diff --git a/elpa/archives/gnu/archive-contents b/elpa/archives/gnu/archive-contents index ead7cf54..61634389 100644 --- a/elpa/archives/gnu/archive-contents +++ b/elpa/archives/gnu/archive-contents @@ -1931,7 +1931,7 @@ (:maintainer "Artur Malabarba" . "emacs@endlessparentheses.com") (:url . "https://github.com/Malabarba/spinner.el"))]) (sql-indent . - [(1 4) + [(1 5) ((cl-lib (0 5))) "Support for indenting code in SQL files." tar diff --git a/elpa/magit-20200318.1224/AUTHORS.md b/elpa/magit-20200318.1224/AUTHORS.md new file mode 100644 index 00000000..84141597 --- /dev/null +++ b/elpa/magit-20200318.1224/AUTHORS.md @@ -0,0 +1,347 @@ +Authors +======= + +The following people have contributed to Magit, including the +libraries `git-commit.el`, `magit-popup.el`, and `with-editor.el` +which are distributed as separate Elpa packages. + +For statistics see https://magit.vc/stats/authors.html. + +Names below are sorted alphabetically. + +Author +------ + +- Marius Vollmer + +Maintainer +---------- + +- Jonas Bernoulli + +Developers +---------- + +- Kyle Meyer +- Noam Postavsky + +Retired Maintainers and Developers +---------------------------------- + +- Nicolas Dudebout +- Peter J. Weisberg +- Pieter Praet +- Phil Jackson +- Rémi Vanicat +- Yann Hodique + +Contributors +------------ + +- Aaron Culich +- Aaron Madlon-Kay +- Abdo Roig-Maranges +- Adam Benanti <0entropy@protonmail.com> +- Adam Kruszewski +- Adam Porter +- Adam Spiers +- Adeodato Simó +- Ævar Arnfjörð Bjarmason +- Alan Falloon +- Alban Gruin +- Aleksey Uimanov +- Alexander Gramiak +- Alexander Miller +- Alex Branham +- Alex Dunn +- Alexey Voinov +- Alex Kost +- Alex Ott +- Allen +- Allen Li +- Andreas Fuchs +- Andreas Liljeqvist +- Andreas Rottmann +- Andrei Chițu +- Andrew Eggenberger +- Andrew Kirkpatrick +- Andrew Schwartzmeyer +- Andrey Smirnov +- Andriy Kmit' +- Andy Sawyer +- Aria Edmonds +- Arialdo Martini +- Arnau Roig Ninerola +- Barak A. Pearlmutter +- Bar Magal +- Bart Bakker +- Basil L. Contovounesios +- Bastian Beischer +- Benjamin Motz +- Ben North +- Ben Walton +- Bob Uhl +- Bradley Wright +- Brandon W Maister +- Brian Warner +- Bryan Shell +- Buster Copley +- Carl Lieberman +- Chillar Anand +- Chris Bernard +- Chris Done +- Chris LaRose +- Chris Moore +- Chris Ring +- Chris Shoemaker +- Christian Dietrich +- Christian Kluge +- Christophe Junke +- Christopher Monsanto +- Clément Pit-Claudel +- Cornelius Mika +- Craig Andera +- Dale Hagglund +- Damien Cassou +- Dan Erikson +- Daniel Brockman +- Daniel Farina +- Daniel Gröber +- Daniel Hackney +- Daniel Kraus +- Daniel Mai +- Daniel Martín +- Dan LaManna +- Danny Zhu +- Dato Simó +- David Abrahams +- David Ellison +- David Ellison +- David Hull +- David L. Rager +- David Wallin +- Dean Kariniemi <8913263+d3k4r@users.noreply.github.com> +- Dennis Paskorz +- Divye Kapoor +- Dominique Quatravaux +- Dominique Quatravaux +- Duianto Vebotci +- Eli Barzilay +- Eric Davis +- Eric Prud'hommeaux +- Eric Schulte +- Erik Anderson +- Evan Torrie +- Evgkeni Sampelnikof +- Eyal Lotem +- Fabian Wiget +- Felix Geller +- Felix Yan +- Feng Li +- Florian Ragwitz +- Fritz Grabo +- Fritz Stelzer +- Geoff Shannon +- George Kadianakis +- Graham Clark +- Graham Dobbins +- Greg A. Woods +- Greg Lucas +- Greg Sexton +- Guillaume Martres +- Hannu Koivisto +- Hans-Peter Deifel +- Hussein Ait-Lahcen +- Ian Eure +- Ingo Lohmar +- Ioan-Adrian Ratiu +- Ivan Brennan +- Jan Tatarik +- Jasper St. Pierre +- Jeff Bellegarde +- Jeff Dairiki +- Jeremy Meng +- Jesse Alama +- Jim Blandy +- Joakim Jalap +- Johannes Altmanninger +- Johann Klähn +- John Mastro +- John Morris +- John Wiegley +- Jonas Bernoulli +- Jonathan Arnett +- Jonathan Leech-Pepin +- Jonathan Roes +- Jon Vanderwijk +- Jordan Galby +- Jordan Greenberg +- Josh Elsasser +- Josiah Schwab +- Julien Danjou +- Justin Burkett +- Justin Caratzas +- Justin Guenther +- Justin Thomas +- Kan-Ru Chen +- Kenny Ballou +- Keshav Kini +- Kevin Brubeck Unhammer +- Kevin J. Foley +- Kévin Le Gouguec +- Kimberly Wolk +- Knut Olav Bøhmer +- Kyle Meyer +- Laurent Laffont +- Laverne Schrock +- Leandro Facchinetti +- Lele Gaifax +- Leo Liu +- Leonardo Etcheverry +- Lingchao Xin +- Li-Yun Chang +- Lluís Vilanova +- Loic Dachary +- Louis Roché +- Luís Oliveira +- Luke Amdor +- Magnus Malm +- Mak Kolybabi +- Manuel Vázquez Acosta +- Marcel Wolf +- Marc Herbert +- Marcin Bachry +- Marco Craveiro +- Marco Wahl +- Marc Sherry +- Marian Schubert +- Mario Rodas +- Marius Vollmer +- Mark Hepburn +- Mark Karpov +- Mark Oteiza +- Matthew Fluet +- Matthieu Hauglustaine +- Matus Goljer +- Michael Fogleman +- Michael Griffiths +- Michael Heerdegen +- Michal Sojka +- Miciah Masters +- Miles Bader +- Miloš Mošić +- Mitchel Humpherys +- Moritz Bunkus +- Naoya Yamashita +- Natalie Weizenbaum +- Nguyễn Tuấn Anh +- Nic Ferier +- Nick Alcock +- Nick Alexander +- Nick Dimiduk +- Nicklas Lindgren +- Nicolas Dudebout +- Nicolas Petton +- Nicolas Richard +- Nikolay Martynov +- Noam Postavsky +- N. Troy de Freitas +- Ole Arndt +- Oleh Krehel +- Orivej Desh +- Óscar Fuentes +- Paul Stadig +- Pavel Holejsovsky +- Pekka Pessi +- Peter Eisentraut +- Peter Jaros +- Peter J. Weisberg +- Peter Vasil +- Philippe Vaucher +- Philipp Haselwarter +- Philipp Stephani +- Philip Weaver +- Phil Jackson +- Phil Sainty +- Pierre Neidhardt +- Pieter Praet +- Prathamesh Sonpatki +- rabio +- Radon Rosborough +- Rafael Laboissiere +- Raimon Grau +- Ramkumar Ramachandra +- Remco van 't Veer +- Rémi Vanicat +- René Stadler +- Richard Kim +- Robert Boone +- Robin Green +- Roey Darwish Dror +- Roger Crew +- Romain Francoise +- Ron Parker +- Roy Crihfield +- Rüdiger Sonderfeld +- Russell Black +- Ryan C. Thompson +- Samuel Bronson +- Samuel W. Flint +- Sanjoy Das +- Sean Allred +- Sean Bryant +- Sean Whitton +- Sebastian Wiesner +- Sébastien Gross +- Seong-Kook Shin +- Sergey Pashinin +- Sergey Vinokurov +- Servilio Afre Puentes +- Silent Sphere +- Štěpán Němec +- Steven Chow +- Steven E. Harris +- Steven Thomas +- Steven Vancoillie +- Steve Purcell +- Suhail Shergill +- Sylvain Rousseau +- Syohei Yoshida +- Takafumi Arakaki +- Tassilo Horn +- Teemu Likonen +- Teruki Shigitani +- Thierry Volpiatto +- Thomas A Caswell +- Thomas Fini Hansen +- Thomas Frössman +- Thomas Jost +- Thomas Riccardi +- Tibor Simko +- Timo Juhani Lindfors +- Tim Perkins +- Tim Wraight +- Ting-Yu Lin +- Tom Feist +- Topi Miettinen +- Troy Hinckley +- Tsuyoshi Kitamoto +- Tunc Uzlu +- Vineet Naik +- Vitaly Ostashov +- Vladimir Panteleev +- Wei Huang +- Wilfred Hughes +- Win Treese +- Wouter Bolsterlee +- Xavier Noria +- Xu Chunyang +- Yann Hodique +- Ynilu +- York Zhao +- Yuichi Higashi +- Yuri Khan +- Zach Latta +- zakora +- Zhu Zihao +- zilongshanren diff --git a/elpa/magit-20200318.1224/LICENSE b/elpa/magit-20200318.1224/LICENSE new file mode 100644 index 00000000..44325404 --- /dev/null +++ b/elpa/magit-20200318.1224/LICENSE @@ -0,0 +1,676 @@ + + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program 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. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. + diff --git a/elpa/magit-20200318.1224/dir b/elpa/magit-20200318.1224/dir new file mode 100644 index 00000000..dfdbd715 --- /dev/null +++ b/elpa/magit-20200318.1224/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* Magit: (magit). Using Git from Emacs with Magit. diff --git a/elpa/magit-20200318.1224/git-rebase.el b/elpa/magit-20200318.1224/git-rebase.el new file mode 100644 index 00000000..4ca8e9b5 --- /dev/null +++ b/elpa/magit-20200318.1224/git-rebase.el @@ -0,0 +1,804 @@ +;;; git-rebase.el --- Edit Git rebase files -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Phil Jackson +;; Maintainer: Jonas Bernoulli + +;; This file is not part of GNU Emacs. + +;; This file 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, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This package assists the user in editing the list of commits to be +;; rewritten during an interactive rebase. + +;; When the user initiates an interactive rebase, e.g. using "r e" in +;; a Magit buffer or on the command line using "git rebase -i REV", +;; Git invokes the `$GIT_SEQUENCE_EDITOR' (or if that is undefined +;; `$GIT_EDITOR' or even `$EDITOR') letting the user rearrange, drop, +;; reword, edit, and squash commits. + +;; This package provides the major-mode `git-rebase-mode' which makes +;; doing so much more fun, by making the buffer more colorful and +;; providing the following commands: +;; +;; C-c C-c Tell Git to make it happen. +;; C-c C-k Tell Git that you changed your mind, i.e. abort. +;; +;; p Move point to previous line. +;; n Move point to next line. +;; +;; M-p Move the commit at point up. +;; M-n Move the commit at point down. +;; +;; k Drop the commit at point. +;; c Don't drop the commit at point. +;; r Change the message of the commit at point. +;; e Edit the commit at point. +;; s Squash the commit at point, into the one above. +;; f Like "s" but don't also edit the commit message. +;; b Break for editing at this point in the sequence. +;; x Add a script to be run with the commit at point +;; being checked out. +;; z Add noop action at point. +;; +;; SPC Show the commit at point in another buffer. +;; RET Show the commit at point in another buffer and +;; select its window. +;; C-/ Undo last change. +;; +;; Commands for --rebase-merges: +;; l Associate label with current HEAD in sequence. +;; MM Merge specified revisions into HEAD. +;; Mt Toggle whether the merge will invoke an editor +;; before committing. +;; t Reset HEAD to the specified label. + +;; You should probably also read the `git-rebase' manpage. + +;;; Code: + +(require 'dash) +(require 'easymenu) +(require 'server) +(require 'with-editor) +(require 'magit) + +(and (require 'async-bytecomp nil t) + (let ((pkgs (bound-and-true-p async-bytecomp-allowed-packages))) + (if (consp pkgs) + (cl-intersection '(all magit) pkgs) + (memq pkgs '(all t)))) + (fboundp 'async-bytecomp-package-mode) + (async-bytecomp-package-mode 1)) + +(eval-when-compile (require 'recentf)) + +;;; Options +;;;; Variables + +(defgroup git-rebase nil + "Edit Git rebase sequences." + :link '(info-link "(magit)Editing Rebase Sequences") + :group 'tools) + +(defcustom git-rebase-auto-advance t + "Whether to move to next line after changing a line." + :group 'git-rebase + :type 'boolean) + +(defcustom git-rebase-show-instructions t + "Whether to show usage instructions inside the rebase buffer." + :group 'git-rebase + :type 'boolean) + +(defcustom git-rebase-confirm-cancel t + "Whether confirmation is required to cancel." + :group 'git-rebase + :type 'boolean) + +;;;; Faces + +(defgroup git-rebase-faces nil + "Faces used by Git-Rebase mode." + :group 'faces + :group 'git-rebase) + +(defface git-rebase-hash '((t (:inherit magit-hash))) + "Face for commit hashes." + :group 'git-rebase-faces) + +(defface git-rebase-label '((t (:inherit magit-refname))) + "Face for labels in label, merge, and reset lines." + :group 'git-rebase-faces) + +(defface git-rebase-description nil + "Face for commit descriptions." + :group 'git-rebase-faces) + +(defface git-rebase-killed-action + '((t (:inherit font-lock-comment-face :strike-through t))) + "Face for commented commit action lines." + :group 'git-rebase-faces) + +(defface git-rebase-comment-hash + '((t (:inherit git-rebase-hash :weight bold))) + "Face for commit hashes in commit message comments." + :group 'git-rebase-faces) + +(defface git-rebase-comment-heading + '((t :inherit font-lock-keyword-face)) + "Face for headings in rebase message comments." + :group 'git-commit-faces) + +;;; Keymaps + +(defvar git-rebase-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map special-mode-map) + (define-key map (kbd "C-m") 'git-rebase-show-commit) + (define-key map (kbd "p") 'git-rebase-backward-line) + (define-key map (kbd "n") 'forward-line) + (define-key map (kbd "M-p") 'git-rebase-move-line-up) + (define-key map (kbd "M-n") 'git-rebase-move-line-down) + (define-key map (kbd "c") 'git-rebase-pick) + (define-key map (kbd "k") 'git-rebase-kill-line) + (define-key map (kbd "C-k") 'git-rebase-kill-line) + (define-key map (kbd "b") 'git-rebase-break) + (define-key map (kbd "e") 'git-rebase-edit) + (define-key map (kbd "l") 'git-rebase-label) + (define-key map (kbd "MM") 'git-rebase-merge) + (define-key map (kbd "Mt") 'git-rebase-merge-toggle-editmsg) + (define-key map (kbd "m") 'git-rebase-edit) + (define-key map (kbd "f") 'git-rebase-fixup) + (define-key map (kbd "q") 'undefined) + (define-key map (kbd "r") 'git-rebase-reword) + (define-key map (kbd "w") 'git-rebase-reword) + (define-key map (kbd "s") 'git-rebase-squash) + (define-key map (kbd "t") 'git-rebase-reset) + (define-key map (kbd "x") 'git-rebase-exec) + (define-key map (kbd "y") 'git-rebase-insert) + (define-key map (kbd "z") 'git-rebase-noop) + (define-key map (kbd "SPC") 'git-rebase-show-or-scroll-up) + (define-key map (kbd "DEL") 'git-rebase-show-or-scroll-down) + (define-key map (kbd "C-x C-t") 'git-rebase-move-line-up) + (define-key map [M-up] 'git-rebase-move-line-up) + (define-key map [M-down] 'git-rebase-move-line-down) + (define-key map [remap undo] 'git-rebase-undo) + map) + "Keymap for Git-Rebase mode.") + +(put 'git-rebase-reword :advertised-binding (kbd "r")) +(put 'git-rebase-move-line-up :advertised-binding (kbd "M-p")) +(put 'git-rebase-kill-line :advertised-binding (kbd "k")) + +(easy-menu-define git-rebase-mode-menu git-rebase-mode-map + "Git-Rebase mode menu" + '("Rebase" + ["Pick" git-rebase-pick t] + ["Reword" git-rebase-reword t] + ["Edit" git-rebase-edit t] + ["Squash" git-rebase-squash t] + ["Fixup" git-rebase-fixup t] + ["Kill" git-rebase-kill-line t] + ["Noop" git-rebase-noop t] + ["Execute" git-rebase-exec t] + ["Move Down" git-rebase-move-line-down t] + ["Move Up" git-rebase-move-line-up t] + "---" + ["Cancel" with-editor-cancel t] + ["Finish" with-editor-finish t])) + +(defvar git-rebase-command-descriptions + '((with-editor-finish . "tell Git to make it happen") + (with-editor-cancel . "tell Git that you changed your mind, i.e. abort") + (git-rebase-backward-line . "move point to previous line") + (forward-line . "move point to next line") + (git-rebase-move-line-up . "move the commit at point up") + (git-rebase-move-line-down . "move the commit at point down") + (git-rebase-show-or-scroll-up . "show the commit at point in another buffer") + (git-rebase-show-commit + . "show the commit at point in another buffer and select its window") + (undo . "undo last change") + (git-rebase-kill-line . "drop the commit at point") + (git-rebase-insert . "insert a line for an arbitrary commit") + (git-rebase-noop . "add noop action at point"))) + +;;; Commands + +(defun git-rebase-pick () + "Use commit on current line." + (interactive) + (git-rebase-set-action "pick")) + +(defun git-rebase-reword () + "Edit message of commit on current line." + (interactive) + (git-rebase-set-action "reword")) + +(defun git-rebase-edit () + "Stop at the commit on the current line." + (interactive) + (git-rebase-set-action "edit")) + +(defun git-rebase-squash () + "Meld commit on current line into previous commit, edit message." + (interactive) + (git-rebase-set-action "squash")) + +(defun git-rebase-fixup () + "Meld commit on current line into previous commit, discard its message." + (interactive) + (git-rebase-set-action "fixup")) + +(defvar-local git-rebase-comment-re nil) + +(defvar git-rebase-short-options + '((?b . "break") + (?e . "edit") + (?f . "fixup") + (?l . "label") + (?m . "merge") + (?p . "pick") + (?r . "reword") + (?s . "squash") + (?t . "reset") + (?x . "exec")) + "Alist mapping single key of an action to the full name.") + +(defclass git-rebase-action () + (;; action-type: commit, exec, bare, label, merge + (action-type :initarg :action-type :initform nil) + ;; Examples for each action type: + ;; | action | action options | target | trailer | + ;; |--------+----------------+---------+---------| + ;; | pick | | hash | subject | + ;; | exec | | command | | + ;; | noop | | | | + ;; | reset | | name | subject | + ;; | merge | -C hash | name | subject | + (action :initarg :action :initform nil) + (action-options :initarg :action-options :initform nil) + (target :initarg :target :initform nil) + (trailer :initarg :trailer :initform nil) + (comment-p :initarg :comment-p :initform nil))) + +(defvar git-rebase-line-regexps + `((commit . ,(concat + (regexp-opt '("e" "edit" + "f" "fixup" + "p" "pick" + "r" "reword" + "s" "squash") + "\\(?1:") + " \\(?3:[^ \n]+\\) \\(?4:.*\\)")) + (exec . "\\(?1:x\\|exec\\) \\(?3:.*\\)") + (bare . ,(concat (regexp-opt '("b" "break" "noop") "\\(?1:") + " *$")) + (label . ,(concat (regexp-opt '("l" "label" + "t" "reset") + "\\(?1:") + " \\(?3:[^ \n]+\\) ?\\(?4:.*\\)")) + (merge . ,(concat "\\(?1:m\\|merge\\) " + "\\(?:\\(?2:-[cC] [^ \n]+\\) \\)?" + "\\(?3:[^ \n]+\\)" + " ?\\(?4:.*\\)")))) + +;;;###autoload +(defun git-rebase-current-line () + "Parse current line into a `git-rebase-action' instance. +If the current line isn't recognized as a rebase line, an +instance with all nil values is returned." + (save-excursion + (goto-char (line-beginning-position)) + (if-let ((re-start (concat "^\\(?5:" (regexp-quote comment-start) + "\\)? *")) + (type (-some (lambda (arg) + (let ((case-fold-search nil)) + (and (looking-at (concat re-start (cdr arg))) + (car arg)))) + git-rebase-line-regexps))) + (git-rebase-action + :action-type type + :action (when-let ((action (match-string-no-properties 1))) + (or (cdr (assoc action git-rebase-short-options)) + action)) + :action-options (match-string-no-properties 2) + :target (match-string-no-properties 3) + :trailer (match-string-no-properties 4) + :comment-p (and (match-string 5) t)) + ;; Use default empty class rather than nil to ease handling. + (git-rebase-action)))) + +(defun git-rebase-set-action (action) + (goto-char (line-beginning-position)) + (with-slots (action-type target trailer) + (git-rebase-current-line) + (if (eq action-type 'commit) + (let ((inhibit-read-only t)) + (magit-delete-line) + (insert (concat action " " target " " trailer "\n")) + (unless git-rebase-auto-advance + (forward-line -1))) + (ding)))) + +(defun git-rebase-line-p (&optional pos) + (save-excursion + (when pos (goto-char pos)) + (and (oref (git-rebase-current-line) action-type) + t))) + +(defun git-rebase-region-bounds () + (when (use-region-p) + (let ((beg (save-excursion (goto-char (region-beginning)) + (line-beginning-position))) + (end (save-excursion (goto-char (region-end)) + (line-end-position)))) + (when (and (git-rebase-line-p beg) + (git-rebase-line-p end)) + (list beg (1+ end)))))) + +(defun git-rebase-move-line-down (n) + "Move the current commit (or command) N lines down. +If N is negative, move the commit up instead. With an active +region, move all the lines that the region touches, not just the +current line." + (interactive "p") + (pcase-let* ((`(,beg ,end) + (or (git-rebase-region-bounds) + (list (line-beginning-position) + (1+ (line-end-position))))) + (pt-offset (- (point) beg)) + (mark-offset (and mark-active (- (mark) beg)))) + (save-restriction + (narrow-to-region + (point-min) + (1- + (if git-rebase-show-instructions + (save-excursion + (goto-char (point-min)) + (while (or (git-rebase-line-p) + ;; The output for --rebase-merges has empty + ;; lines and "Branch" comments interspersed. + (looking-at-p "^$") + (looking-at-p (concat git-rebase-comment-re + " Branch"))) + (forward-line)) + (line-beginning-position)) + (point-max)))) + (if (or (and (< n 0) (= beg (point-min))) + (and (> n 0) (= end (point-max))) + (> end (point-max))) + (ding) + (goto-char (if (< n 0) beg end)) + (forward-line n) + (atomic-change-group + (let ((inhibit-read-only t)) + (insert (delete-and-extract-region beg end))) + (let ((new-beg (- (point) (- end beg)))) + (when (use-region-p) + (setq deactivate-mark nil) + (set-mark (+ new-beg mark-offset))) + (goto-char (+ new-beg pt-offset)))))))) + +(defun git-rebase-move-line-up (n) + "Move the current commit (or command) N lines up. +If N is negative, move the commit down instead. With an active +region, move all the lines that the region touches, not just the +current line." + (interactive "p") + (git-rebase-move-line-down (- n))) + +(defun git-rebase-highlight-region (start end window rol) + (let ((inhibit-read-only t) + (deactivate-mark nil) + (bounds (git-rebase-region-bounds))) + (mapc #'delete-overlay magit-section-highlight-overlays) + (when bounds + (magit-section-make-overlay (car bounds) (cadr bounds) + 'magit-section-heading-selection)) + (if (and bounds (not magit-keep-region-overlay)) + (funcall (default-value 'redisplay-unhighlight-region-function) rol) + (funcall (default-value 'redisplay-highlight-region-function) + start end window rol)))) + +(defun git-rebase-unhighlight-region (rol) + (mapc #'delete-overlay magit-section-highlight-overlays) + (funcall (default-value 'redisplay-unhighlight-region-function) rol)) + +(defun git-rebase-kill-line () + "Kill the current action line." + (interactive) + (goto-char (line-beginning-position)) + (unless (oref (git-rebase-current-line) comment-p) + (let ((inhibit-read-only t)) + (insert comment-start) + (insert " ")) + (goto-char (line-beginning-position)) + (when git-rebase-auto-advance + (forward-line)))) + +(defun git-rebase-insert (rev) + "Read an arbitrary commit and insert it below current line." + (interactive (list (magit-read-branch-or-commit "Insert revision"))) + (forward-line) + (--if-let (magit-rev-format "%h %s" rev) + (let ((inhibit-read-only t)) + (insert "pick " it ?\n)) + (user-error "Unknown revision"))) + +(defun git-rebase-set-noncommit-action (action value-fn arg) + (goto-char (line-beginning-position)) + (pcase-let* ((inhibit-read-only t) + (`(,initial ,trailer ,comment-p) + (and (not arg) + (with-slots ((ln-action action) + target trailer comment-p) + (git-rebase-current-line) + (and (equal ln-action action) + (list target trailer comment-p))))) + (value (funcall value-fn initial))) + (pcase (list value initial comment-p) + (`("" nil ,_) + (ding)) + (`("" ,_ ,_) + (magit-delete-line)) + (_ + (if initial + (magit-delete-line) + (forward-line)) + (insert (concat action " " value + (and (equal value initial) + trailer + (concat " " trailer)) + "\n")) + (unless git-rebase-auto-advance + (forward-line -1)))))) + +(defun git-rebase-exec (arg) + "Insert a shell command to be run after the current commit. + +If there already is such a command on the current line, then edit +that instead. With a prefix argument insert a new command even +when there already is one on the current line. With empty input +remove the command on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "exec" + (lambda (initial) (read-shell-command "Execute: " initial)) + arg)) + +(defun git-rebase-label (arg) + "Add a label after the current commit. +If there already is a label on the current line, then edit that +instead. With a prefix argument, insert a new label even when +there is already a label on the current line. With empty input, +remove the label on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "label" + (lambda (initial) + (read-from-minibuffer + "Label: " initial magit-minibuffer-local-ns-map)) + arg)) + +(defun git-rebase-buffer-labels () + (let (labels) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\(?:l\\|label\\) \\([^ \n]+\\)" nil t) + (push (match-string-no-properties 1) labels))) + (nreverse labels))) + +(defun git-rebase-reset (arg) + "Reset the current HEAD to a label. +If there already is a reset command on the current line, then +edit that instead. With a prefix argument, insert a new reset +line even when point is already on a reset line. With empty +input, remove the reset command on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "reset" + (lambda (initial) + (or (magit-completing-read "Label" (git-rebase-buffer-labels) + nil t initial) + "")) + arg)) + +(defun git-rebase-merge (arg) + "Add a merge command after the current commit. +If there is already a merge command on the current line, then +replace that command instead. With a prefix argument, insert a +new merge command even when there is already one on the current +line. With empty input, remove the merge command on the current +line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "merge" + (lambda (_) + (or (magit-completing-read "Merge" (git-rebase-buffer-labels)) + "")) + arg)) + +(defun git-rebase-merge-toggle-editmsg () + "Toggle whether an editor is invoked when performing the merge at point. +When a merge command uses a lower-case -c, the message for the +specified commit will be opened in an editor before creating the +commit. For an upper-case -C, the message will be used as is." + (interactive) + (with-slots (action-type target action-options trailer) + (git-rebase-current-line) + (if (eq action-type 'merge) + (let ((inhibit-read-only t)) + (magit-delete-line) + (insert + (format "merge %s %s %s\n" + (replace-regexp-in-string + "-[cC]" (lambda (c) + (if (equal c "-c") "-C" "-c")) + action-options t t) + target + trailer))) + (ding)))) + +(defun git-rebase-set-bare-action (action arg) + (goto-char (line-beginning-position)) + (with-slots ((ln-action action) comment-p) + (git-rebase-current-line) + (let ((same-action-p (equal action ln-action)) + (inhibit-read-only t)) + (when (or arg + (not ln-action) + (not same-action-p) + (and same-action-p comment-p)) + (unless (or arg (not same-action-p)) + (magit-delete-line)) + (insert action ?\n) + (unless git-rebase-auto-advance + (forward-line -1)))))) + +(defun git-rebase-noop (&optional arg) + "Add noop action at point. + +If the current line already contains a noop action, leave it +unchanged. If there is a commented noop action present, remove +the comment. Otherwise add a new noop action. With a prefix +argument insert a new noop action regardless of what is already +present on the current line. + +A noop action can be used to make git perform a rebase even if +no commits are selected. Without the noop action present, git +would see an empty file and therefore do nothing." + (interactive "P") + (git-rebase-set-bare-action "noop" arg)) + +(defun git-rebase-break (&optional arg) + "Add break action at point. + +If there is a commented break action present, remove the comment. +If the current line already contains a break action, add another +break action only if a prefix argument is given. + +A break action can be used to interrupt the rebase at the +specified point. It is particularly useful for pausing before +the first commit in the sequence. For other cases, the +equivalent behavior can be achieved with `git-rebase-edit'." + (interactive "P") + (git-rebase-set-bare-action "break" arg)) + +(defun git-rebase-undo (&optional arg) + "Undo some previous changes. +Like `undo' but works in read-only buffers." + (interactive "P") + (let ((inhibit-read-only t)) + (undo arg))) + +(defun git-rebase--show-commit (&optional scroll) + (let ((disable-magit-save-buffers t)) + (save-excursion + (goto-char (line-beginning-position)) + (--if-let (with-slots (action-type target) (git-rebase-current-line) + (and (eq action-type 'commit) + target)) + (pcase scroll + (`up (magit-diff-show-or-scroll-up)) + (`down (magit-diff-show-or-scroll-down)) + (_ (apply #'magit-show-commit it + (magit-diff-arguments 'magit-revision-mode)))) + (ding))))) + +(defun git-rebase-show-commit () + "Show the commit on the current line if any." + (interactive) + (git-rebase--show-commit)) + +(defun git-rebase-show-or-scroll-up () + "Update the commit buffer for commit on current line. + +Either show the commit at point in the appropriate buffer, or if +that buffer is already being displayed in the current frame and +contains information about that commit, then instead scroll the +buffer up." + (interactive) + (git-rebase--show-commit 'up)) + +(defun git-rebase-show-or-scroll-down () + "Update the commit buffer for commit on current line. + +Either show the commit at point in the appropriate buffer, or if +that buffer is already being displayed in the current frame and +contains information about that commit, then instead scroll the +buffer down." + (interactive) + (git-rebase--show-commit 'down)) + +(defun git-rebase-backward-line (&optional n) + "Move N lines backward (forward if N is negative). +Like `forward-line' but go into the opposite direction." + (interactive "p") + (forward-line (- (or n 1)))) + +;;; Mode + +;;;###autoload +(define-derived-mode git-rebase-mode special-mode "Git Rebase" + "Major mode for editing of a Git rebase file. + +Rebase files are generated when you run 'git rebase -i' or run +`magit-interactive-rebase'. They describe how Git should perform +the rebase. See the documentation for git-rebase (e.g., by +running 'man git-rebase' at the command line) for details." + :group 'git-rebase + (setq comment-start (or (magit-get "core.commentChar") "#")) + (setq git-rebase-comment-re (concat "^" (regexp-quote comment-start))) + (setq font-lock-defaults (list (git-rebase-mode-font-lock-keywords) t t)) + (unless git-rebase-show-instructions + (let ((inhibit-read-only t)) + (flush-lines git-rebase-comment-re))) + (unless with-editor-mode + ;; Maybe already enabled when using `shell-command' or an Emacs shell. + (with-editor-mode 1)) + (when git-rebase-confirm-cancel + (add-hook 'with-editor-cancel-query-functions + 'git-rebase-cancel-confirm nil t)) + (setq-local redisplay-highlight-region-function 'git-rebase-highlight-region) + (setq-local redisplay-unhighlight-region-function 'git-rebase-unhighlight-region) + (add-hook 'with-editor-pre-cancel-hook 'git-rebase-autostash-save nil t) + (add-hook 'with-editor-post-cancel-hook 'git-rebase-autostash-apply nil t) + (setq imenu-prev-index-position-function + #'magit-imenu--rebase-prev-index-position-function) + (setq imenu-extract-index-name-function + #'magit-imenu--rebase-extract-index-name-function) + (when (boundp 'save-place) + (setq save-place nil))) + +(defun git-rebase-cancel-confirm (force) + (or (not (buffer-modified-p)) + force + (magit-confirm 'abort-rebase "Abort this rebase" nil 'noabort))) + +(defun git-rebase-autostash-save () + (--when-let (magit-file-line (magit-git-dir "rebase-merge/autostash")) + (push (cons 'stash it) with-editor-cancel-alist))) + +(defun git-rebase-autostash-apply () + (--when-let (cdr (assq 'stash with-editor-cancel-alist)) + (magit-stash-apply it))) + +(defun git-rebase-match-comment-line (limit) + (re-search-forward (concat git-rebase-comment-re ".*") limit t)) + +(defun git-rebase-mode-font-lock-keywords () + "Font lock keywords for Git-Rebase mode." + `((,(concat "^" (cdr (assq 'commit git-rebase-line-regexps))) + (1 'font-lock-keyword-face) + (3 'git-rebase-hash) + (4 'git-rebase-description)) + (,(concat "^" (cdr (assq 'exec git-rebase-line-regexps))) + (1 'font-lock-keyword-face) + (3 'git-rebase-description)) + (,(concat "^" (cdr (assq 'bare git-rebase-line-regexps))) + (1 'font-lock-keyword-face)) + (,(concat "^" (cdr (assq 'label git-rebase-line-regexps))) + (1 'font-lock-keyword-face) + (3 'git-rebase-label) + (4 'font-lock-comment-face)) + ("^\\(m\\(?:erge\\)?\\) -[Cc] \\([^ \n]+\\) \\([^ \n]+\\)\\( #.*\\)?" + (1 'font-lock-keyword-face) + (2 'git-rebase-hash) + (3 'git-rebase-label) + (4 'font-lock-comment-face)) + ("^\\(m\\(?:erge\\)?\\) \\([^ \n]+\\)" + (1 'font-lock-keyword-face) + (2 'git-rebase-label)) + (,(concat git-rebase-comment-re " *" + (cdr (assq 'commit git-rebase-line-regexps))) + 0 'git-rebase-killed-action t) + (git-rebase-match-comment-line 0 'font-lock-comment-face) + ("\\[[^[]*\\]" + 0 'magit-keyword t) + ("\\(?:fixup!\\|squash!\\)" + 0 'magit-keyword-squash t) + (,(format "^%s Rebase \\([^ ]*\\) onto \\([^ ]*\\)" comment-start) + (1 'git-rebase-comment-hash t) + (2 'git-rebase-comment-hash t)) + (,(format "^%s \\(Commands:\\)" comment-start) + (1 'git-rebase-comment-heading t)) + (,(format "^%s Branch \\(.*\\)" comment-start) + (1 'git-rebase-label t)))) + +(defun git-rebase-mode-show-keybindings () + "Modify the \"Commands:\" section of the comment Git generates +at the bottom of the file so that in place of the one-letter +abbreviation for the command, it shows the command's keybinding. +By default, this is the same except for the \"pick\" command." + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (when (and git-rebase-show-instructions + (re-search-forward + (concat git-rebase-comment-re "\\s-+p, pick") + nil t)) + (goto-char (line-beginning-position)) + (pcase-dolist (`(,cmd . ,desc) git-rebase-command-descriptions) + (insert (format "%s %-8s %s\n" + comment-start + (substitute-command-keys (format "\\[%s]" cmd)) + desc))) + (while (re-search-forward (concat git-rebase-comment-re + "\\( ?\\)\\([^\n,],\\) " + "\\([^\n ]+\\) ") + nil t) + (let ((cmd (intern (concat "git-rebase-" (match-string 3))))) + (if (not (fboundp cmd)) + (delete-region (line-beginning-position) (1+ (line-end-position))) + (replace-match " " t t nil 1) + (replace-match + (format "%-8s" + (mapconcat #'key-description + (--remove (eq (elt it 0) 'menu-bar) + (reverse (where-is-internal + cmd git-rebase-mode-map))) + ", ")) + t t nil 2)))))))) + +(add-hook 'git-rebase-mode-hook 'git-rebase-mode-show-keybindings t) + +(defun git-rebase-mode-disable-before-save-hook () + (set (make-local-variable 'before-save-hook) nil)) + +(add-hook 'git-rebase-mode-hook 'git-rebase-mode-disable-before-save-hook) + +;;;###autoload +(defconst git-rebase-filename-regexp "/git-rebase-todo\\'") +;;;###autoload +(add-to-list 'auto-mode-alist + (cons git-rebase-filename-regexp 'git-rebase-mode)) + +(add-to-list 'with-editor-server-window-alist + (cons git-rebase-filename-regexp 'switch-to-buffer)) + +(eval-after-load 'recentf + '(add-to-list 'recentf-exclude git-rebase-filename-regexp)) + +(add-to-list 'with-editor-file-name-history-exclude git-rebase-filename-regexp) + +;;; _ +(provide 'git-rebase) +;;; git-rebase.el ends here diff --git a/elpa/magit-20200318.1224/git-rebase.elc b/elpa/magit-20200318.1224/git-rebase.elc new file mode 100644 index 00000000..de6f1586 Binary files /dev/null and b/elpa/magit-20200318.1224/git-rebase.elc differ diff --git a/elpa/magit-20200318.1224/magit-apply.el b/elpa/magit-20200318.1224/magit-apply.el new file mode 100644 index 00000000..766a3ccc --- /dev/null +++ b/elpa/magit-20200318.1224/magit-apply.el @@ -0,0 +1,739 @@ +;;; magit-apply.el --- apply Git diffs -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements commands for applying Git diffs or parts +;; of such a diff. The supported "apply variants" are apply, stage, +;; unstage, discard, and reverse - more than Git itself knows about, +;; at least at the porcelain level. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit-core) +(require 'magit-diff) +(require 'magit-wip) + +(require 'transient) ; See #3732. + +;; For `magit-apply' +(declare-function magit-am "magit-sequence" ()) +(declare-function magit-patch-apply "magit-files" ()) +;; For `magit-discard-files' +(declare-function magit-checkout-stage "magit-merge" (file arg)) +(declare-function magit-checkout-read-stage "magit-merge" (file)) +(defvar auto-revert-verbose) +;; For `magit-stage-untracked' +(declare-function magit-submodule-add-1 "magit-submodule" + (url &optional path name args)) +(declare-function magit-submodule-read-name-for-path "magit-submodule" + (path &optional prefer-short)) +(declare-function borg--maybe-absorb-gitdir "borg" (pkg)) +(declare-function borg--sort-submodule-sections "borg" (file)) +(defvar borg-user-emacs-directory) + +;;; Options + +(defcustom magit-delete-by-moving-to-trash t + "Whether Magit uses the system's trash can. + +You should absolutely not disable this and also remove `discard' +from `magit-no-confirm'. You shouldn't do that even if you have +all of the Magit-Wip modes enabled, because those modes do not +track any files that are not tracked in the proper branch." + :package-version '(magit . "2.1.0") + :group 'magit-essentials + :type 'boolean) + +(defcustom magit-unstage-committed t + "Whether unstaging a committed change reverts it instead. + +A committed change cannot be unstaged, because staging and +unstaging are actions that are concerned with the differences +between the index and the working tree, not with committed +changes. + +If this option is non-nil (the default), then typing \"u\" +\(`magit-unstage') on a committed change, causes it to be +reversed in the index but not the working tree. For more +information see command `magit-reverse-in-index'." + :package-version '(magit . "2.4.1") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-reverse-atomically nil + "Whether to reverse changes atomically. + +If some changes can be reversed while others cannot, then nothing +is reversed if the value of this option is non-nil. But when it +is nil, then the changes that can be reversed are reversed and +for the other changes diff files are created that contain the +rejected reversals." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-post-stage-hook nil + "Hook run after staging changes. +This hook is run by `magit-refresh' if `this-command' +is a member of `magit-post-stage-hook-commands'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +(defvar magit-post-stage-hook-commands + '(magit-stage magit-stage-file magit-stage-modified)) + +(defcustom magit-post-unstage-hook nil + "Hook run after unstaging changes. +This hook is run by `magit-refresh' if `this-command' +is a member of `magit-post-unstage-hook-commands'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +(defvar magit-post-unstage-hook-commands + '(magit-unstage magit-unstage-file magit-unstage-all)) + +;;; Commands +;;;; Apply + +(defun magit-apply (&rest args) + "Apply the change at point to the working tree. +With a prefix argument fallback to a 3-way merge. Doing +so causes the change to be applied to the index as well." + (interactive (and current-prefix-arg (list "--3way"))) + (--when-let (magit-apply--get-selection) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(,(or `unstaged `staged) ,_) + (user-error "Change is already in the working tree")) + (`(untracked ,(or `file `files)) + (call-interactively 'magit-am)) + (`(,_ region) (magit-apply-region it args)) + (`(,_ hunk) (magit-apply-hunk it args)) + (`(,_ hunks) (magit-apply-hunks it args)) + (`(rebase-sequence file) + (call-interactively 'magit-patch-apply)) + (`(,_ file) (magit-apply-diff it args)) + (`(,_ files) (magit-apply-diffs it args))))) + +(defun magit-apply--section-content (section) + (buffer-substring-no-properties (if (magit-hunk-section-p section) + (oref section start) + (oref section content)) + (oref section end))) + +(defun magit-apply-diffs (sections &rest args) + (setq sections (magit-apply--get-diffs sections)) + (magit-apply-patch sections args + (mapconcat + (lambda (s) + (concat (magit-diff-file-header s) + (magit-apply--section-content s))) + sections ""))) + +(defun magit-apply-diff (section &rest args) + (setq section (car (magit-apply--get-diffs (list section)))) + (magit-apply-patch section args + (concat (magit-diff-file-header section) + (magit-apply--section-content section)))) + +(defun magit-apply--adjust-hunk-new-starts (hunks) + "Adjust new line numbers in headers of HUNKS for partial application. +HUNKS should be a list of ordered, contiguous hunks to be applied +from a file. For example, if there is a sequence of hunks with +the headers + + @@ -2,6 +2,7 @@ + @@ -10,6 +11,7 @@ + @@ -18,6 +20,7 @@ + +and only the second and third are to be applied, they would be +adjusted as \"@@ -10,6 +10,7 @@\" and \"@@ -18,6 +19,7 @@\"." + (let* ((first-hunk (car hunks)) + (offset (if (string-match diff-hunk-header-re-unified first-hunk) + (- (string-to-number (match-string 3 first-hunk)) + (string-to-number (match-string 1 first-hunk))) + (error "Hunk does not have expected header")))) + (if (= offset 0) + hunks + (mapcar (lambda (hunk) + (if (string-match diff-hunk-header-re-unified hunk) + (replace-match (number-to-string + (- (string-to-number (match-string 3 hunk)) + offset)) + t t hunk 3) + (error "Hunk does not have expected header"))) + hunks)))) + +(defun magit-apply--adjust-hunk-new-start (hunk) + (car (magit-apply--adjust-hunk-new-starts (list hunk)))) + +(defun magit-apply-hunks (sections &rest args) + (let ((section (oref (car sections) parent))) + (when (string-match "^diff --cc" (oref section value)) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (magit-apply-patch + section args + (concat (oref section header) + (mapconcat #'identity + (magit-apply--adjust-hunk-new-starts + (mapcar #'magit-apply--section-content sections)) + ""))))) + +(defun magit-apply-hunk (section &rest args) + (when (string-match "^diff --cc" (magit-section-parent-value section)) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (magit-apply-patch (oref section parent) args + (concat (magit-diff-file-header section) + (magit-apply--adjust-hunk-new-start + (magit-apply--section-content section))))) + +(defun magit-apply-region (section &rest args) + (when (string-match "^diff --cc" (magit-section-parent-value section)) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (magit-apply-patch (oref section parent) args + (concat (magit-diff-file-header section) + (magit-apply--adjust-hunk-new-start + (magit-diff-hunk-region-patch section args))))) + +(defun magit-apply-patch (section:s args patch) + (let* ((files (if (atom section:s) + (list (oref section:s value)) + (--map (oref it value) section:s))) + (command (symbol-name this-command)) + (command (if (and command (string-match "^magit-\\([^-]+\\)" command)) + (match-string 1 command) + "apply")) + (ignore-context (magit-diff-ignore-any-space-p))) + (unless (magit-diff-context-p) + (user-error "Not enough context to apply patch. Increase the context")) + (when (and magit-wip-before-change-mode (not inhibit-magit-refresh)) + (magit-wip-commit-before-change files (concat " before " command))) + (with-temp-buffer + (insert patch) + (magit-run-git-with-input + "apply" args "-p0" + (and ignore-context "-C0") + "--ignore-space-change" "-")) + (unless inhibit-magit-refresh + (when magit-wip-after-apply-mode + (magit-wip-commit-after-apply files (concat " after " command))) + (magit-refresh)))) + +(defun magit-apply--get-selection () + (or (magit-region-sections '(hunk file module) t) + (let ((section (magit-current-section))) + (pcase (oref section type) + ((or `hunk `file `module) section) + ((or `staged `unstaged `untracked + `stashed-index `stashed-worktree `stashed-untracked) + (oref section children)) + (_ (user-error "Cannot apply this, it's not a change")))))) + +(defun magit-apply--get-diffs (sections) + (magit-section-case + ([file diffstat] + (--map (or (magit-get-section + (append `((file . ,(oref it value))) + (magit-section-ident magit-root-section))) + (error "Cannot get required diff headers")) + sections)) + (t sections))) + +(defun magit-apply--diff-ignores-whitespace-p () + (and (cl-intersection magit-buffer-diff-args + '("--ignore-space-at-eol" + "--ignore-space-change" + "--ignore-all-space" + "--ignore-blank-lines") + :test #'equal) + t)) + +;;;; Stage + +(defun magit-stage (&optional intent) + "Add the change at point to the staging area. +With a prefix argument, INTENT, and an untracked file (or files) +at point, stage the file but not its content." + (interactive "P") + (--if-let (and (derived-mode-p 'magit-mode) (magit-apply--get-selection)) + (pcase (list (magit-diff-type) + (magit-diff-scope) + (magit-apply--diff-ignores-whitespace-p)) + (`(untracked ,_ ,_) (magit-stage-untracked intent)) + (`(unstaged region ,_) (magit-apply-region it "--cached")) + (`(unstaged hunk ,_) (magit-apply-hunk it "--cached")) + (`(unstaged hunks ,_) (magit-apply-hunks it "--cached")) + (`(unstaged file t) (magit-apply-diff it "--cached")) + (`(unstaged files t) (magit-apply-diffs it "--cached")) + (`(unstaged list t) (magit-apply-diffs it "--cached")) + (`(unstaged file nil) (magit-stage-1 "-u" (list (oref it value)))) + (`(unstaged files nil) (magit-stage-1 "-u" (magit-region-values nil t))) + (`(unstaged list nil) (magit-stage-modified)) + (`(staged ,_ ,_) (user-error "Already staged")) + (`(committed ,_ ,_) (user-error "Cannot stage committed changes")) + (`(undefined ,_ ,_) (user-error "Cannot stage this change"))) + (call-interactively 'magit-stage-file))) + +;;;###autoload +(defun magit-stage-file (file) + "Stage all changes to FILE. +With a prefix argument or when there is no file at point ask for +the file to be staged. Otherwise stage the file at point without +requiring confirmation." + (interactive + (let* ((atpoint (magit-section-value-if 'file)) + (current (magit-file-relative-name)) + (choices (nconc (magit-unstaged-files) + (magit-untracked-files))) + (default (car (member (or atpoint current) choices)))) + (list (if (or current-prefix-arg (not default)) + (magit-completing-read "Stage file" choices + nil t nil nil default) + default)))) + (magit-with-toplevel + (magit-stage-1 nil (list file)))) + +;;;###autoload +(defun magit-stage-modified (&optional all) + "Stage all changes to files modified in the worktree. +Stage all new content of tracked files and remove tracked files +that no longer exist in the working tree from the index also. +With a prefix argument also stage previously untracked (but not +ignored) files." + (interactive "P") + (when (magit-anything-staged-p) + (magit-confirm 'stage-all-changes)) + (magit-with-toplevel + (magit-stage-1 (if all "--all" "-u") magit-buffer-diff-files))) + +(defun magit-stage-1 (arg &optional files) + (magit-wip-commit-before-change files " before stage") + (magit-run-git "add" arg (if files (cons "--" files) ".")) + (when magit-auto-revert-mode + (mapc #'magit-turn-on-auto-revert-mode-if-desired files)) + (magit-wip-commit-after-apply files " after stage")) + +(defun magit-stage-untracked (&optional intent) + (let* ((section (magit-current-section)) + (files (pcase (magit-diff-scope) + (`file (list (oref section value))) + (`files (magit-region-values nil t)) + (`list (magit-untracked-files)))) + plain repos) + (dolist (file files) + (if (and (not (file-symlink-p file)) + (magit-git-repo-p file t)) + (push file repos) + (push file plain))) + (magit-wip-commit-before-change files " before stage") + (when plain + (magit-run-git "add" (and intent "--intent-to-add") + "--" plain) + (when magit-auto-revert-mode + (mapc #'magit-turn-on-auto-revert-mode-if-desired plain))) + (dolist (repo repos) + (save-excursion + (goto-char (oref (magit-get-section + `((file . ,repo) (untracked) (status))) + start)) + (let* ((topdir (magit-toplevel)) + (package + (and (equal (bound-and-true-p borg-user-emacs-directory) + topdir) + (file-name-nondirectory (directory-file-name repo))))) + (magit-submodule-add-1 + (let ((default-directory + (file-name-as-directory (expand-file-name repo)))) + (or (magit-get "remote" (magit-get-some-remote) "url") + (concat (file-name-as-directory ".") repo))) + repo + (magit-submodule-read-name-for-path repo package)) + (when package + (borg--sort-submodule-sections + (expand-file-name ".gitmodules" topdir)) + (let ((default-directory borg-user-emacs-directory)) + (borg--maybe-absorb-gitdir package)) + (when (and (y-or-n-p + (format "Also build and activate `%s' drone?" package)) + (fboundp 'borg-build) + (fboundp 'borg-activate)) + (borg-build package) + (borg-activate package)))))) + (magit-wip-commit-after-apply files " after stage"))) + +;;;; Unstage + +(defun magit-unstage () + "Remove the change at point from the staging area." + (interactive) + (--when-let (magit-apply--get-selection) + (pcase (list (magit-diff-type) + (magit-diff-scope) + (magit-apply--diff-ignores-whitespace-p)) + (`(untracked ,_ ,_) (user-error "Cannot unstage untracked changes")) + (`(unstaged file ,_) (magit-unstage-intent (list (oref it value)))) + (`(unstaged files ,_) (magit-unstage-intent (magit-region-values nil t))) + (`(unstaged ,_ ,_) (user-error "Already unstaged")) + (`(staged region ,_) (magit-apply-region it "--reverse" "--cached")) + (`(staged hunk ,_) (magit-apply-hunk it "--reverse" "--cached")) + (`(staged hunks ,_) (magit-apply-hunks it "--reverse" "--cached")) + (`(staged file t) (magit-apply-diff it "--reverse" "--cached")) + (`(staged files t) (magit-apply-diffs it "--reverse" "--cached")) + (`(staged list t) (magit-apply-diffs it "--reverse" "--cached")) + (`(staged file nil) (magit-unstage-1 (list (oref it value)))) + (`(staged files nil) (magit-unstage-1 (magit-region-values nil t))) + (`(staged list nil) (magit-unstage-all)) + (`(committed ,_ ,_) (if magit-unstage-committed + (magit-reverse-in-index) + (user-error "Cannot unstage committed changes"))) + (`(undefined ,_ ,_) (user-error "Cannot unstage this change"))))) + +;;;###autoload +(defun magit-unstage-file (file) + "Unstage all changes to FILE. +With a prefix argument or when there is no file at point ask for +the file to be unstaged. Otherwise unstage the file at point +without requiring confirmation." + (interactive + (let* ((atpoint (magit-section-value-if 'file)) + (current (magit-file-relative-name)) + (choices (magit-staged-files)) + (default (car (member (or atpoint current) choices)))) + (list (if (or current-prefix-arg (not default)) + (magit-completing-read "Unstage file" choices + nil t nil nil default) + default)))) + (magit-with-toplevel + (magit-unstage-1 (list file)))) + +(defun magit-unstage-1 (files) + (magit-wip-commit-before-change files " before unstage") + (if (magit-no-commit-p) + (magit-run-git "rm" "--cached" "--" files) + (magit-run-git "reset" "HEAD" "--" files)) + (magit-wip-commit-after-apply files " after unstage")) + +(defun magit-unstage-intent (files) + (if-let ((staged (magit-staged-files)) + (intent (--filter (member it staged) files))) + (magit-unstage-1 intent) + (user-error "Already unstaged"))) + +;;;###autoload +(defun magit-unstage-all () + "Remove all changes from the staging area." + (interactive) + (when (or (magit-anything-unstaged-p) + (magit-untracked-files)) + (magit-confirm 'unstage-all-changes)) + (magit-wip-commit-before-change nil " before unstage") + (magit-run-git "reset" "HEAD" "--" magit-buffer-diff-files) + (magit-wip-commit-after-apply nil " after unstage")) + +;;;; Discard + +(defun magit-discard () + "Remove the change at point." + (interactive) + (--when-let (magit-apply--get-selection) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(committed ,_) (user-error "Cannot discard committed changes")) + (`(undefined ,_) (user-error "Cannot discard this change")) + (`(,_ region) (magit-discard-region it)) + (`(,_ hunk) (magit-discard-hunk it)) + (`(,_ hunks) (magit-discard-hunks it)) + (`(,_ file) (magit-discard-file it)) + (`(,_ files) (magit-discard-files it)) + (`(,_ list) (magit-discard-files it))))) + +(defun magit-discard-region (section) + (magit-confirm 'discard "Discard region") + (magit-discard-apply section 'magit-apply-region)) + +(defun magit-discard-hunk (section) + (magit-confirm 'discard "Discard hunk") + (magit-discard-apply section 'magit-apply-hunk)) + +(defun magit-discard-apply (section apply) + (if (eq (magit-diff-type section) 'unstaged) + (funcall apply section "--reverse") + (if (magit-anything-unstaged-p + nil (if (magit-file-section-p section) + (oref section value) + (magit-section-parent-value section))) + (progn (let ((inhibit-magit-refresh t)) + (funcall apply section "--reverse" "--cached") + (funcall apply section "--reverse" "--reject")) + (magit-refresh)) + (funcall apply section "--reverse" "--index")))) + +(defun magit-discard-hunks (sections) + (magit-confirm 'discard (format "Discard %s hunks from %s" + (length sections) + (magit-section-parent-value (car sections)))) + (magit-discard-apply-n sections 'magit-apply-hunks)) + +(defun magit-discard-apply-n (sections apply) + (let ((section (car sections))) + (if (eq (magit-diff-type section) 'unstaged) + (funcall apply sections "--reverse") + (if (magit-anything-unstaged-p + nil (if (magit-file-section-p section) + (oref section value) + (magit-section-parent-value section))) + (progn (let ((inhibit-magit-refresh t)) + (funcall apply sections "--reverse" "--cached") + (funcall apply sections "--reverse" "--reject")) + (magit-refresh)) + (funcall apply sections "--reverse" "--index"))))) + +(defun magit-discard-file (section) + (magit-discard-files (list section))) + +(defun magit-discard-files (sections) + (let ((auto-revert-verbose nil) + (type (magit-diff-type (car sections))) + (status (magit-file-status)) + files delete resurrect rename discard discard-new resolve) + (dolist (section sections) + (let ((file (oref section value))) + (push file files) + (pcase (cons (pcase type + (`staged ?X) + (`unstaged ?Y) + (`untracked ?Z)) + (cddr (assoc file status))) + (`(?Z) (dolist (f (magit-untracked-files nil file)) + (push f delete))) + ((or `(?Z ?? ??) `(?Z ?! ?!)) (push file delete)) + ((or `(?Z ?D ? ) `(,_ ?D ?D)) (push file delete)) + ((or `(,_ ?U ,_) `(,_ ,_ ?U)) (push file resolve)) + (`(,_ ?A ?A) (push file resolve)) + (`(?X ?M ,(or ? ?M ?D)) (push section discard)) + (`(?Y ,_ ?M ) (push section discard)) + (`(?X ?A ?M ) (push file discard-new)) + (`(?X ?C ?M ) (push file discard-new)) + (`(?X ?A ,(or ? ?D)) (push file delete)) + (`(?X ?C ,(or ? ?D)) (push file delete)) + (`(?X ?D ,(or ? ?M )) (push file resurrect)) + (`(?Y ,_ ?D ) (push file resurrect)) + (`(?X ?R ,(or ? ?M ?D)) (push file rename))))) + (unwind-protect + (let ((inhibit-magit-refresh t)) + (magit-wip-commit-before-change files " before discard") + (when resolve + (magit-discard-files--resolve (nreverse resolve))) + (when resurrect + (magit-discard-files--resurrect (nreverse resurrect))) + (when delete + (magit-discard-files--delete (nreverse delete) status)) + (when rename + (magit-discard-files--rename (nreverse rename) status)) + (when (or discard discard-new) + (magit-discard-files--discard (nreverse discard) + (nreverse discard-new))) + (magit-wip-commit-after-apply files " after discard")) + (magit-refresh)))) + +(defun magit-discard-files--resolve (files) + (if-let ((arg (and (cdr files) + (magit-read-char-case + (format "For these %i files\n%s\ncheckout:\n" + (length files) + (mapconcat (lambda (file) + (concat " " file)) + files "\n")) + t + (?o "[o]ur stage" "--ours") + (?t "[t]heir stage" "--theirs") + (?c "[c]onflict" "--merge") + (?i "decide [i]ndividually" nil))))) + (dolist (file files) + (magit-checkout-stage file arg)) + (dolist (file files) + (magit-checkout-stage file (magit-checkout-read-stage file))))) + +(defun magit-discard-files--resurrect (files) + (magit-confirm-files 'resurrect files) + (if (eq (magit-diff-type) 'staged) + (magit-call-git "reset" "--" files) + (magit-call-git "checkout" "--" files))) + +(defun magit-discard-files--delete (files status) + (magit-confirm-files (if magit-delete-by-moving-to-trash 'trash 'delete) + files) + (let ((delete-by-moving-to-trash magit-delete-by-moving-to-trash)) + (dolist (file files) + (when (string-match-p "\\`\\\\?~" file) + (error "Refusing to delete %S, too dangerous" file)) + (pcase (nth 3 (assoc file status)) + ((guard (memq (magit-diff-type) '(unstaged untracked))) + (dired-delete-file file dired-recursive-deletes + magit-delete-by-moving-to-trash) + (dired-clean-up-after-deletion file)) + (?\s (delete-file file t) + (magit-call-git "rm" "--cached" "--" file)) + (?M (let ((temp (magit-git-string "checkout-index" "--temp" file))) + (string-match + (format "\\(.+?\\)\t%s" (regexp-quote file)) temp) + (rename-file (match-string 1 temp) + (setq temp (concat file ".~{index}~"))) + (delete-file temp t)) + (magit-call-git "rm" "--cached" "--force" "--" file)) + (?D (magit-call-git "checkout" "--" file) + (delete-file file t) + (magit-call-git "rm" "--cached" "--force" "--" file)))))) + +(defun magit-discard-files--rename (files status) + (magit-confirm 'rename "Undo rename %s" "Undo %i renames" nil + (mapcar (lambda (file) + (setq file (assoc file status)) + (format "%s -> %s" (cadr file) (car file))) + files)) + (dolist (file files) + (let ((orig (cadr (assoc file status)))) + (if (file-exists-p file) + (progn + (--when-let (file-name-directory orig) + (make-directory it t)) + (magit-call-git "mv" file orig)) + (magit-call-git "rm" "--cached" "--" file) + (magit-call-git "reset" "--" orig))))) + +(defun magit-discard-files--discard (sections new-files) + (let ((files (--map (oref it value) sections))) + (magit-confirm-files 'discard (append files new-files) + (format "Discard %s changes in" (magit-diff-type))) + (if (eq (magit-diff-type (car sections)) 'unstaged) + (magit-call-git "checkout" "--" files) + (when new-files + (magit-call-git "add" "--" new-files) + (magit-call-git "reset" "--" new-files)) + (let ((binaries (magit-binary-files "--cached"))) + (when binaries + (setq sections + (--remove (member (oref it value) binaries) + sections))) + (cond ((= (length sections) 1) + (magit-discard-apply (car sections) 'magit-apply-diff)) + (sections + (magit-discard-apply-n sections 'magit-apply-diffs))) + (when binaries + (let ((modified (magit-unstaged-files t))) + (setq binaries (--separate (member it modified) binaries))) + (when (cadr binaries) + (magit-call-git "reset" "--" (cadr binaries))) + (when (car binaries) + (user-error + (concat + "Cannot discard staged changes to binary files, " + "which also have unstaged changes. Unstage instead.")))))))) + +;;;; Reverse + +(defun magit-reverse (&rest args) + "Reverse the change at point in the working tree. +With a prefix argument fallback to a 3-way merge. Doing +so causes the change to be applied to the index as well." + (interactive (and current-prefix-arg (list "--3way"))) + (--when-let (magit-apply--get-selection) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(untracked ,_) (user-error "Cannot reverse untracked changes")) + (`(unstaged ,_) (user-error "Cannot reverse unstaged changes")) + (`(,_ region) (magit-reverse-region it args)) + (`(,_ hunk) (magit-reverse-hunk it args)) + (`(,_ hunks) (magit-reverse-hunks it args)) + (`(,_ file) (magit-reverse-file it args)) + (`(,_ files) (magit-reverse-files it args)) + (`(,_ list) (magit-reverse-files it args))))) + +(defun magit-reverse-region (section args) + (magit-confirm 'reverse "Reverse region") + (magit-reverse-apply section 'magit-apply-region args)) + +(defun magit-reverse-hunk (section args) + (magit-confirm 'reverse "Reverse hunk") + (magit-reverse-apply section 'magit-apply-hunk args)) + +(defun magit-reverse-hunks (sections args) + (magit-confirm 'reverse + (format "Reverse %s hunks from %s" + (length sections) + (magit-section-parent-value (car sections)))) + (magit-reverse-apply sections 'magit-apply-hunks args)) + +(defun magit-reverse-file (section args) + (magit-reverse-files (list section) args)) + +(defun magit-reverse-files (sections args) + (pcase-let ((`(,binaries ,sections) + (let ((bs (magit-binary-files + (cond ((derived-mode-p 'magit-revision-mode) + magit-buffer-range) + ((derived-mode-p 'magit-diff-mode) + magit-buffer-range) + (t + "--cached"))))) + (--separate (member (oref it value) bs) + sections)))) + (magit-confirm-files 'reverse (--map (oref it value) sections)) + (cond ((= (length sections) 1) + (magit-reverse-apply (car sections) 'magit-apply-diff args)) + (sections + (magit-reverse-apply sections 'magit-apply-diffs args))) + (when binaries + (user-error "Cannot reverse binary files")))) + +(defun magit-reverse-apply (section:s apply args) + (funcall apply section:s "--reverse" args + (and (not magit-reverse-atomically) + (not (member "--3way" args)) + "--reject"))) + +(defun magit-reverse-in-index (&rest args) + "Reverse the change at point in the index but not the working tree. + +Use this command to extract a change from `HEAD', while leaving +it in the working tree, so that it can later be committed using +a separate commit. A typical workflow would be: + +0. Optionally make sure that there are no uncommitted changes. +1. Visit the `HEAD' commit and navigate to the change that should + not have been included in that commit. +2. Type \"u\" (`magit-unstage') to reverse it in the index. + This assumes that `magit-unstage-committed-changes' is non-nil. +3. Type \"c e\" to extend `HEAD' with the staged changes, + including those that were already staged before. +4. Optionally stage the remaining changes using \"s\" or \"S\" + and then type \"c c\" to create a new commit." + (interactive) + (magit-reverse (cons "--cached" args))) + +;;; _ +(provide 'magit-apply) +;;; magit-apply.el ends here diff --git a/elpa/magit-20200318.1224/magit-apply.elc b/elpa/magit-20200318.1224/magit-apply.elc new file mode 100644 index 00000000..8b68625c Binary files /dev/null and b/elpa/magit-20200318.1224/magit-apply.elc differ diff --git a/elpa/magit-20200318.1224/magit-autoloads.el b/elpa/magit-20200318.1224/magit-autoloads.el new file mode 100644 index 00000000..4689dfa2 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-autoloads.el @@ -0,0 +1,2523 @@ +;;; magit-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "git-rebase" "git-rebase.el" (0 0 0 0)) +;;; Generated autoloads from git-rebase.el + +(autoload 'git-rebase-current-line "git-rebase" "\ +Parse current line into a `git-rebase-action' instance. +If the current line isn't recognized as a rebase line, an +instance with all nil values is returned. + +\(fn)" nil nil) + +(autoload 'git-rebase-mode "git-rebase" "\ +Major mode for editing of a Git rebase file. + +Rebase files are generated when you run 'git rebase -i' or run +`magit-interactive-rebase'. They describe how Git should perform +the rebase. See the documentation for git-rebase (e.g., by +running 'man git-rebase' at the command line) for details. + +\(fn)" t nil) + +(defconst git-rebase-filename-regexp "/git-rebase-todo\\'") + +(add-to-list 'auto-mode-alist (cons git-rebase-filename-regexp 'git-rebase-mode)) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "git-rebase" '("git-rebase-"))) + +;;;*** + +;;;### (autoloads nil "magit" "magit.el" (0 0 0 0)) +;;; Generated autoloads from magit.el + (autoload 'magit-dispatch "magit" nil t) + (autoload 'magit-run "magit" nil t) + +(autoload 'magit-git-command "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +With a prefix argument COMMAND is run in the top-level directory +of the current working tree, otherwise in `default-directory'. + +\(fn COMMAND)" t nil) + +(autoload 'magit-git-command-topdir "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +COMMAND is run in the top-level directory of the current +working tree. + +\(fn COMMAND)" t nil) + +(autoload 'magit-shell-command "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. With a +prefix argument COMMAND is run in the top-level directory of +the current working tree, otherwise in `default-directory'. + +\(fn COMMAND)" t nil) + +(autoload 'magit-shell-command-topdir "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. COMMAND +is run in the top-level directory of the current working tree. + +\(fn COMMAND)" t nil) + +(autoload 'magit-version "magit" "\ +Return the version of Magit currently in use. +If optional argument PRINT-DEST is non-nil, output +stream (interactively, the echo area, or the current buffer with +a prefix argument), also print the used versions of Magit, Git, +and Emacs to it. + +\(fn &optional PRINT-DEST)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-apply" "magit-apply.el" (0 0 0 0)) +;;; Generated autoloads from magit-apply.el + +(autoload 'magit-stage-file "magit-apply" "\ +Stage all changes to FILE. +With a prefix argument or when there is no file at point ask for +the file to be staged. Otherwise stage the file at point without +requiring confirmation. + +\(fn FILE)" t nil) + +(autoload 'magit-stage-modified "magit-apply" "\ +Stage all changes to files modified in the worktree. +Stage all new content of tracked files and remove tracked files +that no longer exist in the working tree from the index also. +With a prefix argument also stage previously untracked (but not +ignored) files. + +\(fn &optional ALL)" t nil) + +(autoload 'magit-unstage-file "magit-apply" "\ +Unstage all changes to FILE. +With a prefix argument or when there is no file at point ask for +the file to be unstaged. Otherwise unstage the file at point +without requiring confirmation. + +\(fn FILE)" t nil) + +(autoload 'magit-unstage-all "magit-apply" "\ +Remove all changes from the staging area. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-apply" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-autorevert" "magit-autorevert.el" (0 +;;;;;; 0 0 0)) +;;; Generated autoloads from magit-autorevert.el + +(defvar magit-auto-revert-mode (not (or global-auto-revert-mode noninteractive)) "\ +Non-nil if Magit-Auto-Revert mode is enabled. +See the `magit-auto-revert-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-auto-revert-mode'.") + +(custom-autoload 'magit-auto-revert-mode "magit-autorevert" nil) + +(autoload 'magit-auto-revert-mode "magit-autorevert" "\ +Toggle Auto-Revert mode in all buffers. +With prefix ARG, enable Magit-Auto-Revert mode if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Auto-Revert mode is enabled in all buffers where +`magit-turn-on-auto-revert-mode-if-desired' would do it. +See `auto-revert-mode' for more information on Auto-Revert mode. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-autorevert" '("auto-revert-buffer" "magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-bisect" "magit-bisect.el" (0 0 0 0)) +;;; Generated autoloads from magit-bisect.el + (autoload 'magit-bisect "magit-bisect" nil t) + +(autoload 'magit-bisect-start "magit-bisect" "\ +Start a bisect session. + +Bisecting a bug means to find the commit that introduced it. +This command starts such a bisect session by asking for a know +good and a bad commit. To move the session forward use the +other actions from the bisect transient command (\\\\[magit-bisect]). + +\(fn BAD GOOD)" t nil) + +(autoload 'magit-bisect-reset "magit-bisect" "\ +After bisecting, cleanup bisection state and return to original `HEAD'. + +\(fn)" t nil) + +(autoload 'magit-bisect-good "magit-bisect" "\ +While bisecting, mark the current commit as good. +Use this after you have asserted that the commit does not contain +the bug in question. + +\(fn)" t nil) + +(autoload 'magit-bisect-bad "magit-bisect" "\ +While bisecting, mark the current commit as bad. +Use this after you have asserted that the commit does contain the +bug in question. + +\(fn)" t nil) + +(autoload 'magit-bisect-skip "magit-bisect" "\ +While bisecting, skip the current commit. +Use this if for some reason the current commit is not a good one +to test. This command lets Git choose a different one. + +\(fn)" t nil) + +(autoload 'magit-bisect-run "magit-bisect" "\ +Bisect automatically by running commands after each step. + +Unlike `git bisect run' this can be used before bisecting has +begun. In that case it behaves like `git bisect start; git +bisect run'. + +\(fn CMDLINE &optional BAD GOOD)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-bisect" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-blame" "magit-blame.el" (0 0 0 0)) +;;; Generated autoloads from magit-blame.el + (autoload 'magit-blame-echo "magit-blame" nil t) + (autoload 'magit-blame-addition "magit-blame" nil t) + (autoload 'magit-blame-removal "magit-blame" nil t) + (autoload 'magit-blame-reverse "magit-blame" nil t) + (autoload 'magit-blame "magit-blame" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-blame" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-bookmark" "magit-bookmark.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from magit-bookmark.el + +(autoload 'magit--handle-bookmark "magit-bookmark" "\ +Open a bookmark created by `magit--make-bookmark'. +Call the `magit-*-setup-buffer' function of the the major-mode +with the variables' values as arguments, which were recorded by +`magit--make-bookmark'. Ignore `magit-display-buffer-function'. + +\(fn BOOKMARK)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-bookmark" '("magit--make-bookmark"))) + +;;;*** + +;;;### (autoloads nil "magit-branch" "magit-branch.el" (0 0 0 0)) +;;; Generated autoloads from magit-branch.el + (autoload 'magit-branch "magit" nil t) + +(autoload 'magit-checkout "magit-branch" "\ +Checkout REVISION, updating the index and the working tree. +If REVISION is a local branch, then that becomes the current +branch. If it is something else, then `HEAD' becomes detached. +Checkout fails if the working tree or the staging area contain +changes. + +\(git checkout REVISION). + +\(fn REVISION)" t nil) + +(autoload 'magit-branch-create "magit-branch" "\ +Create BRANCH at branch or revision START-POINT. + +\(fn BRANCH START-POINT)" t nil) + +(autoload 'magit-branch-and-checkout "magit-branch" "\ +Create and checkout BRANCH at branch or revision START-POINT. + +\(fn BRANCH START-POINT)" t nil) + +(autoload 'magit-branch-or-checkout "magit-branch" "\ +Hybrid between `magit-checkout' and `magit-branch-and-checkout'. + +Ask the user for an existing branch or revision. If the user +input actually can be resolved as a branch or revision, then +check that out, just like `magit-checkout' would. + +Otherwise create and checkout a new branch using the input as +its name. Before doing so read the starting-point for the new +branch. This is similar to what `magit-branch-and-checkout' +does. + +\(fn ARG &optional START-POINT)" t nil) + +(autoload 'magit-branch-checkout "magit-branch" "\ +Checkout an existing or new local branch. + +Read a branch name from the user offering all local branches and +a subset of remote branches as candidates. Omit remote branches +for which a local branch by the same name exists from the list +of candidates. The user can also enter a completely new branch +name. + +- If the user selects an existing local branch, then check that + out. + +- If the user selects a remote branch, then create and checkout + a new local branch with the same name. Configure the selected + remote branch as push target. + +- If the user enters a new branch name, then create and check + that out, after also reading the starting-point from the user. + +In the latter two cases the upstream is also set. Whether it is +set to the chosen START-POINT or something else depends on the +value of `magit-branch-adjust-remote-upstream-alist', just like +when using `magit-branch-and-checkout'. + +\(fn BRANCH &optional START-POINT)" t nil) + +(autoload 'magit-branch-orphan "magit-branch" "\ +Create and checkout an orphan BRANCH with contents from revision START-POINT. + +\(fn BRANCH START-POINT)" t nil) + +(autoload 'magit-branch-spinout "magit-branch" "\ +Create new branch from the unpushed commits. +Like `magit-branch-spinoff' but remain on the current branch. +If there are any uncommitted changes, then behave exactly like +`magit-branch-spinoff'. + +\(fn BRANCH &optional FROM)" t nil) + +(autoload 'magit-branch-spinoff "magit-branch" "\ +Create new branch from the unpushed commits. + +Create and checkout a new branch starting at and tracking the +current branch. That branch in turn is reset to the last commit +it shares with its upstream. If the current branch has no +upstream or no unpushed commits, then the new branch is created +anyway and the previously current branch is not touched. + +This is useful to create a feature branch after work has already +began on the old branch (likely but not necessarily \"master\"). + +If the current branch is a member of the value of option +`magit-branch-prefer-remote-upstream' (which see), then the +current branch will be used as the starting point as usual, but +the upstream of the starting-point may be used as the upstream +of the new branch, instead of the starting-point itself. + +If optional FROM is non-nil, then the source branch is reset +to `FROM~', instead of to the last commit it shares with its +upstream. Interactively, FROM is only ever non-nil, if the +region selects some commits, and among those commits, FROM is +the commit that is the fewest commits ahead of the source +branch. + +The commit at the other end of the selection actually does not +matter, all commits between FROM and `HEAD' are moved to the new +branch. If FROM is not reachable from `HEAD' or is reachable +from the source branch's upstream, then an error is raised. + +\(fn BRANCH &optional FROM)" t nil) + +(autoload 'magit-branch-reset "magit-branch" "\ +Reset a branch to the tip of another branch or any other commit. + +When the branch being reset is the current branch, then do a +hard reset. If there are any uncommitted changes, then the user +has to confirm the reset because those changes would be lost. + +This is useful when you have started work on a feature branch but +realize it's all crap and want to start over. + +When resetting to another branch and a prefix argument is used, +then also set the target branch as the upstream of the branch +that is being reset. + +\(fn BRANCH TO &optional SET-UPSTREAM)" t nil) + +(autoload 'magit-branch-delete "magit-branch" "\ +Delete one or multiple branches. +If the region marks multiple branches, then offer to delete +those, otherwise prompt for a single branch to be deleted, +defaulting to the branch at point. + +\(fn BRANCHES &optional FORCE)" t nil) + +(autoload 'magit-branch-rename "magit-branch" "\ +Rename the branch named OLD to NEW. + +With a prefix argument FORCE, rename even if a branch named NEW +already exists. + +If `branch.OLD.pushRemote' is set, then unset it. Depending on +the value of `magit-branch-rename-push-target' (which see) maybe +set `branch.NEW.pushRemote' and maybe rename the push-target on +the remote. + +\(fn OLD NEW &optional FORCE)" t nil) + +(autoload 'magit-branch-shelve "magit-branch" "\ +Shelve a BRANCH. +Rename \"refs/heads/BRANCH\" to \"refs/shelved/BRANCH\", +and also rename the respective reflog file. + +\(fn BRANCH)" t nil) + +(autoload 'magit-branch-unshelve "magit-branch" "\ +Unshelve a BRANCH +Rename \"refs/shelved/BRANCH\" to \"refs/heads/BRANCH\", +and also rename the respective reflog file. + +\(fn BRANCH)" t nil) + (autoload 'magit-branch-configure "magit-branch" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-branch" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-clone" "magit-clone.el" (0 0 0 0)) +;;; Generated autoloads from magit-clone.el + (autoload 'magit-clone "magit-clone" nil t) + +(autoload 'magit-clone-regular "magit-clone" "\ +Create a clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +\(fn REPOSITORY DIRECTORY ARGS)" t nil) + +(autoload 'magit-clone-shallow "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +With a prefix argument read the DEPTH of the clone; +otherwise use 1. + +\(fn REPOSITORY DIRECTORY ARGS DEPTH)" t nil) + +(autoload 'magit-clone-shallow-since "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits before DATE, which is read from the +user. + +\(fn REPOSITORY DIRECTORY ARGS DATE)" t nil) + +(autoload 'magit-clone-shallow-exclude "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits reachable from EXCLUDE, which is a +branch or tag read from the user. + +\(fn REPOSITORY DIRECTORY ARGS EXCLUDE)" t nil) + +(autoload 'magit-clone-bare "magit-clone" "\ +Create a bare clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +\(fn REPOSITORY DIRECTORY ARGS)" t nil) + +(autoload 'magit-clone-mirror "magit-clone" "\ +Create a mirror of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +\(fn REPOSITORY DIRECTORY ARGS)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-clone" '("magit-clone"))) + +;;;*** + +;;;### (autoloads nil "magit-commit" "magit-commit.el" (0 0 0 0)) +;;; Generated autoloads from magit-commit.el + (autoload 'magit-commit "magit-commit" nil t) + +(autoload 'magit-commit-create "magit-commit" "\ +Create a new commit on `HEAD'. +With a prefix argument, amend to the commit at `HEAD' instead. + +\(git commit [--amend] ARGS) + +\(fn &optional ARGS)" t nil) + +(autoload 'magit-commit-amend "magit-commit" "\ +Amend the last commit. + +\(git commit --amend ARGS) + +\(fn &optional ARGS)" t nil) + +(autoload 'magit-commit-extend "magit-commit" "\ +Amend the last commit, without editing the message. + +With a prefix argument keep the committer date, otherwise change +it. The option `magit-commit-extend-override-date' can be used +to inverse the meaning of the prefix argument. +\(git commit +--amend --no-edit) + +\(fn &optional ARGS OVERRIDE-DATE)" t nil) + +(autoload 'magit-commit-reword "magit-commit" "\ +Reword the last commit, ignoring staged changes. + +With a prefix argument keep the committer date, otherwise change +it. The option `magit-commit-reword-override-date' can be used +to inverse the meaning of the prefix argument. + +Non-interactively respect the optional OVERRIDE-DATE argument +and ignore the option. + +\(git commit --amend --only) + +\(fn &optional ARGS OVERRIDE-DATE)" t nil) + +(autoload 'magit-commit-fixup "magit-commit" "\ +Create a fixup commit. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'. + +\(fn &optional COMMIT ARGS)" t nil) + +(autoload 'magit-commit-squash "magit-commit" "\ +Create a squash commit, without editing the squash message. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'. + +\(fn &optional COMMIT ARGS)" t nil) + +(autoload 'magit-commit-augment "magit-commit" "\ +Create a squash commit, editing the squash message. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'. + +\(fn &optional COMMIT ARGS)" t nil) + +(autoload 'magit-commit-instant-fixup "magit-commit" "\ +Create a fixup commit targeting COMMIT and instantly rebase. + +\(fn &optional COMMIT ARGS)" t nil) + +(autoload 'magit-commit-instant-squash "magit-commit" "\ +Create a squash commit targeting COMMIT and instantly rebase. + +\(fn &optional COMMIT ARGS)" t nil) + +(autoload 'magit-commit-reshelve "magit-commit" "\ +Change the committer date and possibly the author date of `HEAD'. + +If you are the author of `HEAD', then both dates are changed, +otherwise only the committer date. The current time is used +as the initial minibuffer input and the original author (if +that is you) or committer date is available as the previous +history element. + +\(fn DATE)" t nil) + (autoload 'magit-commit-absorb "magit-commit" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-commit" '("magit"))) + +;;;*** + +;;;### (autoloads nil "magit-diff" "magit-diff.el" (0 0 0 0)) +;;; Generated autoloads from magit-diff.el + (autoload 'magit-diff "magit-diff" nil t) + (autoload 'magit-diff-refresh "magit-diff" nil t) + +(autoload 'magit-diff-dwim "magit-diff" "\ +Show changes for the thing at point. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-diff-range "magit-diff" "\ +Show differences between two commits. + +REV-OR-RANGE should be a range or a single revision. If it is a +revision, then show changes in the working tree relative to that +revision. If it is a range, but one side is omitted, then show +changes relative to `HEAD'. + +If the region is active, use the revisions on the first and last +line of the region as the two sides of the range. With a prefix +argument, instead of diffing the revisions, choose a revision to +view changes along, starting at the common ancestor of both +revisions (i.e., use a \"...\" range). + +\(fn REV-OR-RANGE &optional ARGS FILES)" t nil) + +(autoload 'magit-diff-working-tree "magit-diff" "\ +Show changes between the current working tree and the `HEAD' commit. +With a prefix argument show changes between the working tree and +a commit read from the minibuffer. + +\(fn &optional REV ARGS FILES)" t nil) + +(autoload 'magit-diff-staged "magit-diff" "\ +Show changes between the index and the `HEAD' commit. +With a prefix argument show changes between the index and +a commit read from the minibuffer. + +\(fn &optional REV ARGS FILES)" t nil) + +(autoload 'magit-diff-unstaged "magit-diff" "\ +Show changes between the working tree and the index. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-diff-unmerged "magit-diff" "\ +Show changes that are being merged. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-diff-while-committing "magit-diff" "\ +While committing, show the changes that are about to be committed. +While amending, invoking the command again toggles between +showing just the new changes or all the changes that will +be committed. + +\(fn &optional ARGS)" t nil) + +(autoload 'magit-diff-buffer-file "magit-diff" "\ +Show diff for the blob or file visited in the current buffer. + +When the buffer visits a blob, then show the respective commit. +When the buffer visits a file, then show the differenced between +`HEAD' and the working tree. In both cases limit the diff to +the file or blob. + +\(fn)" t nil) + +(autoload 'magit-diff-paths "magit-diff" "\ +Show changes between any two files on disk. + +\(fn A B)" t nil) + +(autoload 'magit-show-commit "magit-diff" "\ +Visit the revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision. + +\(fn REV &optional ARGS FILES MODULE)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-diff" '("magit"))) + +;;;*** + +;;;### (autoloads nil "magit-ediff" "magit-ediff.el" (0 0 0 0)) +;;; Generated autoloads from magit-ediff.el + (autoload 'magit-ediff "magit-ediff" nil) + +(autoload 'magit-ediff-resolve "magit-ediff" "\ +Resolve outstanding conflicts in FILE using Ediff. +FILE has to be relative to the top directory of the repository. + +In the rare event that you want to manually resolve all +conflicts, including those already resolved by Git, use +`ediff-merge-revisions-with-ancestor'. + +\(fn FILE)" t nil) + +(autoload 'magit-ediff-stage "magit-ediff" "\ +Stage and unstage changes to FILE using Ediff. +FILE has to be relative to the top directory of the repository. + +\(fn FILE)" t nil) + +(autoload 'magit-ediff-compare "magit-ediff" "\ +Compare REVA:FILEA with REVB:FILEB using Ediff. + +FILEA and FILEB have to be relative to the top directory of the +repository. If REVA or REVB is nil, then this stands for the +working tree state. + +If the region is active, use the revisions on the first and last +line of the region. With a prefix argument, instead of diffing +the revisions, choose a revision to view changes along, starting +at the common ancestor of both revisions (i.e., use a \"...\" +range). + +\(fn REVA REVB FILEA FILEB)" t nil) + +(autoload 'magit-ediff-dwim "magit-ediff" "\ +Compare, stage, or resolve using Ediff. +This command tries to guess what file, and what commit or range +the user wants to compare, stage, or resolve using Ediff. It +might only be able to guess either the file, or range or commit, +in which case the user is asked about the other. It might not +always guess right, in which case the appropriate `magit-ediff-*' +command has to be used explicitly. If it cannot read the user's +mind at all, then it asks the user for a command to run. + +\(fn)" t nil) + +(autoload 'magit-ediff-show-staged "magit-ediff" "\ +Show staged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository. + +\(fn FILE)" t nil) + +(autoload 'magit-ediff-show-unstaged "magit-ediff" "\ +Show unstaged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository. + +\(fn FILE)" t nil) + +(autoload 'magit-ediff-show-working-tree "magit-ediff" "\ +Show changes between `HEAD' and working tree using Ediff. +FILE must be relative to the top directory of the repository. + +\(fn FILE)" t nil) + +(autoload 'magit-ediff-show-commit "magit-ediff" "\ +Show changes introduced by COMMIT using Ediff. + +\(fn COMMIT)" t nil) + +(autoload 'magit-ediff-show-stash "magit-ediff" "\ +Show changes introduced by STASH using Ediff. +`magit-ediff-show-stash-with-index' controls whether a +three-buffer Ediff is used in order to distinguish changes in the +stash that were staged. + +\(fn STASH)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-ediff" '("magit-ediff"))) + +;;;*** + +;;;### (autoloads nil "magit-extras" "magit-extras.el" (0 0 0 0)) +;;; Generated autoloads from magit-extras.el + +(autoload 'magit-run-git-gui "magit-extras" "\ +Run `git gui' for the current git repository. + +\(fn)" t nil) + +(autoload 'magit-run-git-gui-blame "magit-extras" "\ +Run `git gui blame' on the given FILENAME and COMMIT. +Interactively run it for the current file and the `HEAD', with a +prefix or when the current file cannot be determined let the user +choose. When the current buffer is visiting FILENAME instruct +blame to center around the line point is on. + +\(fn COMMIT FILENAME &optional LINENUM)" t nil) + +(autoload 'magit-run-gitk "magit-extras" "\ +Run `gitk' in the current repository. + +\(fn)" t nil) + +(autoload 'magit-run-gitk-branches "magit-extras" "\ +Run `gitk --branches' in the current repository. + +\(fn)" t nil) + +(autoload 'magit-run-gitk-all "magit-extras" "\ +Run `gitk --all' in the current repository. + +\(fn)" t nil) + +(autoload 'ido-enter-magit-status "magit-extras" "\ +Drop into `magit-status' from file switching. + +This command does not work in Emacs 26.1. +See https://github.com/magit/magit/issues/3634 +and https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31707. + +To make this command available use something like: + + (add-hook \\='ido-setup-hook + (lambda () + (define-key ido-completion-map + (kbd \"C-x g\") \\='ido-enter-magit-status))) + +Starting with Emacs 25.1 the Ido keymaps are defined just once +instead of every time Ido is invoked, so now you can modify it +like pretty much every other keymap: + + (define-key ido-common-completion-map + (kbd \"C-x g\") \\='ido-enter-magit-status) + +\(fn)" t nil) + +(autoload 'magit-dired-jump "magit-extras" "\ +Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'. + +\(fn &optional OTHER-WINDOW)" t nil) + +(autoload 'magit-dired-log "magit-extras" "\ +Show log for all marked files, or the current file. + +\(fn &optional FOLLOW)" t nil) + +(autoload 'magit-do-async-shell-command "magit-extras" "\ +Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point. + +\(fn FILE)" t nil) + +(autoload 'magit-previous-line "magit-extras" "\ +Like `previous-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects an +area that is larger than the region. This causes `previous-line' +when invoked while holding the shift key to move up one line and +thereby select two lines. When invoked inside a hunk body this +command does not move point on the first invocation and thereby +it only selects a single line. Which inconsistency you prefer +is a matter of preference. + +\(fn &optional ARG TRY-VSCROLL)" t nil) + +(function-put 'magit-previous-line 'interactive-only '"use `forward-line' with negative argument instead.") + +(autoload 'magit-next-line "magit-extras" "\ +Like `next-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects +an area that is larger than the region. This causes `next-line' +when invoked while holding the shift key to move down one line +and thereby select two lines. When invoked inside a hunk body +this command does not move point on the first invocation and +thereby it only selects a single line. Which inconsistency you +prefer is a matter of preference. + +\(fn &optional ARG TRY-VSCROLL)" t nil) + +(function-put 'magit-next-line 'interactive-only 'forward-line) + +(autoload 'magit-clean "magit-extras" "\ +Remove untracked files from the working tree. +With a prefix argument also remove ignored files, +with two prefix arguments remove ignored files only. + +\(git clean -f -d [-x|-X]) + +\(fn &optional ARG)" t nil) + +(autoload 'magit-add-change-log-entry "magit-extras" "\ +Find change log file and add date entry and item for current change. +This differs from `add-change-log-entry' (which see) in that +it acts on the current hunk in a Magit buffer instead of on +a position in a file-visiting buffer. + +\(fn &optional WHOAMI FILE-NAME OTHER-WINDOW)" t nil) + +(autoload 'magit-add-change-log-entry-other-window "magit-extras" "\ +Find change log file in other window and add entry and item. +This differs from `add-change-log-entry-other-window' (which see) +in that it acts on the current hunk in a Magit buffer instead of +on a position in a file-visiting buffer. + +\(fn &optional WHOAMI FILE-NAME)" t nil) + +(autoload 'magit-edit-line-commit "magit-extras" "\ +Edit the commit that added the current line. + +With a prefix argument edit the commit that removes the line, +if any. The commit is determined using `git blame' and made +editable using `git rebase --interactive' if it is reachable +from `HEAD', or by checking out the commit (or a branch that +points at it) otherwise. + +\(fn &optional TYPE)" t nil) + +(autoload 'magit-diff-edit-hunk-commit "magit-extras" "\ +From a hunk, edit the respective commit and visit the file. + +First visit the file being modified by the hunk at the correct +location using `magit-diff-visit-file'. This actually visits a +blob. When point is on a diff header, not within an individual +hunk, then this visits the blob the first hunk is about. + +Then invoke `magit-edit-line-commit', which uses an interactive +rebase to make the commit editable, or if that is not possible +because the commit is not reachable from `HEAD' by checking out +that commit directly. This also causes the actual worktree file +to be visited. + +Neither the blob nor the file buffer are killed when finishing +the rebase. If that is undesirable, then it might be better to +use `magit-rebase-edit-command' instead of this command. + +\(fn FILE)" t nil) + +(autoload 'magit-reshelve-since "magit-extras" "\ +Change the author and committer dates of the commits since REV. + +Ask the user for the first reachable commit whose dates should +be changed. Then read the new date for that commit. The initial +minibuffer input and the previous history element offer good +values. The next commit will be created one minute later and so +on. + +This command is only intended for interactive use and should only +be used on highly rearranged and unpublished history. + +\(fn REV)" t nil) + +(autoload 'magit-pop-revision-stack "magit-extras" "\ +Insert a representation of a revision into the current buffer. + +Pop a revision from the `magit-revision-stack' and insert it into +the current buffer according to `magit-pop-revision-stack-format'. +Revisions can be put on the stack using `magit-copy-section-value' +and `magit-copy-buffer-revision'. + +If the stack is empty or with a prefix argument, instead read a +revision in the minibuffer. By using the minibuffer history this +allows selecting an item which was popped earlier or to insert an +arbitrary reference or revision without first pushing it onto the +stack. + +When reading the revision from the minibuffer, then it might not +be possible to guess the correct repository. When this command +is called inside a repository (e.g. while composing a commit +message), then that repository is used. Otherwise (e.g. while +composing an email) then the repository recorded for the top +element of the stack is used (even though we insert another +revision). If not called inside a repository and with an empty +stack, or with two prefix arguments, then read the repository in +the minibuffer too. + +\(fn REV TOPLEVEL)" t nil) + +(autoload 'magit-copy-section-value "magit-extras" "\ +Save the value of the current section for later use. + +Save the section value to the `kill-ring', and, provided that +the current section is a commit, branch, or tag section, push +the (referenced) revision to the `magit-revision-stack' for use +with `magit-pop-revision-stack'. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'. + +When the current section is a branch or a tag, and a prefix +argument is used, then save the revision at its tip to the +`kill-ring' instead of the reference name. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. If a prefix argument is used and the region is within a +hunk, strip the outer diff marker column. + +\(fn)" t nil) + +(autoload 'magit-copy-buffer-revision "magit-extras" "\ +Save the revision of the current buffer for later use. + +Save the revision shown in the current buffer to the `kill-ring' +and push it to the `magit-revision-stack'. + +This command is mainly intended for use in `magit-revision-mode' +buffers, the only buffers where it is always unambiguous exactly +which revision should be saved. + +Most other Magit buffers usually show more than one revision, in +some way or another, so this command has to select one of them, +and that choice might not always be the one you think would have +been the best pick. + +In such buffers it is often more useful to save the value of +the current section instead, using `magit-copy-section-value'. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'. + +\(fn)" t nil) + +(autoload 'magit-abort-dwim "magit-extras" "\ +Abort current operation. +Depending on the context, this will abort a merge, a rebase, a +patch application, a cherry-pick, a revert, or a bisect. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-extras" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-fetch" "magit-fetch.el" (0 0 0 0)) +;;; Generated autoloads from magit-fetch.el + (autoload 'magit-fetch "magit-fetch" nil t) + (autoload 'magit-fetch-from-pushremote "magit-fetch" nil t) + (autoload 'magit-fetch-from-upstream "magit-fetch" nil t) + +(autoload 'magit-fetch-other "magit-fetch" "\ +Fetch from another repository. + +\(fn REMOTE ARGS)" t nil) + +(autoload 'magit-fetch-branch "magit-fetch" "\ +Fetch a BRANCH from a REMOTE. + +\(fn REMOTE BRANCH ARGS)" t nil) + +(autoload 'magit-fetch-refspec "magit-fetch" "\ +Fetch a REFSPEC from a REMOTE. + +\(fn REMOTE REFSPEC ARGS)" t nil) + +(autoload 'magit-fetch-all "magit-fetch" "\ +Fetch from all remotes. + +\(fn ARGS)" t nil) + +(autoload 'magit-fetch-all-prune "magit-fetch" "\ +Fetch from all remotes, and prune. +Prune remote tracking branches for branches that have been +removed on the respective remote. + +\(fn)" t nil) + +(autoload 'magit-fetch-all-no-prune "magit-fetch" "\ +Fetch from all remotes. + +\(fn)" t nil) + +(autoload 'magit-fetch-modules "magit-fetch" "\ +Fetch all submodules. + +Option `magit-fetch-modules-jobs' controls how many submodules +are being fetched in parallel. Also fetch the super-repository, +because `git-fetch' does not support not doing that. With a +prefix argument fetch all remotes. + +\(fn &optional ALL)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-fetch" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-files" "magit-files.el" (0 0 0 0)) +;;; Generated autoloads from magit-files.el + +(autoload 'magit-find-file "magit-files" "\ +View FILE from REV. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go +to the line and column corresponding to that location. + +\(fn REV FILE)" t nil) + +(autoload 'magit-find-file-other-window "magit-files" "\ +View FILE from REV, in another window. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location. + +\(fn REV FILE)" t nil) + +(autoload 'magit-find-file-other-frame "magit-files" "\ +View FILE from REV, in another frame. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location. + +\(fn REV FILE)" t nil) + (autoload 'magit-file-dispatch "magit" nil t) + +(defvar global-magit-file-mode t "\ +Non-nil if Global Magit-File mode is enabled. +See the `global-magit-file-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `global-magit-file-mode'.") + +(custom-autoload 'global-magit-file-mode "magit-files" nil) + +(autoload 'global-magit-file-mode "magit-files" "\ +Toggle Magit-File mode in all buffers. +With prefix ARG, enable Global Magit-File mode if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Magit-File mode is enabled in all buffers where +`magit-file-mode-turn-on' would do it. +See `magit-file-mode' for more information on Magit-File mode. + +\(fn &optional ARG)" t nil) + +(autoload 'magit-blob-visit-file "magit-files" "\ +View the file from the worktree corresponding to the current blob. +When visiting a blob or the version from the index, then go to +the same location in the respective file in the working tree. + +\(fn)" t nil) + +(autoload 'magit-file-checkout "magit-files" "\ +Checkout FILE from REV. + +\(fn REV FILE)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-files" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-git" "magit-git.el" (0 0 0 0)) +;;; Generated autoloads from magit-git.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-git" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-gitignore" "magit-gitignore.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from magit-gitignore.el + (autoload 'magit-gitignore "magit-gitignore" nil t) + +(autoload 'magit-gitignore-in-topdir "magit-gitignore" "\ +Add the Git ignore RULE to the top-level \".gitignore\" file. +Since this file is tracked, it is shared with other clones of the +repository. Also stage the file. + +\(fn RULE)" t nil) + +(autoload 'magit-gitignore-in-subdir "magit-gitignore" "\ +Add the Git ignore RULE to a \".gitignore\" file. +Prompted the user for a directory and add the rule to the +\".gitignore\" file in that directory. Since such files are +tracked, they are shared with other clones of the repository. +Also stage the file. + +\(fn RULE DIRECTORY)" t nil) + +(autoload 'magit-gitignore-in-gitdir "magit-gitignore" "\ +Add the Git ignore RULE to \"$GIT_DIR/info/exclude\". +Rules in that file only affects this clone of the repository. + +\(fn RULE)" t nil) + +(autoload 'magit-gitignore-on-system "magit-gitignore" "\ +Add the Git ignore RULE to the file specified by `core.excludesFile'. +Rules that are defined in that file affect all local repositories. + +\(fn RULE)" t nil) + +(autoload 'magit-skip-worktree "magit-gitignore" "\ +Call \"git update-index --skip-worktree -- FILE\". + +\(fn FILE)" t nil) + +(autoload 'magit-no-skip-worktree "magit-gitignore" "\ +Call \"git update-index --no-skip-worktree -- FILE\". + +\(fn FILE)" t nil) + +(autoload 'magit-assume-unchanged "magit-gitignore" "\ +Call \"git update-index --assume-unchanged -- FILE\". + +\(fn FILE)" t nil) + +(autoload 'magit-no-assume-unchanged "magit-gitignore" "\ +Call \"git update-index --no-assume-unchanged -- FILE\". + +\(fn FILE)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-gitignore" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-imenu" "magit-imenu.el" (0 0 0 0)) +;;; Generated autoloads from magit-imenu.el + +(autoload 'magit-imenu--log-prev-index-position-function "magit-imenu" "\ +Move point to previous line in current buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--log-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(autoload 'magit-imenu--diff-prev-index-position-function "magit-imenu" "\ +Move point to previous file line in current buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--diff-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(autoload 'magit-imenu--status-create-index-function "magit-imenu" "\ +Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--refs-create-index-function "magit-imenu" "\ +Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--cherry-create-index-function "magit-imenu" "\ +Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--submodule-prev-index-position-function "magit-imenu" "\ +Move point to previous line in magit-submodule-list buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--submodule-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(autoload 'magit-imenu--repolist-prev-index-position-function "magit-imenu" "\ +Move point to previous line in magit-repolist buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--repolist-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(autoload 'magit-imenu--process-prev-index-position-function "magit-imenu" "\ +Move point to previous process in magit-process buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--process-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(autoload 'magit-imenu--rebase-prev-index-position-function "magit-imenu" "\ +Move point to previous commit in git-rebase buffer. +This function is used as a value for +`imenu-prev-index-position-function'. + +\(fn)" nil nil) + +(autoload 'magit-imenu--rebase-extract-index-name-function "magit-imenu" "\ +Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line. + +\(fn)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-imenu" '("magit-imenu--index-function"))) + +;;;*** + +;;;### (autoloads nil "magit-log" "magit-log.el" (0 0 0 0)) +;;; Generated autoloads from magit-log.el + (autoload 'magit-log "magit-log" nil t) + (autoload 'magit-log-refresh "magit-log" nil t) + +(autoload 'magit-log-current "magit-log" "\ +Show log for the current branch. +When `HEAD' is detached or with a prefix argument show log for +one or more revs read from the minibuffer. + +\(fn REVS &optional ARGS FILES)" t nil) + +(autoload 'magit-log-other "magit-log" "\ +Show log for one or more revs read from the minibuffer. +The user can input any revision or revisions separated by a +space, or even ranges, but only branches and tags, and a +representation of the commit at point, are available as +completion candidates. + +\(fn REVS &optional ARGS FILES)" t nil) + +(autoload 'magit-log-head "magit-log" "\ +Show log for `HEAD'. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-log-branches "magit-log" "\ +Show log for all local branches and `HEAD'. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-log-matching-branches "magit-log" "\ +Show log for all branches matching PATTERN and `HEAD'. + +\(fn PATTERN &optional ARGS FILES)" t nil) + +(autoload 'magit-log-matching-tags "magit-log" "\ +Show log for all tags matching PATTERN and `HEAD'. + +\(fn PATTERN &optional ARGS FILES)" t nil) + +(autoload 'magit-log-all-branches "magit-log" "\ +Show log for all local and remote branches and `HEAD'. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-log-all "magit-log" "\ +Show log for all references and `HEAD'. + +\(fn &optional ARGS FILES)" t nil) + +(autoload 'magit-log-buffer-file "magit-log" "\ +Show log for the blob or file visited in the current buffer. +With a prefix argument or when `--follow' is an active log +argument, then follow renames. When the region is active, +restrict the log to the lines that the region touches. + +\(fn &optional FOLLOW BEG END)" t nil) + +(autoload 'magit-log-trace-definition "magit-log" "\ +Show log for the definition at point. + +\(fn FILE FN REV)" t nil) + +(autoload 'magit-log-merged "magit-log" "\ +Show log for the merge of COMMIT into BRANCH. + +More precisely, find merge commit M that brought COMMIT into +BRANCH, and show the log of the range \"M^1..M\". If COMMIT is +directly on BRANCH, then show approximately twenty surrounding +commits instead. + +This command requires git-when-merged, which is available from +https://github.com/mhagger/git-when-merged. + +\(fn COMMIT BRANCH &optional ARGS FILES)" t nil) + +(autoload 'magit-log-move-to-parent "magit-log" "\ +Move to the Nth parent of the current commit. + +\(fn &optional N)" t nil) + +(autoload 'magit-cherry "magit-log" "\ +Show commits in a branch that are not merged in the upstream branch. + +\(fn HEAD UPSTREAM)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-log" '("magit"))) + +;;;*** + +;;;### (autoloads nil "magit-margin" "magit-margin.el" (0 0 0 0)) +;;; Generated autoloads from magit-margin.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-margin" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-merge" "magit-merge.el" (0 0 0 0)) +;;; Generated autoloads from magit-merge.el + (autoload 'magit-merge "magit" nil t) + +(autoload 'magit-merge-plain "magit-merge" "\ +Merge commit REV into the current branch; using default message. + +Unless there are conflicts or a prefix argument is used create a +merge commit using a generic commit message and without letting +the user inspect the result. With a prefix argument pretend the +merge failed to give the user the opportunity to inspect the +merge. + +\(git merge --no-edit|--no-commit [ARGS] REV) + +\(fn REV &optional ARGS NOCOMMIT)" t nil) + +(autoload 'magit-merge-editmsg "magit-merge" "\ +Merge commit REV into the current branch; and edit message. +Perform the merge and prepare a commit message but let the user +edit it. + +\(git merge --edit --no-ff [ARGS] REV) + +\(fn REV &optional ARGS)" t nil) + +(autoload 'magit-merge-nocommit "magit-merge" "\ +Merge commit REV into the current branch; pretending it failed. +Pretend the merge failed to give the user the opportunity to +inspect the merge and change the commit message. + +\(git merge --no-commit --no-ff [ARGS] REV) + +\(fn REV &optional ARGS)" t nil) + +(autoload 'magit-merge-into "magit-merge" "\ +Merge the current branch into BRANCH and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +branch, then also remove the respective remote branch. + +\(fn BRANCH &optional ARGS)" t nil) + +(autoload 'magit-merge-absorb "magit-merge" "\ +Merge BRANCH into the current branch and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch. + +\(fn BRANCH &optional ARGS)" t nil) + +(autoload 'magit-merge-squash "magit-merge" "\ +Squash commit REV into the current branch; don't create a commit. + +\(git merge --squash REV) + +\(fn REV)" t nil) + +(autoload 'magit-merge-preview "magit-merge" "\ +Preview result of merging REV into the current branch. + +\(fn REV)" t nil) + +(autoload 'magit-merge-abort "magit-merge" "\ +Abort the current merge operation. + +\(git merge --abort) + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-merge" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-mode" "magit-mode.el" (0 0 0 0)) +;;; Generated autoloads from magit-mode.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-mode" '("magit-" "disable-magit-save-buffers" "inhibit-magit-refresh"))) + +;;;*** + +;;;### (autoloads nil "magit-notes" "magit-notes.el" (0 0 0 0)) +;;; Generated autoloads from magit-notes.el + (autoload 'magit-notes "magit" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-notes" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-obsolete" "magit-obsolete.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from magit-obsolete.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-obsolete" '("magit--magit-popup-warning"))) + +;;;*** + +;;;### (autoloads nil "magit-patch" "magit-patch.el" (0 0 0 0)) +;;; Generated autoloads from magit-patch.el + (autoload 'magit-patch "magit-patch" nil t) + (autoload 'magit-patch-create "magit-patch" nil t) + (autoload 'magit-patch-apply "magit-patch" nil t) + +(autoload 'magit-patch-save "magit-patch" "\ +Write current diff into patch FILE. + +What arguments are used to create the patch depends on the value +of `magit-patch-save-arguments' and whether a prefix argument is +used. + +If the value is the symbol `buffer', then use the same arguments +as the buffer. With a prefix argument use no arguments. + +If the value is a list beginning with the symbol `exclude', then +use the same arguments as the buffer except for those matched by +entries in the cdr of the list. The comparison is done using +`string-prefix-p'. With a prefix argument use the same arguments +as the buffer. + +If the value is a list of strings (including the empty list), +then use those arguments. With a prefix argument use the same +arguments as the buffer. + +Of course the arguments that are required to actually show the +same differences as those shown in the buffer are always used. + +\(fn FILE &optional ARG)" t nil) + +(autoload 'magit-request-pull "magit-patch" "\ +Request upstream to pull from you public repository. + +URL is the url of your publicly accessible repository. +START is a commit that already is in the upstream repository. +END is the last commit, usually a branch name, which upstream +is asked to pull. START has to be reachable from that commit. + +\(fn URL START END)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-patch" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-process" "magit-process.el" (0 0 0 0)) +;;; Generated autoloads from magit-process.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-process" '("magit-" "tramp-sh-handle-"))) + +;;;*** + +;;;### (autoloads nil "magit-pull" "magit-pull.el" (0 0 0 0)) +;;; Generated autoloads from magit-pull.el + (autoload 'magit-pull "magit-pull" nil t) + (autoload 'magit-pull-from-pushremote "magit-pull" nil t) + (autoload 'magit-pull-from-upstream "magit-pull" nil t) + +(autoload 'magit-pull-branch "magit-pull" "\ +Pull from a branch read in the minibuffer. + +\(fn SOURCE ARGS)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-pull" '("magit-pull"))) + +;;;*** + +;;;### (autoloads nil "magit-push" "magit-push.el" (0 0 0 0)) +;;; Generated autoloads from magit-push.el + (autoload 'magit-push "magit-push" nil t) + (autoload 'magit-push-current-to-pushremote "magit-push" nil t) + (autoload 'magit-push-current-to-upstream "magit-push" nil t) + +(autoload 'magit-push-current "magit-push" "\ +Push the current branch to a branch read in the minibuffer. + +\(fn TARGET ARGS)" t nil) + +(autoload 'magit-push-other "magit-push" "\ +Push an arbitrary branch or commit somewhere. +Both the source and the target are read in the minibuffer. + +\(fn SOURCE TARGET ARGS)" t nil) + +(autoload 'magit-push-refspecs "magit-push" "\ +Push one or multiple REFSPECS to a REMOTE. +Both the REMOTE and the REFSPECS are read in the minibuffer. To +use multiple REFSPECS, separate them with commas. Completion is +only available for the part before the colon, or when no colon +is used. + +\(fn REMOTE REFSPECS ARGS)" t nil) + +(autoload 'magit-push-matching "magit-push" "\ +Push all matching branches to another repository. +If multiple remotes exist, then read one from the user. +If just one exists, use that without requiring confirmation. + +\(fn REMOTE &optional ARGS)" t nil) + +(autoload 'magit-push-tags "magit-push" "\ +Push all tags to another repository. +If only one remote exists, then push to that. Otherwise prompt +for a remote, offering the remote configured for the current +branch as default. + +\(fn REMOTE &optional ARGS)" t nil) + +(autoload 'magit-push-tag "magit-push" "\ +Push a tag to another repository. + +\(fn TAG REMOTE &optional ARGS)" t nil) + +(autoload 'magit-push-notes-ref "magit-push" "\ +Push a notes ref to another repository. + +\(fn REF REMOTE &optional ARGS)" t nil) + +(autoload 'magit-push-implicitly "magit-push" "\ +Push somewhere without using an explicit refspec. + +This command simply runs \"git push -v [ARGS]\". ARGS are the +arguments specified in the popup buffer. No explicit refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'. + +The function `magit-push-implicitly--desc' attempts to predict +what this command will do. The value it returns is displayed in +the popup buffer. + +\(fn ARGS)" t nil) + +(autoload 'magit-push-to-remote "magit-push" "\ +Push to REMOTE without using an explicit refspec. +The REMOTE is read in the minibuffer. + +This command simply runs \"git push -v [ARGS] REMOTE\". ARGS +are the arguments specified in the popup buffer. No refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'. + +\(fn REMOTE ARGS)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-push" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-reflog" "magit-reflog.el" (0 0 0 0)) +;;; Generated autoloads from magit-reflog.el + +(autoload 'magit-reflog-current "magit-reflog" "\ +Display the reflog of the current branch. +If `HEAD' is detached, then show the reflog for that instead. + +\(fn)" t nil) + +(autoload 'magit-reflog-other "magit-reflog" "\ +Display the reflog of a branch or another ref. + +\(fn REF)" t nil) + +(autoload 'magit-reflog-head "magit-reflog" "\ +Display the `HEAD' reflog. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-reflog" '("magit-reflog-"))) + +;;;*** + +;;;### (autoloads nil "magit-refs" "magit-refs.el" (0 0 0 0)) +;;; Generated autoloads from magit-refs.el + (autoload 'magit-show-refs "magit-refs" nil t) + +(autoload 'magit-show-refs-head "magit-refs" "\ +List and compare references in a dedicated buffer. +Compared with `HEAD'. + +\(fn &optional ARGS)" t nil) + +(autoload 'magit-show-refs-current "magit-refs" "\ +List and compare references in a dedicated buffer. +Compare with the current branch or `HEAD' if it is detached. + +\(fn &optional ARGS)" t nil) + +(autoload 'magit-show-refs-other "magit-refs" "\ +List and compare references in a dedicated buffer. +Compared with a branch read from the user. + +\(fn &optional REF ARGS)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-refs" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-remote" "magit-remote.el" (0 0 0 0)) +;;; Generated autoloads from magit-remote.el + (autoload 'magit-remote "magit-remote" nil t) + +(autoload 'magit-remote-add "magit-remote" "\ +Add a remote named REMOTE and fetch it. + +\(fn REMOTE URL &optional ARGS)" t nil) + +(autoload 'magit-remote-rename "magit-remote" "\ +Rename the remote named OLD to NEW. + +\(fn OLD NEW)" t nil) + +(autoload 'magit-remote-remove "magit-remote" "\ +Delete the remote named REMOTE. + +\(fn REMOTE)" t nil) + +(autoload 'magit-remote-prune "magit-remote" "\ +Remove stale remote-tracking branches for REMOTE. + +\(fn REMOTE)" t nil) + +(autoload 'magit-remote-prune-refspecs "magit-remote" "\ +Remove stale refspecs for REMOTE. + +A refspec is stale if there no longer exists at least one branch +on the remote that would be fetched due to that refspec. A stale +refspec is problematic because its existence causes Git to refuse +to fetch according to the remaining non-stale refspecs. + +If only stale refspecs remain, then offer to either delete the +remote or to replace the stale refspecs with the default refspec. + +Also remove the remote-tracking branches that were created due to +the now stale refspecs. Other stale branches are not removed. + +\(fn REMOTE)" t nil) + +(autoload 'magit-remote-set-head "magit-remote" "\ +Set the local representation of REMOTE's default branch. +Query REMOTE and set the symbolic-ref refs/remotes//HEAD +accordingly. With a prefix argument query for the branch to be +used, which allows you to select an incorrect value if you fancy +doing that. + +\(fn REMOTE &optional BRANCH)" t nil) + +(autoload 'magit-remote-unset-head "magit-remote" "\ +Unset the local representation of REMOTE's default branch. +Delete the symbolic-ref \"refs/remotes//HEAD\". + +\(fn REMOTE)" t nil) + (autoload 'magit-remote-configure "magit-remote" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-remote" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-repos" "magit-repos.el" (0 0 0 0)) +;;; Generated autoloads from magit-repos.el + +(autoload 'magit-list-repositories "magit-repos" "\ +Display a list of repositories. + +Use the options `magit-repository-directories' to control which +repositories are displayed. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-repos" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-reset" "magit-reset.el" (0 0 0 0)) +;;; Generated autoloads from magit-reset.el + (autoload 'magit-reset "magit" nil t) + +(autoload 'magit-reset-mixed "magit-reset" "\ +Reset the `HEAD' and index to COMMIT, but not the working tree. + +\(git reset --mixed COMMIT) + +\(fn COMMIT)" t nil) + +(autoload 'magit-reset-soft "magit-reset" "\ +Reset the `HEAD' to COMMIT, but not the index and working tree. + +\(git reset --soft REVISION) + +\(fn COMMIT)" t nil) + +(autoload 'magit-reset-hard "magit-reset" "\ +Reset the `HEAD', index, and working tree to COMMIT. + +\(git reset --hard REVISION) + +\(fn COMMIT)" t nil) + +(autoload 'magit-reset-index "magit-reset" "\ +Reset the index to COMMIT. +Keep the `HEAD' and working tree as-is, so if COMMIT refers to the +head this effectively unstages all changes. + +\(git reset COMMIT .) + +\(fn COMMIT)" t nil) + +(autoload 'magit-reset-worktree "magit-reset" "\ +Reset the worktree to COMMIT. +Keep the `HEAD' and index as-is. + +\(fn COMMIT)" t nil) + +(autoload 'magit-reset-quickly "magit-reset" "\ +Reset the `HEAD' and index to COMMIT, and possibly the working tree. +With a prefix argument reset the working tree otherwise don't. + +\(git reset --mixed|--hard COMMIT) + +\(fn COMMIT &optional HARD)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-reset" '("magit-reset"))) + +;;;*** + +;;;### (autoloads nil "magit-section" "magit-section.el" (0 0 0 0)) +;;; Generated autoloads from magit-section.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-section" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-sequence" "magit-sequence.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from magit-sequence.el + +(autoload 'magit-sequencer-continue "magit-sequence" "\ +Resume the current cherry-pick or revert sequence. + +\(fn)" t nil) + +(autoload 'magit-sequencer-skip "magit-sequence" "\ +Skip the stopped at commit during a cherry-pick or revert sequence. + +\(fn)" t nil) + +(autoload 'magit-sequencer-abort "magit-sequence" "\ +Abort the current cherry-pick or revert sequence. +This discards all changes made since the sequence started. + +\(fn)" t nil) + (autoload 'magit-cherry-pick "magit-sequence" nil t) + +(autoload 'magit-cherry-copy "magit-sequence" "\ +Copy COMMITS from another branch onto the current branch. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then pick all of them, +without prompting. + +\(fn COMMITS &optional ARGS)" t nil) + +(autoload 'magit-cherry-apply "magit-sequence" "\ +Apply the changes in COMMITS but do not commit them. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then apply all of them, +without prompting. + +\(fn COMMITS &optional ARGS)" t nil) + +(autoload 'magit-cherry-harvest "magit-sequence" "\ +Move COMMITS from another BRANCH onto the current branch. +Remove the COMMITS from BRANCH and stay on the current branch. +If a conflict occurs, then you have to fix that and finish the +process manually. + +\(fn COMMITS BRANCH &optional ARGS)" t nil) + +(autoload 'magit-cherry-donate "magit-sequence" "\ +Move COMMITS from the current branch onto another existing BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually. + +\(fn COMMITS BRANCH &optional ARGS)" t nil) + +(autoload 'magit-cherry-spinout "magit-sequence" "\ +Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually. + +\(fn COMMITS BRANCH START-POINT &optional ARGS)" t nil) + +(autoload 'magit-cherry-spinoff "magit-sequence" "\ +Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and checkout BRANCH. +If a conflict occurs, then you have to fix that and finish +the process manually. + +\(fn COMMITS BRANCH START-POINT &optional ARGS)" t nil) + (autoload 'magit-revert "magit-sequence" nil t) + +(autoload 'magit-revert-and-commit "magit-sequence" "\ +Revert COMMIT by creating a new commit. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting. + +\(fn COMMIT &optional ARGS)" t nil) + +(autoload 'magit-revert-no-commit "magit-sequence" "\ +Revert COMMIT by applying it in reverse to the worktree. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting. + +\(fn COMMIT &optional ARGS)" t nil) + (autoload 'magit-am "magit-sequence" nil t) + +(autoload 'magit-am-apply-patches "magit-sequence" "\ +Apply the patches FILES. + +\(fn &optional FILES ARGS)" t nil) + +(autoload 'magit-am-apply-maildir "magit-sequence" "\ +Apply the patches from MAILDIR. + +\(fn &optional MAILDIR ARGS)" t nil) + +(autoload 'magit-am-continue "magit-sequence" "\ +Resume the current patch applying sequence. + +\(fn)" t nil) + +(autoload 'magit-am-skip "magit-sequence" "\ +Skip the stopped at patch during a patch applying sequence. + +\(fn)" t nil) + +(autoload 'magit-am-abort "magit-sequence" "\ +Abort the current patch applying sequence. +This discards all changes made since the sequence started. + +\(fn)" t nil) + (autoload 'magit-rebase "magit-sequence" nil t) + (autoload 'magit-rebase-onto-pushremote "magit-sequence" nil t) + (autoload 'magit-rebase-onto-upstream "magit-sequence" nil t) + +(autoload 'magit-rebase-branch "magit-sequence" "\ +Rebase the current branch onto a branch read in the minibuffer. +All commits that are reachable from `HEAD' but not from the +selected branch TARGET are being rebased. + +\(fn TARGET ARGS)" t nil) + +(autoload 'magit-rebase-subset "magit-sequence" "\ +Rebase a subset of the current branch's history onto a new base. +Rebase commits from START to `HEAD' onto NEWBASE. +START has to be selected from a list of recent commits. + +\(fn NEWBASE START ARGS)" t nil) + +(autoload 'magit-rebase-interactive "magit-sequence" "\ +Start an interactive rebase sequence. + +\(fn COMMIT ARGS)" t nil) + +(autoload 'magit-rebase-autosquash "magit-sequence" "\ +Combine squash and fixup commits with their intended targets. + +\(fn ARGS)" t nil) + +(autoload 'magit-rebase-edit-commit "magit-sequence" "\ +Edit a single older commit using rebase. + +\(fn COMMIT ARGS)" t nil) + +(autoload 'magit-rebase-reword-commit "magit-sequence" "\ +Reword a single older commit using rebase. + +\(fn COMMIT ARGS)" t nil) + +(autoload 'magit-rebase-remove-commit "magit-sequence" "\ +Remove a single older commit using rebase. + +\(fn COMMIT ARGS)" t nil) + +(autoload 'magit-rebase-continue "magit-sequence" "\ +Restart the current rebasing operation. +In some cases this pops up a commit message buffer for you do +edit. With a prefix argument the old message is reused as-is. + +\(fn &optional NOEDIT)" t nil) + +(autoload 'magit-rebase-skip "magit-sequence" "\ +Skip the current commit and restart the current rebase operation. + +\(fn)" t nil) + +(autoload 'magit-rebase-edit "magit-sequence" "\ +Edit the todo list of the current rebase operation. + +\(fn)" t nil) + +(autoload 'magit-rebase-abort "magit-sequence" "\ +Abort the current rebase operation, restoring the original branch. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-sequence" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-stash" "magit-stash.el" (0 0 0 0)) +;;; Generated autoloads from magit-stash.el + (autoload 'magit-stash "magit-stash" nil t) + +(autoload 'magit-stash-both "magit-stash" "\ +Create a stash of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +\(fn MESSAGE &optional INCLUDE-UNTRACKED)" t nil) + +(autoload 'magit-stash-index "magit-stash" "\ +Create a stash of the index only. +Unstaged and untracked changes are not stashed. The stashed +changes are applied in reverse to both the index and the +worktree. This command can fail when the worktree is not clean. +Applying the resulting stash has the inverse effect. + +\(fn MESSAGE)" t nil) + +(autoload 'magit-stash-worktree "magit-stash" "\ +Create a stash of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +\(fn MESSAGE &optional INCLUDE-UNTRACKED)" t nil) + +(autoload 'magit-stash-keep-index "magit-stash" "\ +Create a stash of the index and working tree, keeping index intact. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +\(fn MESSAGE &optional INCLUDE-UNTRACKED)" t nil) + +(autoload 'magit-snapshot-both "magit-stash" "\ +Create a snapshot of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +\(fn &optional INCLUDE-UNTRACKED)" t nil) + +(autoload 'magit-snapshot-index "magit-stash" "\ +Create a snapshot of the index only. +Unstaged and untracked changes are not stashed. + +\(fn)" t nil) + +(autoload 'magit-snapshot-worktree "magit-stash" "\ +Create a snapshot of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +\(fn &optional INCLUDE-UNTRACKED)" t nil) + +(autoload 'magit-stash-apply "magit-stash" "\ +Apply a stash to the working tree. +Try to preserve the stash index. If that fails because there +are staged changes, apply without preserving the stash index. + +\(fn STASH)" t nil) + +(autoload 'magit-stash-drop "magit-stash" "\ +Remove a stash from the stash list. +When the region is active offer to drop all contained stashes. + +\(fn STASH)" t nil) + +(autoload 'magit-stash-clear "magit-stash" "\ +Remove all stashes saved in REF's reflog by deleting REF. + +\(fn REF)" t nil) + +(autoload 'magit-stash-branch "magit-stash" "\ +Create and checkout a new BRANCH from STASH. + +\(fn STASH BRANCH)" t nil) + +(autoload 'magit-stash-branch-here "magit-stash" "\ +Create and checkout a new BRANCH and apply STASH. +The branch is created using `magit-branch-and-checkout', using the +current branch or `HEAD' as the start-point. + +\(fn STASH BRANCH)" t nil) + +(autoload 'magit-stash-format-patch "magit-stash" "\ +Create a patch from STASH + +\(fn STASH)" t nil) + +(autoload 'magit-stash-list "magit-stash" "\ +List all stashes in a buffer. + +\(fn)" t nil) + +(autoload 'magit-stash-show "magit-stash" "\ +Show all diffs of a stash in a buffer. + +\(fn STASH &optional ARGS FILES)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-stash" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-status" "magit-status.el" (0 0 0 0)) +;;; Generated autoloads from magit-status.el + +(autoload 'magit-init "magit-status" "\ +Initialize a Git repository, then show its status. + +If the directory is below an existing repository, then the user +has to confirm that a new one should be created inside. If the +directory is the root of the existing repository, then the user +has to confirm that it should be reinitialized. + +Non-interactively DIRECTORY is (re-)initialized unconditionally. + +\(fn DIRECTORY)" t nil) + +(autoload 'magit-status "magit-status" "\ +Show the status of the current Git repository in a buffer. + +If the current directory isn't located within a Git repository, +then prompt for an existing repository or an arbitrary directory, +depending on option `magit-repository-directories', and show the +status of the selected repository instead. + +* If that option specifies any existing repositories, then offer + those for completion and show the status buffer for the + selected one. + +* Otherwise read an arbitrary directory using regular file-name + completion. If the selected directory is the top-level of an + existing working tree, then show the status buffer for that. + +* Otherwise offer to initialize the selected directory as a new + repository. After creating the repository show its status + buffer. + +These fallback behaviors can also be forced using one or more +prefix arguments: + +* With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) read an arbitrary directory and act on + it as described above. The same could be accomplished using + the command `magit-init'. + +* With a single prefix argument read an existing repository, or + if none can be found based on `magit-repository-directories', + then fall back to the same behavior as with two prefix + arguments. + +\(fn &optional DIRECTORY CACHE)" t nil) + +(defalias 'magit 'magit-status "\ +An alias for `magit-status' for better discoverability. + +Instead of invoking this alias for `magit-status' using +\"M-x magit RET\", you should bind a key to `magit-status' +and read the info node `(magit)Getting Started', which +also contains other useful hints.") + +(autoload 'magit-status-here "magit-status" "\ +Like `magit-status' but with non-nil `magit-status-goto-file-position'. + +\(fn)" t nil) + +(autoload 'magit-status-setup-buffer "magit-status" "\ + + +\(fn &optional DIRECTORY)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-status" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-submodule" "magit-submodule.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from magit-submodule.el + (autoload 'magit-submodule "magit-submodule" nil t) + (autoload 'magit-submodule-add "magit-submodule" nil t) + +(autoload 'magit-submodule-read-name-for-path "magit-submodule" "\ + + +\(fn PATH &optional PREFER-SHORT)" nil nil) + (autoload 'magit-submodule-register "magit-submodule" nil t) + (autoload 'magit-submodule-populate "magit-submodule" nil t) + (autoload 'magit-submodule-update "magit-submodule" nil t) + (autoload 'magit-submodule-synchronize "magit-submodule" nil t) + (autoload 'magit-submodule-unpopulate "magit-submodule" nil t) + +(autoload 'magit-submodule-remove "magit-submodule" "\ +Unregister MODULES and remove their working directories. + +For safety reasons, do not remove the gitdirs and if a module has +uncomitted changes, then do not remove it at all. If a module's +gitdir is located inside the working directory, then move it into +the gitdir of the superproject first. + +With the \"--force\" argument offer to remove dirty working +directories and with a prefix argument offer to delete gitdirs. +Both actions are very dangerous and have to be confirmed. There +are additional safety precautions in place, so you might be able +to recover from making a mistake here, but don't count on it. + +\(fn MODULES ARGS TRASH-GITDIRS)" t nil) + +(autoload 'magit-insert-modules "magit-submodule" "\ +Insert submodule sections. +Hook `magit-module-sections-hook' controls which module sections +are inserted, and option `magit-module-sections-nested' controls +whether they are wrapped in an additional section. + +\(fn)" nil nil) + +(autoload 'magit-insert-modules-overview "magit-submodule" "\ +Insert sections for all modules. +For each section insert the path and the output of `git describe --tags', +or, failing that, the abbreviated HEAD commit hash. + +\(fn)" nil nil) + +(autoload 'magit-insert-modules-unpulled-from-upstream "magit-submodule" "\ +Insert sections for modules that haven't been pulled from the upstream. +These sections can be expanded to show the respective commits. + +\(fn)" nil nil) + +(autoload 'magit-insert-modules-unpulled-from-pushremote "magit-submodule" "\ +Insert sections for modules that haven't been pulled from the push-remote. +These sections can be expanded to show the respective commits. + +\(fn)" nil nil) + +(autoload 'magit-insert-modules-unpushed-to-upstream "magit-submodule" "\ +Insert sections for modules that haven't been pushed to the upstream. +These sections can be expanded to show the respective commits. + +\(fn)" nil nil) + +(autoload 'magit-insert-modules-unpushed-to-pushremote "magit-submodule" "\ +Insert sections for modules that haven't been pushed to the push-remote. +These sections can be expanded to show the respective commits. + +\(fn)" nil nil) + +(autoload 'magit-list-submodules "magit-submodule" "\ +Display a list of the current repository's submodules. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-submodule" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-subtree" "magit-subtree.el" (0 0 0 0)) +;;; Generated autoloads from magit-subtree.el + (autoload 'magit-subtree "magit-subtree" nil t) + (autoload 'magit-subtree-import "magit-subtree" nil t) + (autoload 'magit-subtree-export "magit-subtree" nil t) + +(autoload 'magit-subtree-add "magit-subtree" "\ +Add REF from REPOSITORY as a new subtree at PREFIX. + +\(fn PREFIX REPOSITORY REF ARGS)" t nil) + +(autoload 'magit-subtree-add-commit "magit-subtree" "\ +Add COMMIT as a new subtree at PREFIX. + +\(fn PREFIX COMMIT ARGS)" t nil) + +(autoload 'magit-subtree-merge "magit-subtree" "\ +Merge COMMIT into the PREFIX subtree. + +\(fn PREFIX COMMIT ARGS)" t nil) + +(autoload 'magit-subtree-pull "magit-subtree" "\ +Pull REF from REPOSITORY into the PREFIX subtree. + +\(fn PREFIX REPOSITORY REF ARGS)" t nil) + +(autoload 'magit-subtree-push "magit-subtree" "\ +Extract the history of the subtree PREFIX and push it to REF on REPOSITORY. + +\(fn PREFIX REPOSITORY REF ARGS)" t nil) + +(autoload 'magit-subtree-split "magit-subtree" "\ +Extract the history of the subtree PREFIX. + +\(fn PREFIX COMMIT ARGS)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-subtree" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-tag" "magit-tag.el" (0 0 0 0)) +;;; Generated autoloads from magit-tag.el + (autoload 'magit-tag "magit" nil t) + +(autoload 'magit-tag-create "magit-tag" "\ +Create a new tag with the given NAME at REV. +With a prefix argument annotate the tag. + +\(git tag [--annotate] NAME REV) + +\(fn NAME REV &optional ARGS)" t nil) + +(autoload 'magit-tag-delete "magit-tag" "\ +Delete one or more tags. +If the region marks multiple tags (and nothing else), then offer +to delete those, otherwise prompt for a single tag to be deleted, +defaulting to the tag at point. + +\(git tag -d TAGS) + +\(fn TAGS)" t nil) + +(autoload 'magit-tag-prune "magit-tag" "\ +Offer to delete tags missing locally from REMOTE, and vice versa. + +\(fn TAGS REMOTE-TAGS REMOTE)" t nil) + +(autoload 'magit-tag-release "magit-tag" "\ +Create an annotated release tag. + +Assume that release tags match `magit-release-tag-regexp'. + +First prompt for the name of the new tag using the highest +existing tag as initial input and leaving it to the user to +increment the desired part of the version string. + +Then prompt for the message of the new tag. Base the proposed +tag message on the message of the highest tag, provided that +that contains the corresponding version string and substituting +the new version string for that. Otherwise propose something +like \"Foo-Bar 1.2.3\", given, for example, a TAG \"v1.2.3\" and a +repository located at something like \"/path/to/foo-bar\". + +Then call \"git tag --annotate --sign -m MSG TAG\" to create the, +tag, regardless of whether these arguments are enabled in the +popup. Finally show the refs buffer to let the user quickly +review the result. + +\(fn TAG MSG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-tag" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-transient" "magit-transient.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from magit-transient.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-transient" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-utils" "magit-utils.el" (0 0 0 0)) +;;; Generated autoloads from magit-utils.el + +(autoload 'magit-emacs-Q-command "magit-utils" "\ +Show a shell command that runs an uncustomized Emacs with only Magit loaded. +See info node `(magit)Debugging Tools' for more information. + +\(fn)" t nil) + +(autoload 'Info-follow-nearest-node--magit-gitman "magit-utils" "\ + + +\(fn FN &optional FORK)" nil nil) + +(advice-add 'Info-follow-nearest-node :around 'Info-follow-nearest-node--magit-gitman) + +(autoload 'org-man-export--magit-gitman "magit-utils" "\ + + +\(fn FN LINK DESCRIPTION FORMAT)" nil nil) + +(advice-add 'org-man-export :around 'org-man-export--magit-gitman) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-utils" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-wip" "magit-wip.el" (0 0 0 0)) +;;; Generated autoloads from magit-wip.el + +(defvar magit-wip-after-save-mode nil "\ +Non-nil if Magit-Wip-After-Save mode is enabled. +See the `magit-wip-after-save-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-wip-after-save-mode'.") + +(custom-autoload 'magit-wip-after-save-mode "magit-wip" nil) + +(autoload 'magit-wip-after-save-mode "magit-wip" "\ +Toggle Magit-Wip-After-Save-Local mode in all buffers. +With prefix ARG, enable Magit-Wip-After-Save mode if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Magit-Wip-After-Save-Local mode is enabled in all buffers where +`magit-wip-after-save-local-mode-turn-on' would do it. +See `magit-wip-after-save-local-mode' for more information on Magit-Wip-After-Save-Local mode. + +\(fn &optional ARG)" t nil) + +(defvar magit-wip-after-apply-mode nil "\ +Non-nil if Magit-Wip-After-Apply mode is enabled. +See the `magit-wip-after-apply-mode' command +for a description of this minor mode.") + +(custom-autoload 'magit-wip-after-apply-mode "magit-wip" nil) + +(autoload 'magit-wip-after-apply-mode "magit-wip" "\ +Commit to work-in-progress refs. + +After applying a change using any \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected files to the current wip refs. For each branch there +may be two wip refs; one contains snapshots of the files as found +in the worktree and the other contains snapshots of the entries +in the index. + +\(fn &optional ARG)" t nil) + +(defvar magit-wip-before-change-mode nil "\ +Non-nil if Magit-Wip-Before-Change mode is enabled. +See the `magit-wip-before-change-mode' command +for a description of this minor mode.") + +(custom-autoload 'magit-wip-before-change-mode "magit-wip" nil) + +(autoload 'magit-wip-before-change-mode "magit-wip" "\ +Commit to work-in-progress refs before certain destructive changes. + +Before invoking a revert command or an \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected tracked files to the current wip refs. For each branch +there may be two wip refs; one contains snapshots of the files +as found in the worktree and the other contains snapshots of the +entries in the index. + +Only changes to files which could potentially be affected by the +command which is about to be called are committed. + +\(fn &optional ARG)" t nil) + +(autoload 'magit-wip-commit-initial-backup "magit-wip" "\ +Before saving, commit current file to a worktree wip ref. + +The user has to add this function to `before-save-hook'. + +Commit the current state of the visited file before saving the +current buffer to that file. This backs up the same version of +the file as `backup-buffer' would, but stores the backup in the +worktree wip ref, which is also used by the various Magit Wip +modes, instead of in a backup file as `backup-buffer' would. + +This function ignores the variables that affect `backup-buffer' +and can be used along-side that function, which is recommended +because this function only backs up files that are tracked in +a Git repository. + +\(fn)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-wip" '("magit-"))) + +;;;*** + +;;;### (autoloads nil "magit-worktree" "magit-worktree.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from magit-worktree.el + (autoload 'magit-worktree "magit-worktree" nil t) + +(autoload 'magit-worktree-checkout "magit-worktree" "\ +Checkout BRANCH in a new worktree at PATH. + +\(fn PATH BRANCH)" t nil) + +(autoload 'magit-worktree-branch "magit-worktree" "\ +Create a new BRANCH and check it out in a new worktree at PATH. + +\(fn PATH BRANCH START-POINT &optional FORCE)" t nil) + +(autoload 'magit-worktree-move "magit-worktree" "\ +Move WORKTREE to PATH. + +\(fn WORKTREE PATH)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "magit-worktree" '("magit-"))) + +;;;*** + +;;;### (autoloads nil nil ("magit-core.el" "magit-pkg.el") (0 0 0 +;;;;;; 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; magit-autoloads.el ends here diff --git a/elpa/magit-20200318.1224/magit-autorevert.el b/elpa/magit-20200318.1224/magit-autorevert.el new file mode 100644 index 00000000..74c07210 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-autorevert.el @@ -0,0 +1,269 @@ +;;; magit-autorevert.el --- revert buffers when files in repository change -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Code: + +(require 'cl-lib) +(require 'dash) + +(require 'magit-git) + +(require 'autorevert) + +;;; Options + +(defgroup magit-auto-revert nil + "Revert buffers when files in repository change." + :link '(custom-group-link auto-revert) + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'auto-revert + :group 'magit-essentials + :group 'magit-modes) + +(defcustom auto-revert-buffer-list-filter nil + "Filter that determines which buffers `auto-revert-buffers' reverts. + +This option is provided by Magit, which also advises +`auto-revert-buffers' to respect it. Magit users who do not turn +on the local mode `auto-revert-mode' themselves, are best served +by setting the value to `magit-auto-revert-repository-buffer-p'. + +However the default is nil, so as not to disturb users who do use +the local mode directly. If you experience delays when running +Magit commands, then you should consider using one of the +predicates provided by Magit - especially if you also use Tramp. + +Users who do turn on `auto-revert-mode' in buffers in which Magit +doesn't do that for them, should likely not use any filter. +Users who turn on `global-auto-revert-mode', do not have to worry +about this option, because it is disregarded if the global mode +is enabled." + :package-version '(magit . "2.4.2") + :group 'auto-revert + :group 'magit-auto-revert + :group 'magit-related + :type '(radio (const :tag "No filter" nil) + (function-item magit-auto-revert-buffer-p) + (function-item magit-auto-revert-repository-buffer-p) + function)) + +(defcustom magit-auto-revert-tracked-only t + "Whether `magit-auto-revert-mode' only reverts tracked files." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean + :set (lambda (var val) + (set var val) + (when (and (bound-and-true-p magit-auto-revert-mode) + (featurep 'magit-autorevert)) + (magit-auto-revert-mode -1) + (magit-auto-revert-mode)))) + +(defcustom magit-auto-revert-immediately t + "Whether Magit reverts buffers immediately. + +If this is non-nil and either `global-auto-revert-mode' or +`magit-auto-revert-mode' is enabled, then Magit immediately +reverts buffers by explicitly calling `auto-revert-buffers' +after running Git for side-effects. + +If `auto-revert-use-notify' is non-nil (and file notifications +are actually supported), then `magit-auto-revert-immediately' +does not have to be non-nil, because the reverts happen +immediately anyway. + +If `magit-auto-revert-immediately' and `auto-revert-use-notify' +are both nil, then reverts happen after `auto-revert-interval' +seconds of user inactivity. That is not desirable." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean) + +;;; Mode + +(defun magit-turn-on-auto-revert-mode-if-desired (&optional file) + (if file + (--when-let (find-buffer-visiting file) + (with-current-buffer it + (magit-turn-on-auto-revert-mode-if-desired))) + (when (and buffer-file-name + (file-readable-p buffer-file-name) + (or (< emacs-major-version 27) + (with-no-warnings + (condition-case nil + (executable-find magit-git-executable t) ; see #3684 + (wrong-number-of-arguments t)))) ; very old 27 built + (magit-toplevel) + (or (not magit-auto-revert-tracked-only) + (magit-file-tracked-p buffer-file-name)) + (not auto-revert-mode) ; see #3014 + (not global-auto-revert-mode)) ; see #3460 + (auto-revert-mode 1)))) + +;;;###autoload +(define-globalized-minor-mode magit-auto-revert-mode auto-revert-mode + magit-turn-on-auto-revert-mode-if-desired + :package-version '(magit . "2.4.0") + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'magit-auto-revert + :group 'magit-essentials + ;; - When `global-auto-revert-mode' is enabled, then this mode is + ;; redundant. + ;; - In all other cases enable the mode because if buffers are not + ;; automatically reverted that would make many very common tasks + ;; much more cumbersome. + :init-value (not (or global-auto-revert-mode + noninteractive))) +;; - Unfortunately `:init-value t' only sets the value of the mode +;; variable but does not cause the mode function to be called. +;; - I don't think it works like this on purpose, but since one usually +;; should not enable global modes by default, it is understandable. +;; - If the user has set the variable `magit-auto-revert-mode' to nil +;; after loading magit (instead of doing so before loading magit or +;; by using the function), then we should still respect that setting. +;; - If the user sets one of these variables after loading magit and +;; after `after-init-hook' has run, then that won't have an effect +;; and there is nothing we can do about it. +(defun magit-auto-revert-mode--init-kludge () + "This is an internal kludge to be used on `after-init-hook'. +Do not use this function elsewhere, and don't remove it from +the `after-init-hook'. For more information see the comments +and code surrounding the definition of this function." + (if magit-auto-revert-mode + (let ((start (current-time))) + (magit-message "Turning on magit-auto-revert-mode...") + (magit-auto-revert-mode 1) + (magit-message + "Turning on magit-auto-revert-mode...done%s" + (let ((elapsed (float-time (time-subtract nil start)))) + (if (> elapsed 0.2) + (format " (%.3fs, %s buffers checked)" elapsed + (length (buffer-list))) + "")))) + (magit-auto-revert-mode -1))) +(if after-init-time + ;; Since `after-init-hook' has already been + ;; run, turn the mode on or off right now. + (magit-auto-revert-mode--init-kludge) + ;; By the time the init file has been fully loaded the + ;; values of the relevant variables might have changed. + (add-hook 'after-init-hook #'magit-auto-revert-mode--init-kludge t)) + +(put 'magit-auto-revert-mode 'function-documentation + "Toggle Magit Auto Revert mode. +If called interactively, enable Magit Auto Revert mode if ARG is +positive, and disable it if ARG is zero or negative. If called +from Lisp, also enable the mode if ARG is omitted or nil, and +toggle it if ARG is `toggle'; disable the mode otherwise. + +Magit Auto Revert mode is a global minor mode that reverts +buffers associated with a file that is located inside a Git +repository when the file changes on disk. Use `auto-revert-mode' +to revert a particular buffer. Or use `global-auto-revert-mode' +to revert all file-visiting buffers, not just those that visit +a file located inside a Git repository. + +This global mode works by turning on the buffer-local mode +`auto-revert-mode' at the time a buffer is first created. The +local mode is turned on if the visited file is being tracked in +a Git repository at the time when the buffer is created. + +If `magit-auto-revert-tracked-only' is non-nil (the default), +then only tracked files are reverted. But if you stage a +previously untracked file using `magit-stage', then this mode +notices that. + +Unlike `global-auto-revert-mode', this mode never reverts any +buffers that are not visiting files. + +The behavior of this mode can be customized using the options +in the `autorevert' and `magit-autorevert' groups. + +This function calls the hook `magit-auto-revert-mode-hook'. + +Like nearly every mode, this mode should be enabled or disabled +by calling the respective mode function, the reason being that +changing the state of a mode involves more than merely toggling +a single switch, so setting the mode variable is not enough. +Also, you should not use `after-init-hook' to disable this mode.") + +(defun magit-auto-revert-buffers () + (when (and magit-auto-revert-immediately + (or global-auto-revert-mode + (and magit-auto-revert-mode auto-revert-buffer-list))) + (let ((auto-revert-buffer-list-filter + (or auto-revert-buffer-list-filter + #'magit-auto-revert-repository-buffer-p))) + (auto-revert-buffers)))) + +(defvar magit-auto-revert-toplevel nil) + +(defvar magit-auto-revert-counter 1 + "Incremented each time `auto-revert-buffers' is called.") + +(defun magit-auto-revert-buffer-p (buffer) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return t for any BUFFER." + (magit-auto-revert-repository-buffer-p buffer t)) + +(defun magit-auto-revert-repository-buffer-p (buffer &optional fallback) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return FALLBACK (which +defaults to nil) for any BUFFER." + ;; Call `magit-toplevel' just once per cycle. + (unless (and magit-auto-revert-toplevel + (= (cdr magit-auto-revert-toplevel) + magit-auto-revert-counter)) + (setq magit-auto-revert-toplevel + (cons (or (magit-toplevel) 'no-repo) + magit-auto-revert-counter))) + (let ((top (car magit-auto-revert-toplevel))) + (if (eq top 'no-repo) + fallback + (let ((dir (buffer-local-value 'default-directory buffer))) + (and (equal (file-remote-p dir) + (file-remote-p top)) + ;; ^ `tramp-handle-file-in-directory-p' lacks this optimization. + (file-in-directory-p dir top)))))) + +(defun auto-revert-buffers--buffer-list-filter (fn) + (cl-incf magit-auto-revert-counter) + (if (or global-auto-revert-mode + (not auto-revert-buffer-list) + (not auto-revert-buffer-list-filter)) + (funcall fn) + (let ((auto-revert-buffer-list + (-filter auto-revert-buffer-list-filter + auto-revert-buffer-list))) + (funcall fn)) + (unless auto-revert-timer + (auto-revert-set-timer)))) + +(advice-add 'auto-revert-buffers :around + 'auto-revert-buffers--buffer-list-filter) + +;;; _ +(provide 'magit-autorevert) +;;; magit-autorevert.el ends here diff --git a/elpa/magit-20200318.1224/magit-autorevert.elc b/elpa/magit-20200318.1224/magit-autorevert.elc new file mode 100644 index 00000000..d7c467fd Binary files /dev/null and b/elpa/magit-20200318.1224/magit-autorevert.elc differ diff --git a/elpa/magit-20200318.1224/magit-bisect.el b/elpa/magit-20200318.1224/magit-bisect.el new file mode 100644 index 00000000..451914e0 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-bisect.el @@ -0,0 +1,239 @@ +;;; magit-bisect.el --- bisect support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Use a binary search to find the commit that introduced a bug. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-bisect-show-graph t + "Whether to use `--graph' in the log showing commits yet to be bisected." + :package-version '(magit . "2.8.0") + :group 'magit-status + :type 'boolean) + +(defface magit-bisect-good + '((t :foreground "DarkOliveGreen")) + "Face for good bisect revisions." + :group 'magit-faces) + +(defface magit-bisect-skip + '((t :foreground "DarkGoldenrod")) + "Face for skipped bisect revisions." + :group 'magit-faces) + +(defface magit-bisect-bad + '((t :foreground "IndianRed4")) + "Face for bad bisect revisions." + :group 'magit-faces) + +;;; Commands + +;;;###autoload (autoload 'magit-bisect "magit-bisect" nil t) +(define-transient-command magit-bisect () + "Narrow in on the commit that introduced a bug." + :man-page "git-bisect" + ["Actions" + :if-not magit-bisect-in-progress-p + ("B" "Start" magit-bisect-start) + ("s" "Start script" magit-bisect-run)] + ["Actions" + :if magit-bisect-in-progress-p + ("B" "Bad" magit-bisect-bad) + ("g" "Good" magit-bisect-good) + ("k" "Skip" magit-bisect-skip) + ("r" "Reset" magit-bisect-reset) + ("s" "Run script" magit-bisect-run)]) + +;;;###autoload +(defun magit-bisect-start (bad good) + "Start a bisect session. + +Bisecting a bug means to find the commit that introduced it. +This command starts such a bisect session by asking for a know +good and a bad commit. To move the session forward use the +other actions from the bisect transient command (\ +\\\\[magit-bisect])." + (interactive (if (magit-bisect-in-progress-p) + (user-error "Already bisecting") + (magit-bisect-start-read-args))) + (unless (magit-rev-ancestor-p good bad) + (user-error + "The good revision (%s) has to be an ancestor of the bad one (%s)" + good bad)) + (when (magit-anything-modified-p) + (user-error "Cannot bisect with uncommitted changes")) + (magit-git-bisect "start" (list bad good) t)) + +(defun magit-bisect-start-read-args () + (let ((b (magit-read-branch-or-commit "Start bisect with bad revision"))) + (list b (magit-read-other-branch-or-commit "Good revision" b)))) + +;;;###autoload +(defun magit-bisect-reset () + "After bisecting, cleanup bisection state and return to original `HEAD'." + (interactive) + (magit-confirm 'reset-bisect) + (magit-run-git "bisect" "reset") + (ignore-errors (delete-file (magit-git-dir "BISECT_CMD_OUTPUT")))) + +;;;###autoload +(defun magit-bisect-good () + "While bisecting, mark the current commit as good. +Use this after you have asserted that the commit does not contain +the bug in question." + (interactive) + (magit-git-bisect "good")) + +;;;###autoload +(defun magit-bisect-bad () + "While bisecting, mark the current commit as bad. +Use this after you have asserted that the commit does contain the +bug in question." + (interactive) + (magit-git-bisect "bad")) + +;;;###autoload +(defun magit-bisect-skip () + "While bisecting, skip the current commit. +Use this if for some reason the current commit is not a good one +to test. This command lets Git choose a different one." + (interactive) + (magit-git-bisect "skip")) + +;;;###autoload +(defun magit-bisect-run (cmdline &optional bad good) + "Bisect automatically by running commands after each step. + +Unlike `git bisect run' this can be used before bisecting has +begun. In that case it behaves like `git bisect start; git +bisect run'." + (interactive (let ((args (and (not (magit-bisect-in-progress-p)) + (magit-bisect-start-read-args)))) + (cons (read-shell-command "Bisect shell command: ") args))) + (when (and bad good) + (magit-bisect-start bad good)) + (magit-git-bisect "run" (list shell-file-name shell-command-switch cmdline))) + +(defun magit-git-bisect (subcommand &optional args no-assert) + (unless (or no-assert (magit-bisect-in-progress-p)) + (user-error "Not bisecting")) + (message "Bisecting...") + (magit-with-toplevel + (magit-run-git-async "bisect" subcommand args)) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (when-let ((section (get-text-property (point) 'magit-section)) + (output (buffer-substring-no-properties + (oref section content) + (oref section end)))) + (with-temp-file (magit-git-dir "BISECT_CMD_OUTPUT") + (insert output))))) + (magit-refresh)) + (message "Bisecting...done"))))) + +;;; Sections + +(defun magit-bisect-in-progress-p () + (file-exists-p (magit-git-dir "BISECT_LOG"))) + +(defun magit-insert-bisect-output () + "While bisecting, insert section with output from `git bisect'." + (when (magit-bisect-in-progress-p) + (let* ((lines + (or (magit-file-lines (magit-git-dir "BISECT_CMD_OUTPUT")) + (list "Bisecting: (no saved bisect output)" + "It appears you have invoked `git bisect' from a shell." + "There is nothing wrong with that, we just cannot display" + "anything useful here. Consult the shell output instead."))) + (done-re "^\\([a-z0-9]\\{40\\}\\) is the first bad commit$") + (bad-line (or (and (string-match done-re (car lines)) + (pop lines)) + (--first (string-match done-re it) lines)))) + (magit-insert-section ((eval (if bad-line 'commit 'bisect-output)) + (and bad-line (match-string 1 bad-line))) + (magit-insert-heading + (propertize (or bad-line (pop lines)) + 'font-lock-face 'magit-section-heading)) + (dolist (line lines) + (insert line "\n")))) + (insert "\n"))) + +(defun magit-insert-bisect-rest () + "While bisecting, insert section visualizing the bisect state." + (when (magit-bisect-in-progress-p) + (magit-insert-section (bisect-view) + (magit-insert-heading "Bisect Rest:") + (magit-git-wash (apply-partially 'magit-log-wash-log 'bisect-vis) + "bisect" "visualize" "git" "log" + "--format=%h%x00%D%x00%s" "--decorate=full" + (and magit-bisect-show-graph "--graph"))))) + +(defun magit-insert-bisect-log () + "While bisecting, insert section logging bisect progress." + (when (magit-bisect-in-progress-p) + (magit-insert-section (bisect-log) + (magit-insert-heading "Bisect Log:") + (magit-git-wash #'magit-wash-bisect-log "bisect" "log") + (insert ?\n)))) + +(defun magit-wash-bisect-log (_args) + (let (beg) + (while (progn (setq beg (point-marker)) + (re-search-forward "^\\(git bisect [^\n]+\n\\)" nil t)) + (magit-bind-match-strings (heading) nil + (magit-delete-match) + (save-restriction + (narrow-to-region beg (point)) + (goto-char (point-min)) + (magit-insert-section (bisect-item heading t) + (insert (propertize heading 'font-lock-face + 'magit-section-secondary-heading)) + (magit-insert-heading) + (magit-wash-sequence + (apply-partially 'magit-log-wash-rev 'bisect-log + (magit-abbrev-length))) + (insert ?\n))))) + (when (re-search-forward + "# first bad commit: \\[\\([a-z0-9]\\{40\\}\\)\\] [^\n]+\n" nil t) + (magit-bind-match-strings (hash) nil + (magit-delete-match) + (magit-insert-section (bisect-item) + (insert hash " is the first bad commit\n")))))) + +;;; _ +(provide 'magit-bisect) +;;; magit-bisect.el ends here diff --git a/elpa/magit-20200318.1224/magit-bisect.elc b/elpa/magit-20200318.1224/magit-bisect.elc new file mode 100644 index 00000000..cd55c53a Binary files /dev/null and b/elpa/magit-20200318.1224/magit-bisect.elc differ diff --git a/elpa/magit-20200318.1224/magit-blame.el b/elpa/magit-20200318.1224/magit-blame.el new file mode 100644 index 00000000..50657034 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-blame.el @@ -0,0 +1,943 @@ +;;; magit-blame.el --- blame support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Annotates each line in file-visiting buffer with information from +;; the revision which last modified the line. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Options + +(defgroup magit-blame nil + "Blame support for Magit." + :link '(info-link "(magit)Blaming") + :group 'magit-modes) + +(defcustom magit-blame-styles + '((headings + (heading-format . "%-20a %C %s\n")) + (margin + (margin-format . (" %s%f" " %C %a" " %H")) + (margin-width . 42) + (margin-face . magit-blame-margin) + (margin-body-face . (magit-blame-dimmed))) + (highlight + (highlight-face . magit-blame-highlight)) + (lines + (show-lines . t) + (show-message . t))) + "List of styles used to visualize blame information. + +Each entry has the form (IDENT (KEY . VALUE)...). IDENT has +to be a symbol uniquely identifing the style. The following +KEYs are recognized: + + `show-lines' + Whether to prefix each chunk of lines with a thin line. + This has no effect if `heading-format' is non-nil. + `show-message' + Whether to display a commit's summary line in the echo area + when crossing chunks. + `highlight-face' + Face used to highlight the first line of each chunk. + If this is nil, then those lines are not highlighted. + `heading-format' + String specifying the information to be shown above each + chunk of lines. It must end with a newline character. + `margin-format' + String specifying the information to be shown in the left + buffer margin. It must NOT end with a newline character. + This can also be a list of formats used for the lines at + the same positions within the chunk. If the chunk has + more lines than formats are specified, then the last is + repeated. + `margin-width' + Width of the margin, provided `margin-format' is non-nil. + `margin-face' + Face used in the margin, provided `margin-format' is + non-nil. This face is used in combination with the faces + that are specific to the used %-specs. If this is nil, + then `magit-blame-margin' is used. + `margin-body-face' + Face used in the margin for all but first line of a chunk. + This face is used in combination with the faces that are + specific to the used %-specs. This can also be a list of + faces (usually one face), in which case only these faces + are used and the %-spec faces are ignored. A good value + might be `(magit-blame-dimmed)'. If this is nil, then + the same face as for the first line is used. + +The following %-specs can be used in `heading-format' and +`margin-format': + + %H hash using face `magit-blame-hash' + %s summary using face `magit-blame-summary' + %a author using face `magit-blame-name' + %A author time using face `magit-blame-date' + %c committer using face `magit-blame-name' + %C committer time using face `magit-blame-date' + +Additionally if `margin-format' ends with %f, then the string +that is displayed in the margin is made at least `margin-width' +characters wide, which may be desirable if the used face sets +the background color. + +The style used in the current buffer can be cycled from the blame +popup. Blame commands (except `magit-blame-echo') use the first +style as the initial style when beginning to blame in a buffer." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'string) + +(defcustom magit-blame-echo-style 'lines + "The blame visualization style used by `magit-blame-echo'. +A symbol that has to be used as the identifier for one of the +styles defined in `magit-blame-styles'." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'symbol) + +(defcustom magit-blame-time-format "%F %H:%M" + "Format for time strings in blame headings." + :group 'magit-blame + :type 'string) + +(defcustom magit-blame-read-only t + "Whether to initially make the blamed buffer read-only." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'boolean) + +(defcustom magit-blame-disable-modes '(fci-mode yascroll-bar-mode) + "List of modes not compatible with Magit-Blame mode. +This modes are turned off when Magit-Blame mode is turned on, +and then turned on again when turning off the latter." + :group 'magit-blame + :type '(repeat (symbol :tag "Mode"))) + +(defcustom magit-blame-mode-lighter " Blame" + "The mode-line lighter of the Magit-Blame mode." + :group 'magit-blame + :type '(choice (const :tag "No lighter" "") string)) + +(defcustom magit-blame-goto-chunk-hook + '(magit-blame-maybe-update-revision-buffer + magit-blame-maybe-show-message) + "Hook run after point entered another chunk." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'hook + :get 'magit-hook-custom-get + :options '(magit-blame-maybe-update-revision-buffer + magit-blame-maybe-show-message)) + +;;; Faces + +(defface magit-blame-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey80" + :foreground "black") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey25" + :foreground "white")) + "Face used for highlighting when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-margin + '((t :inherit magit-blame-highlight + :weight normal + :slant normal)) + "Face used for the blame margin by default when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-dimmed + '((t :inherit magit-dimmed + :weight normal + :slant normal)) + "Face used for the blame margin in some cases when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-heading + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-blame-highlight + :weight normal + :slant normal)) + "Face used for blame headings by default when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-summary nil + "Face used for commit summaries when blaming." + :group 'magit-faces) + +(defface magit-blame-hash nil + "Face used for commit hashes when blaming." + :group 'magit-faces) + +(defface magit-blame-name nil + "Face used for author and committer names when blaming." + :group 'magit-faces) + +(defface magit-blame-date nil + "Face used for dates when blaming." + :group 'magit-faces) + +;;; Chunks + +(defclass magit-blame-chunk () + (;; + (orig-rev :initarg :orig-rev) + (orig-line :initarg :orig-line) + (final-line :initarg :final-line) + (num-lines :initarg :num-lines) + ;; previous + (prev-rev :initform nil) + (prev-file :initform nil) + ;; filename + (orig-file))) + +(defun magit-current-blame-chunk (&optional type) + (or (and (not (and type (not (eq type magit-blame-type)))) + (magit-blame-chunk-at (point))) + (and type + (let ((rev (or magit-buffer-refname magit-buffer-revision)) + (file (magit-file-relative-name nil (not magit-buffer-file-name))) + (line (format "%i,+1" (line-number-at-pos)))) + (unless file + (error "Buffer does not visit a tracked file")) + (with-temp-buffer + (magit-with-toplevel + (magit-git-insert + "blame" "--porcelain" + (if (memq magit-blame-type '(final removal)) + (cons "--reverse" (magit-blame-arguments)) + (magit-blame-arguments)) + "-L" line rev "--" file) + (goto-char (point-min)) + (car (magit-blame--parse-chunk type)))))))) + +(defun magit-blame-chunk-at (pos) + (--some (overlay-get it 'magit-blame-chunk) + (overlays-at pos))) + +(defun magit-blame--overlay-at (&optional pos key) + (unless pos + (setq pos (point))) + (--first (overlay-get it (or key 'magit-blame-chunk)) + (nconc (overlays-at pos) + (overlays-in pos pos)))) + +;;; Keymaps + +(defvar magit-blame-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-q") 'magit-blame-quit) + map) + "Keymap for `magit-blame-mode'. +Note that most blaming key bindings are defined +in `magit-blame-read-only-mode-map' instead.") + +(defvar magit-blame-read-only-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-m") 'magit-show-commit) + (define-key map (kbd "p") 'magit-blame-previous-chunk) + (define-key map (kbd "P") 'magit-blame-previous-chunk-same-commit) + (define-key map (kbd "n") 'magit-blame-next-chunk) + (define-key map (kbd "N") 'magit-blame-next-chunk-same-commit) + (define-key map (kbd "b") 'magit-blame-addition) + (define-key map (kbd "r") 'magit-blame-removal) + (define-key map (kbd "f") 'magit-blame-reverse) + (define-key map (kbd "B") 'magit-blame) + (define-key map (kbd "c") 'magit-blame-cycle-style) + (define-key map (kbd "q") 'magit-blame-quit) + (define-key map (kbd "M-w") 'magit-blame-copy-hash) + (define-key map (kbd "SPC") 'magit-diff-show-or-scroll-up) + (define-key map (kbd "DEL") 'magit-diff-show-or-scroll-down) + map) + "Keymap for `magit-blame-read-only-mode'.") + +;;; Modes +;;;; Variables + +(defvar-local magit-blame-buffer-read-only nil) +(defvar-local magit-blame-cache nil) +(defvar-local magit-blame-disabled-modes nil) +(defvar-local magit-blame-process nil) +(defvar-local magit-blame-recursive-p nil) +(defvar-local magit-blame-type nil) +(defvar-local magit-blame-separator nil) +(defvar-local magit-blame-previous-chunk nil) + +(defvar-local magit-blame--style nil) + +(defsubst magit-blame--style-get (key) + (cdr (assoc key (cdr magit-blame--style)))) + +;;;; Base Mode + +(define-minor-mode magit-blame-mode + "Display blame information inline." + :lighter magit-blame-mode-lighter + (cond (magit-blame-mode + (when (called-interactively-p 'any) + (setq magit-blame-mode nil) + (user-error + (concat "Don't call `magit-blame-mode' directly; " + "instead use `magit-blame'"))) + (add-hook 'after-save-hook 'magit-blame--refresh t t) + (add-hook 'post-command-hook 'magit-blame-goto-chunk-hook t t) + (add-hook 'before-revert-hook 'magit-blame--remove-overlays t t) + (add-hook 'after-revert-hook 'magit-blame--refresh t t) + (add-hook 'read-only-mode-hook 'magit-blame-toggle-read-only t t) + (setq magit-blame-buffer-read-only buffer-read-only) + (when (or magit-blame-read-only magit-buffer-file-name) + (read-only-mode 1)) + (dolist (mode magit-blame-disable-modes) + (when (and (boundp mode) (symbol-value mode)) + (funcall mode -1) + (push mode magit-blame-disabled-modes))) + (setq magit-blame-separator (magit-blame--format-separator)) + (unless magit-blame--style + (setq magit-blame--style (car magit-blame-styles))) + (magit-blame--update-margin)) + (t + (when (process-live-p magit-blame-process) + (kill-process magit-blame-process) + (while magit-blame-process + (sit-for 0.01))) ; avoid racing the sentinel + (remove-hook 'after-save-hook 'magit-blame--refresh t) + (remove-hook 'post-command-hook 'magit-blame-goto-chunk-hook t) + (remove-hook 'before-revert-hook 'magit-blame--remove-overlays t) + (remove-hook 'after-revert-hook 'magit-blame--refresh t) + (remove-hook 'read-only-mode-hook 'magit-blame-toggle-read-only t) + (unless magit-blame-buffer-read-only + (read-only-mode -1)) + (magit-blame-read-only-mode -1) + (dolist (mode magit-blame-disabled-modes) + (funcall mode 1)) + (kill-local-variable 'magit-blame-disabled-modes) + (kill-local-variable 'magit-blame-type) + (kill-local-variable 'magit-blame--style) + (magit-blame--update-margin) + (magit-blame--remove-overlays)))) + +(defun magit-blame--refresh () + (magit-blame--run (magit-blame-arguments))) + +(defun magit-blame-goto-chunk-hook () + (let ((chunk (magit-blame-chunk-at (point)))) + (when (cl-typep chunk 'magit-blame-chunk) + (unless (eq chunk magit-blame-previous-chunk) + (run-hooks 'magit-blame-goto-chunk-hook)) + (setq magit-blame-previous-chunk chunk)))) + +(defun magit-blame-toggle-read-only () + (magit-blame-read-only-mode (if buffer-read-only 1 -1))) + +;;;; Read-Only Mode + +(define-minor-mode magit-blame-read-only-mode + "Provide keybindings for Magit-Blame mode. + +This minor-mode provides the key bindings for Magit-Blame mode, +but only when Read-Only mode is also enabled because these key +bindings would otherwise conflict badly with regular bindings. + +When both Magit-Blame mode and Read-Only mode are enabled, then +this mode gets automatically enabled too and when one of these +modes is toggled, then this mode also gets toggled automatically. + +\\{magit-blame-read-only-mode-map}") + +;;;; Kludges + +(defun magit-blame-put-keymap-before-view-mode () + "Put `magit-blame-read-only-mode' ahead of `view-mode' in `minor-mode-map-alist'." + (--when-let (assq 'magit-blame-read-only-mode + (cl-member 'view-mode minor-mode-map-alist :key #'car)) + (setq minor-mode-map-alist + (cons it (delq it minor-mode-map-alist)))) + (remove-hook 'view-mode-hook #'magit-blame-put-keymap-before-view-mode)) + +(add-hook 'view-mode-hook #'magit-blame-put-keymap-before-view-mode) + +;;; Process + +(defun magit-blame--run (args) + (magit-with-toplevel + (unless magit-blame-mode + (magit-blame-mode 1)) + (message "Blaming...") + (magit-blame-run-process + (or magit-buffer-refname magit-buffer-revision) + (magit-file-relative-name nil (not magit-buffer-file-name)) + (if (memq magit-blame-type '(final removal)) + (cons "--reverse" args) + args) + (list (line-number-at-pos (window-start)) + (line-number-at-pos (1- (window-end nil t))))) + (set-process-sentinel magit-this-process + 'magit-blame-process-quickstart-sentinel))) + +(defun magit-blame-run-process (revision file args &optional lines) + (let ((process (magit-parse-git-async + "blame" "--incremental" args + (and lines (list "-L" (apply #'format "%s,%s" lines))) + revision "--" file))) + (set-process-filter process 'magit-blame-process-filter) + (set-process-sentinel process 'magit-blame-process-sentinel) + (process-put process 'arguments (list revision file args)) + (setq magit-blame-cache (make-hash-table :test 'equal)) + (setq magit-blame-process process))) + +(defun magit-blame-process-quickstart-sentinel (process event) + (when (memq (process-status process) '(exit signal)) + (magit-blame-process-sentinel process event t) + (magit-blame-assert-buffer process) + (with-current-buffer (process-get process 'command-buf) + (when magit-blame-mode + (let ((default-directory (magit-toplevel))) + (apply #'magit-blame-run-process + (process-get process 'arguments))))))) + +(defun magit-blame-process-sentinel (process _event &optional quiet) + (let ((status (process-status process))) + (when (memq status '(exit signal)) + (kill-buffer (process-buffer process)) + (if (and (eq status 'exit) + (zerop (process-exit-status process))) + (unless quiet + (message "Blaming...done")) + (magit-blame-assert-buffer process) + (with-current-buffer (process-get process 'command-buf) + (if magit-blame-mode + (progn (magit-blame-mode -1) + (message "Blaming...failed")) + (message "Blaming...aborted")))) + (kill-local-variable 'magit-blame-process)))) + +(defun magit-blame-process-filter (process string) + (internal-default-process-filter process string) + (let ((buf (process-get process 'command-buf)) + (pos (process-get process 'parsed)) + (mark (process-mark process)) + type cache) + (with-current-buffer buf + (setq type magit-blame-type) + (setq cache magit-blame-cache)) + (with-current-buffer (process-buffer process) + (goto-char pos) + (while (and (< (point) mark) + (save-excursion (re-search-forward "^filename .+\n" nil t))) + (pcase-let* ((`(,chunk ,revinfo) + (magit-blame--parse-chunk type)) + (rev (oref chunk orig-rev))) + (if revinfo + (puthash rev revinfo cache) + (setq revinfo + (or (gethash rev cache) + (puthash rev (magit-blame--commit-alist rev) cache)))) + (magit-blame--make-overlays buf chunk revinfo)) + (process-put process 'parsed (point)))))) + +(defun magit-blame--parse-chunk (type) + (let (chunk revinfo) + (looking-at "^\\(.\\{40\\}\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\)") + (with-slots (orig-rev orig-file prev-rev prev-file) + (setq chunk (magit-blame-chunk + :orig-rev (match-string 1) + :orig-line (string-to-number (match-string 2)) + :final-line (string-to-number (match-string 3)) + :num-lines (string-to-number (match-string 4)))) + (forward-line) + (let (done) + (while (not done) + (cond ((looking-at "^filename \\(.+\\)") + (setq done t) + (setf orig-file (match-string 1))) + ((looking-at "^previous \\(.\\{40\\}\\) \\(.+\\)") + (setf prev-rev (match-string 1)) + (setf prev-file (match-string 2))) + ((looking-at "^\\([^ ]+\\) \\(.+\\)") + (push (cons (match-string 1) + (match-string 2)) revinfo))) + (forward-line))) + (when (and (eq type 'removal) prev-rev) + (cl-rotatef orig-rev prev-rev) + (cl-rotatef orig-file prev-file) + (setq revinfo nil))) + (list chunk revinfo))) + +(defun magit-blame--commit-alist (rev) + (cl-mapcar 'cons + '("summary" + "author" "author-time" "author-tz" + "committer" "committer-time" "committer-tz") + (split-string (magit-rev-format "%s\v%an\v%ad\v%cn\v%cd" rev + "--date=format:%s\v%z") + "\v"))) + +(defun magit-blame-assert-buffer (process) + (unless (buffer-live-p (process-get process 'command-buf)) + (kill-process process) + (user-error "Buffer being blamed has been killed"))) + +;;; Display + +(defun magit-blame--make-overlays (buf chunk revinfo) + (with-current-buffer buf + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- (oref chunk final-line))) + (let ((beg (point)) + (end (save-excursion + (forward-line (oref chunk num-lines)) + (point)))) + (magit-blame--remove-overlays beg end) + (magit-blame--make-margin-overlays chunk revinfo beg end) + (magit-blame--make-heading-overlay chunk revinfo beg end) + (magit-blame--make-highlight-overlay chunk beg)))))) + +(defun magit-blame--make-margin-overlays (chunk revinfo _beg end) + (save-excursion + (let ((line 0)) + (while (< (point) end) + (magit-blame--make-margin-overlay chunk revinfo line) + (forward-line) + (cl-incf line))))) + +(defun magit-blame--make-margin-overlay (chunk revinfo line) + (let* ((end (line-end-position)) + ;; If possible avoid putting this on the first character + ;; of the line to avoid a conflict with the line overlay. + (beg (min (1+ (line-beginning-position)) end)) + (ov (make-overlay beg end))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-revinfo revinfo) + (overlay-put ov 'magit-blame-margin line) + (magit-blame--update-margin-overlay ov))) + +(defun magit-blame--make-heading-overlay (chunk revinfo beg end) + (let ((ov (make-overlay beg end))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-revinfo revinfo) + (overlay-put ov 'magit-blame-heading t) + (magit-blame--update-heading-overlay ov))) + +(defun magit-blame--make-highlight-overlay (chunk beg) + (let ((ov (make-overlay beg (1+ (line-end-position))))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-highlight t) + (magit-blame--update-highlight-overlay ov))) + +(defun magit-blame--update-margin () + (setq left-margin-width (or (magit-blame--style-get 'margin-width) 0)) + (set-window-buffer (selected-window) (current-buffer))) + +(defun magit-blame--update-overlays () + (save-restriction + (widen) + (dolist (ov (overlays-in (point-min) (point-max))) + (cond ((overlay-get ov 'magit-blame-heading) + (magit-blame--update-heading-overlay ov)) + ((overlay-get ov 'magit-blame-margin) + (magit-blame--update-margin-overlay ov)) + ((overlay-get ov 'magit-blame-highlight) + (magit-blame--update-highlight-overlay ov)))))) + +(defun magit-blame--update-margin-overlay (ov) + (overlay-put + ov 'before-string + (and (magit-blame--style-get 'margin-width) + (propertize + "o" 'display + (list (list 'margin 'left-margin) + (let ((line (overlay-get ov 'magit-blame-margin)) + (format (magit-blame--style-get 'margin-format)) + (face (magit-blame--style-get 'margin-face))) + (magit-blame--format-string + ov + (or (and (atom format) + format) + (nth line format) + (car (last format))) + (or (and (not (zerop line)) + (magit-blame--style-get 'margin-body-face)) + face + 'magit-blame-margin)))))))) + +(defun magit-blame--update-heading-overlay (ov) + (overlay-put + ov 'before-string + (--if-let (magit-blame--style-get 'heading-format) + (magit-blame--format-string ov it 'magit-blame-heading) + (and (magit-blame--style-get 'show-lines) + (or (not (magit-blame--style-get 'margin-format)) + (save-excursion + (goto-char (overlay-start ov)) + ;; Special case of the special case described in + ;; `magit-blame--make-margin-overlay'. For empty + ;; lines it is not possible to show both overlays + ;; without the line being to high. + (not (= (point) (line-end-position))))) + magit-blame-separator)))) + +(defun magit-blame--update-highlight-overlay (ov) + (overlay-put ov 'font-lock-face (magit-blame--style-get 'highlight-face))) + +(defun magit-blame--format-string (ov format face) + (let* ((chunk (overlay-get ov 'magit-blame-chunk)) + (revinfo (overlay-get ov 'magit-blame-revinfo)) + (key (list format face)) + (string (cdr (assoc key revinfo)))) + (unless string + (setq string + (and format + (magit-blame--format-string-1 (oref chunk orig-rev) + revinfo format face))) + (nconc revinfo (list (cons key string)))) + string)) + +(defun magit-blame--format-string-1 (rev revinfo format face) + (let ((str + (if (equal rev "0000000000000000000000000000000000000000") + (propertize (concat (if (string-prefix-p "\s" format) "\s" "") + "Not Yet Committed" + (if (string-suffix-p "\n" format) "\n" "")) + 'font-lock-face face) + (magit--format-spec + (propertize format 'font-lock-face face) + (cl-flet* ((p0 (s f) + (propertize s 'font-lock-face + (if face + (if (listp face) + face + (list f face)) + f))) + (p1 (k f) + (p0 (cdr (assoc k revinfo)) f)) + (p2 (k1 k2 f) + (p0 (magit-blame--format-time-string + (cdr (assoc k1 revinfo)) + (cdr (assoc k2 revinfo))) + f))) + `((?H . ,(p0 rev 'magit-blame-hash)) + (?s . ,(p1 "summary" 'magit-blame-summary)) + (?a . ,(p1 "author" 'magit-blame-name)) + (?c . ,(p1 "committer" 'magit-blame-name)) + (?A . ,(p2 "author-time" "author-tz" 'magit-blame-date)) + (?C . ,(p2 "committer-time" "committer-tz" 'magit-blame-date)) + (?f . ""))))))) + (if-let ((width (and (string-suffix-p "%f" format) + (magit-blame--style-get 'margin-width)))) + (concat str + (propertize (make-string (max 0 (- width (length str))) ?\s) + 'font-lock-face face)) + str))) + +(defun magit-blame--format-separator () + (propertize + (concat (propertize "\s" 'display '(space :height (2))) + (propertize "\n" 'line-height t)) + 'font-lock-face (list :background + (face-attribute 'magit-blame-heading + :background nil t)))) + +(defun magit-blame--format-time-string (time tz) + (let* ((time-format (or (magit-blame--style-get 'time-format) + magit-blame-time-format)) + (tz-in-second (and (string-match "%z" time-format) + (car (last (parse-time-string tz)))))) + (format-time-string time-format + (seconds-to-time (string-to-number time)) + tz-in-second))) + +(defun magit-blame--remove-overlays (&optional beg end) + (save-restriction + (widen) + (dolist (ov (overlays-in (or beg (point-min)) + (or end (point-max)))) + (when (overlay-get ov 'magit-blame-chunk) + (delete-overlay ov))))) + +(defun magit-blame-maybe-show-message () + (when (magit-blame--style-get 'show-message) + (let ((message-log-max 0)) + (if-let ((msg (cdr (assoc "summary" + (gethash (oref (magit-current-blame-chunk) + orig-rev) + magit-blame-cache))))) + (progn (set-text-properties 0 (length msg) nil msg) + (message msg)) + (message "Commit data not available yet. Still blaming."))))) + +;;; Commands + +;;;###autoload (autoload 'magit-blame-echo "magit-blame" nil t) +(define-suffix-command magit-blame-echo (args) + "For each line show the revision in which it was added. +Show the information about the chunk at point in the echo area +when moving between chunks. Unlike other blaming commands, do +not turn on `read-only-mode'." + :if (lambda () + (and buffer-file-name + (or (not magit-blame-mode) + buffer-read-only))) + (interactive (list (magit-blame-arguments))) + (when magit-buffer-file-name + (user-error "Blob buffers aren't supported")) + (setq-local magit-blame--style + (assq magit-blame-echo-style magit-blame-styles)) + (setq-local magit-blame-disable-modes + (cons 'eldoc-mode magit-blame-disable-modes)) + (if (not magit-blame-mode) + (let ((magit-blame-read-only nil)) + (magit-blame--pre-blame-assert 'addition) + (magit-blame--pre-blame-setup 'addition) + (magit-blame--run args)) + (read-only-mode -1) + (magit-blame--update-overlays))) + +;;;###autoload (autoload 'magit-blame-addition "magit-blame" nil t) +(define-suffix-command magit-blame-addition (args) + "For each line show the revision in which it was added." + (interactive (list (magit-blame-arguments))) + (magit-blame--pre-blame-assert 'addition) + (magit-blame--pre-blame-setup 'addition) + (magit-blame--run args)) + +;;;###autoload (autoload 'magit-blame-removal "magit-blame" nil t) +(define-suffix-command magit-blame-removal (args) + "For each line show the revision in which it was removed." + :if-nil 'buffer-file-name + (interactive (list (magit-blame-arguments))) + (unless magit-buffer-file-name + (user-error "Only blob buffers can be blamed in reverse")) + (magit-blame--pre-blame-assert 'removal) + (magit-blame--pre-blame-setup 'removal) + (magit-blame--run args)) + +;;;###autoload (autoload 'magit-blame-reverse "magit-blame" nil t) +(define-suffix-command magit-blame-reverse (args) + "For each line show the last revision in which it still exists." + :if-nil 'buffer-file-name + (interactive (list (magit-blame-arguments))) + (unless magit-buffer-file-name + (user-error "Only blob buffers can be blamed in reverse")) + (magit-blame--pre-blame-assert 'final) + (magit-blame--pre-blame-setup 'final) + (magit-blame--run args)) + +(defun magit-blame--pre-blame-assert (type) + (unless (magit-toplevel) + (magit--not-inside-repository-error)) + (if (and magit-blame-mode + (eq type magit-blame-type)) + (if-let ((chunk (magit-current-blame-chunk))) + (unless (oref chunk prev-rev) + (user-error "Chunk has no further history")) + (user-error "Commit data not available yet. Still blaming.")) + (unless (magit-file-relative-name nil (not magit-buffer-file-name)) + (if buffer-file-name + (user-error "Buffer isn't visiting a tracked file") + (user-error "Buffer isn't visiting a file"))))) + +(defun magit-blame--pre-blame-setup (type) + (when magit-blame-mode + (if (eq type magit-blame-type) + (let ((style magit-blame--style)) + (magit-blame-visit-other-file) + (setq-local magit-blame--style style) + (setq-local magit-blame-recursive-p t) + ;; Set window-start for the benefit of quickstart. + (redisplay)) + (magit-blame--remove-overlays))) + (setq magit-blame-type type)) + +(defun magit-blame-visit-other-file () + "Visit another blob related to the current chunk." + (interactive) + (with-slots (prev-rev prev-file orig-line) + (magit-current-blame-chunk) + (unless prev-rev + (user-error "Chunk has no further history")) + (magit-with-toplevel + (magit-find-file prev-rev prev-file)) + ;; TODO Adjust line like magit-diff-visit-file. + (goto-char (point-min)) + (forward-line (1- orig-line)))) + +(defun magit-blame-visit-file () + "Visit the blob related to the current chunk." + (interactive) + (with-slots (orig-rev orig-file orig-line) + (magit-current-blame-chunk) + (magit-with-toplevel + (magit-find-file orig-rev orig-file)) + (goto-char (point-min)) + (forward-line (1- orig-line)))) + +(define-suffix-command magit-blame-quit () + "Turn off Magit-Blame mode. +If the buffer was created during a recursive blame, +then also kill the buffer." + :if-non-nil 'magit-blame-mode + (interactive) + (magit-blame-mode -1) + (when magit-blame-recursive-p + (kill-buffer))) + +(defun magit-blame-next-chunk () + "Move to the next chunk." + (interactive) + (--if-let (next-single-char-property-change (point) 'magit-blame-chunk) + (goto-char it) + (user-error "No more chunks"))) + +(defun magit-blame-previous-chunk () + "Move to the previous chunk." + (interactive) + (--if-let (previous-single-char-property-change (point) 'magit-blame-chunk) + (goto-char it) + (user-error "No more chunks"))) + +(defun magit-blame-next-chunk-same-commit (&optional previous) + "Move to the next chunk from the same commit.\n\n(fn)" + (interactive) + (if-let ((rev (oref (magit-current-blame-chunk) orig-rev))) + (let ((pos (point)) ov) + (save-excursion + (while (and (not ov) + (not (= pos (if previous (point-min) (point-max)))) + (setq pos (funcall + (if previous + 'previous-single-char-property-change + 'next-single-char-property-change) + pos 'magit-blame-chunk))) + (--when-let (magit-blame--overlay-at pos) + (when (equal (oref (magit-blame-chunk-at pos) orig-rev) rev) + (setq ov it))))) + (if ov + (goto-char (overlay-start ov)) + (user-error "No more chunks from same commit"))) + (user-error "This chunk hasn't been blamed yet"))) + +(defun magit-blame-previous-chunk-same-commit () + "Move to the previous chunk from the same commit." + (interactive) + (magit-blame-next-chunk-same-commit 'previous-single-char-property-change)) + +(defun magit-blame-cycle-style () + "Change how blame information is visualized. +Cycle through the elements of option `magit-blame-styles'." + (interactive) + (setq magit-blame--style + (or (cadr (cl-member (car magit-blame--style) + magit-blame-styles :key #'car)) + (car magit-blame-styles))) + (magit-blame--update-margin) + (magit-blame--update-overlays)) + +(defun magit-blame-copy-hash () + "Save hash of the current chunk's commit to the kill ring. + +When the region is active, then save the region's content +instead of the hash, like `kill-ring-save' would." + (interactive) + (if (use-region-p) + (call-interactively #'copy-region-as-kill) + (kill-new (message "%s" (oref (magit-current-blame-chunk) orig-rev))))) + +;;; Popup + +;;;###autoload (autoload 'magit-blame "magit-blame" nil t) +(define-transient-command magit-blame () + "Show the commits that added or removed lines in the visited file." + :man-page "git-blame" + :value '("-w") + ["Arguments" + ("-w" "Ignore whitespace" "-w") + ("-r" "Do not treat root commits as boundaries" "--root") + (magit-blame:-M) + (magit-blame:-C)] + ["Actions" + ("b" "Show commits adding lines" magit-blame-addition) + ("r" "Show commits removing lines" magit-blame-removal) + ("f" "Show last commits that still have lines" magit-blame-reverse) + ("m" "Blame echo" magit-blame-echo) + ("q" "Quit blaming" magit-blame-quit)] + ["Refresh" + :if-non-nil magit-blame-mode + ("c" "Cycle style" magit-blame-cycle-style)]) + +(defun magit-blame-arguments () + (transient-args 'magit-blame)) + +(define-infix-argument magit-blame:-M () + :description "Detect lines moved or copied within a file" + :class 'transient-option + :argument "-M" + :reader 'transient-read-number-N+) + +(define-infix-argument magit-blame:-C () + :description "Detect lines moved or copied between files" + :class 'transient-option + :argument "-C" + :reader 'transient-read-number-N+) + +;;; Utilities + +(defun magit-blame-maybe-update-revision-buffer () + (when-let ((chunk (magit-current-blame-chunk)) + (commit (oref chunk orig-rev)) + (buffer (magit-get-mode-buffer 'magit-revision-mode nil t))) + (if magit--update-revision-buffer + (setq magit--update-revision-buffer (list commit buffer)) + (setq magit--update-revision-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-revision-buffer)) + (setq magit--update-revision-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-show-commit rev + (magit-diff-arguments 'magit-revision-mode)))))))))) + +;;; _ +(provide 'magit-blame) +;;; magit-blame.el ends here diff --git a/elpa/magit-20200318.1224/magit-blame.elc b/elpa/magit-20200318.1224/magit-blame.elc new file mode 100644 index 00000000..78b00d59 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-blame.elc differ diff --git a/elpa/magit-20200318.1224/magit-bookmark.el b/elpa/magit-20200318.1224/magit-bookmark.el new file mode 100644 index 00000000..bd6c6838 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-bookmark.el @@ -0,0 +1,203 @@ +;;; magit-bookmark.el --- bookmark support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Inspired by an earlier implementation by Yuri Khan. + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Support for bookmarks for most Magit buffers. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) +(require 'bookmark) + +;;; Core + +(defun magit--make-bookmark () + "Create a bookmark for the current Magit buffer. +Input values are the major-mode's `magit-bookmark-name' method, +and the buffer-local values of the variables referenced in its +`magit-bookmark-variables' property." + (if (plist-member (symbol-plist major-mode) 'magit-bookmark-variables) + (let ((bookmark (bookmark-make-record-default 'no-file))) + (bookmark-prop-set bookmark 'handler 'magit--handle-bookmark) + (bookmark-prop-set bookmark 'mode major-mode) + (bookmark-prop-set bookmark 'filename (magit-toplevel)) + (bookmark-prop-set bookmark 'defaults (list (magit-bookmark-name))) + (dolist (var (get major-mode 'magit-bookmark-variables)) + (bookmark-prop-set bookmark var (symbol-value var))) + (bookmark-prop-set + bookmark 'magit-hidden-sections + (--keep (and (oref it hidden) + (cons (oref it type) + (if (derived-mode-p 'magit-stash-mode) + (replace-regexp-in-string + (regexp-quote magit-buffer-revision) + magit-buffer-revision-hash + (oref it value)) + (oref it value)))) + (oref magit-root-section children))) + bookmark) + (user-error "Bookmarking is not implemented for %s buffers" major-mode))) + +;;;###autoload +(defun magit--handle-bookmark (bookmark) + "Open a bookmark created by `magit--make-bookmark'. +Call the `magit-*-setup-buffer' function of the the major-mode +with the variables' values as arguments, which were recorded by +`magit--make-bookmark'. Ignore `magit-display-buffer-function'." + (let ((buffer (let ((default-directory (bookmark-get-filename bookmark)) + (mode (bookmark-prop-get bookmark 'mode)) + (magit-display-buffer-function #'identity) + (magit-display-buffer-noselect t)) + (apply (intern (format "%s-setup-buffer" + (substring (symbol-name mode) 0 -5))) + (--map (bookmark-prop-get bookmark it) + (get mode 'magit-bookmark-variables)))))) + (set-buffer buffer) ; That is the interface we have to adhere to. + (when-let ((hidden (bookmark-prop-get bookmark 'magit-hidden-sections))) + (with-current-buffer buffer + (dolist (child (oref magit-root-section children)) + (if (member (cons (oref child type) + (oref child value)) + hidden) + (magit-section-hide child) + (magit-section-show child))))) + nil)) + +(cl-defgeneric magit-bookmark-name () + "Return name for bookmark to current buffer." + (format "%s%s" + (substring (symbol-name major-mode) 0 -5) + (if-let ((vars (get major-mode 'magit-bookmark-variables))) + (cl-mapcan (lambda (var) + (let ((val (symbol-value var))) + (if (and val (atom val)) + (list val) + val))) + vars) + ""))) + +;;; Diff +;;;; Diff + +(put 'magit-diff-mode 'magit-bookmark-variables + '(magit-buffer-range-hashed + magit-buffer-typearg + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-diff-mode)) + (format "magit-diff(%s%s)" + (pcase (magit-diff-type) + (`staged "staged") + (`unstaged "unstaged") + (`committed magit-buffer-range) + (`undefined + (delq nil (list magit-buffer-typearg magit-buffer-range-hashed)))) + (if magit-buffer-diff-files + (concat " -- " (mapconcat #'identity magit-buffer-diff-files " ")) + ""))) + +;;;; Revision + +(put 'magit-revision-mode 'magit-bookmark-variables + '(magit-buffer-revision-hash + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-revision-mode)) + (format "magit-revision(%s %s)" + (magit-rev-abbrev magit-buffer-revision) + (if magit-buffer-diff-files + (mapconcat #'identity magit-buffer-diff-files " ") + (magit-rev-format "%s" magit-buffer-revision)))) + +;;;; Stash + +(put 'magit-stash-mode 'magit-bookmark-variables + '(magit-buffer-revision-hash + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-stash-mode)) + (format "magit-stash(%s %s)" + (magit-rev-abbrev magit-buffer-revision) + (if magit-buffer-diff-files + (mapconcat #'identity magit-buffer-diff-files " ") + (magit-rev-format "%s" magit-buffer-revision)))) + +;;; Log +;;;; Log + +(put 'magit-log-mode 'magit-bookmark-variables + '(magit-buffer-revisions + magit-buffer-log-args + magit-buffer-log-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-log-mode)) + (format "magit-log(%s%s)" + (mapconcat #'identity magit-buffer-revisions " ") + (if magit-buffer-log-files + (concat " -- " (mapconcat #'identity magit-buffer-log-files " ")) + ""))) + +;;;; Cherry + +(put 'magit-cherry-mode 'magit-bookmark-variables + '(magit-buffer-refname + magit-buffer-upstream)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-cherry-mode)) + (format "magit-cherry(%s > %s)" + magit-buffer-refname + magit-buffer-upstream)) + +;;;; Reflog + +(put 'magit-reflog-mode 'magit-bookmark-variables + '(magit-buffer-refname)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-reflog-mode)) + (format "magit-reflog(%s)" magit-buffer-refname)) + +;;; Misc + +(put 'magit-status-mode 'magit-bookmark-variables nil) + +(put 'magit-refs-mode 'magit-bookmark-variables + '(magit-buffer-upstream + magit-buffer-arguments)) + +(put 'magit-stashes-mode 'magit-bookmark-variables nil) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-stashes-mode)) + (format "magit-states(%s)" magit-buffer-refname)) + +;;; _ +(provide 'magit-bookmark) +;;; magit-bookmark.el ends here diff --git a/elpa/magit-20200318.1224/magit-bookmark.elc b/elpa/magit-20200318.1224/magit-bookmark.elc new file mode 100644 index 00000000..da2deb49 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-bookmark.elc differ diff --git a/elpa/magit-20200318.1224/magit-branch.el b/elpa/magit-20200318.1224/magit-branch.el new file mode 100644 index 00000000..b2d0a73a --- /dev/null +++ b/elpa/magit-20200318.1224/magit-branch.el @@ -0,0 +1,893 @@ +;;; magit-branch.el --- branch support -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for branches. It defines commands +;; for creating, checking out, manipulating, and configuring branches. +;; Commands defined here are mainly concerned with branches as +;; pointers, commands that deal with what a branch points at, are +;; defined elsewhere. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) +(require 'magit-reset) + +;;; Options + +(defcustom magit-branch-read-upstream-first t + "Whether to read upstream before name of new branch when creating a branch. + +`nil' Read the branch name first. +`t' Read the upstream first. +`fallback' Read the upstream first, but if it turns out that the chosen + value is not a valid upstream (because it cannot be resolved + as an existing revision), then treat it as the name of the + new branch and continue by reading the upstream next." + :package-version '(magit . "2.2.0") + :group 'magit-commands + :type '(choice (const :tag "read branch name first" nil) + (const :tag "read upstream first" t) + (const :tag "read upstream first, with fallback" fallback))) + +(defcustom magit-branch-prefer-remote-upstream nil + "Whether to favor remote upstreams when creating new branches. + +When a new branch is created, then the branch, commit, or stash +at point is suggested as the default starting point of the new +branch, or if there is no such revision at point the current +branch. In either case the user may choose another starting +point. + +If the chosen starting point is a branch, then it may also be set +as the upstream of the new branch, depending on the value of the +Git variable `branch.autoSetupMerge'. By default this is done +for remote branches, but not for local branches. + +You might prefer to always use some remote branch as upstream. +If the chosen starting point is (1) a local branch, (2) whose +name matches a member of the value of this option, (3) the +upstream of that local branch is a remote branch with the same +name, and (4) that remote branch can be fast-forwarded to the +local branch, then the chosen branch is used as starting point, +but its own upstream is used as the upstream of the new branch. + +Members of this option's value are treated as branch names that +have to match exactly unless they contain a character that makes +them invalid as a branch name. Recommended characters to use +to trigger interpretation as a regexp are \"*\" and \"^\". Some +other characters which you might expect to be invalid, actually +are not, e.g. \".+$\" are all perfectly valid. More precisely, +if `git check-ref-format --branch STRING' exits with a non-zero +status, then treat STRING as a regexp. + +Assuming the chosen branch matches these conditions you would end +up with with e.g.: + + feature --upstream--> origin/master + +instead of + + feature --upstream--> master --upstream--> origin/master + +Which you prefer is a matter of personal preference. If you do +prefer the former, then you should add branches such as \"master\", +\"next\", and \"maint\" to the value of this options." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(repeat string)) + +(defcustom magit-branch-adjust-remote-upstream-alist nil + "Alist of upstreams to be used when branching from remote branches. + +When creating a local branch from an ephemeral branch located +on a remote, e.g. a feature or hotfix branch, then that remote +branch should usually not be used as the upstream branch, since +the push-remote already allows accessing it and having both the +upstream and the push-remote reference the same related branch +would be wasteful. Instead a branch like \"maint\" or \"master\" +should be used as the upstream. + +This option allows specifying the branch that should be used as +the upstream when branching certain remote branches. The value +is an alist of the form ((UPSTREAM . RULE)...). The first +matching element is used, the following elements are ignored. + +UPSTREAM is the branch to be used as the upstream for branches +specified by RULE. It can be a local or a remote branch. + +RULE can either be a regular expression, matching branches whose +upstream should be the one specified by UPSTREAM. Or it can be +a list of the only branches that should *not* use UPSTREAM; all +other branches will. Matching is done after stripping the remote +part of the name of the branch that is being branched from. + +If you use a finite set of non-ephemeral branches across all your +repositories, then you might use something like: + + ((\"origin/master\" \"master\" \"next\" \"maint\")) + +Or if the names of all your ephemeral branches contain a slash, +at least in some repositories, then a good value could be: + + ((\"origin/master\" . \"/\")) + +Of course you can also fine-tune: + + ((\"origin/maint\" . \"\\\\\\=`hotfix/\") + (\"origin/master\" . \"\\\\\\=`feature/\")) + +If you use remote branches as UPSTREAM, then you might also want +to set `magit-branch-prefer-remote-upstream' to a non-nil value. +However, I recommend that you use local branches as UPSTREAM." + :package-version '(magit . "2.9.0") + :group 'magit-commands + :type '(repeat (cons (string :tag "Use upstream") + (choice :tag "for branches" + (regexp :tag "matching") + (repeat :tag "except" + (string :tag "branch")))))) + +(defcustom magit-branch-rename-push-target t + "Whether the push-remote setup is preserved when renaming a branch. + +The command `magit-branch-rename' renames a branch named OLD to +NEW. This option controls how much of the push-remote setup is +preserved when doing so. + +When nil, then preserve nothing and unset `branch.OLD.pushRemote'. + +When `local-only', then first set `branch.NEW.pushRemote' to the + same value as `branch.OLD.pushRemote', provided the latter is + actually set and unless the former already has another value. + +When t, then rename the branch named OLD on the remote specified + by `branch.OLD.pushRemote' to NEW, provided OLD exists on that + remote and unless NEW already exists on the remote. + +When `forge-only' and the `forge' package is available, then + behave like `t' if the remote points to a repository on a forge + (currently Github or Gitlab), otherwise like `local-only'. + +Another supported but obsolete value is `github-only'. It is a + misnomer because it now treated as an alias for `forge-only'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type '(choice + (const :tag "Don't preserve push-remote setup" nil) + (const :tag "Preserve push-remote setup" local-only) + (const :tag "... and rename corresponding branch on remote" t) + (const :tag "... but only if remote is on a forge" forge-only))) + +(defcustom magit-branch-direct-configure t + "Whether the command `magit-branch' shows Git variables. +When set to nil, no variables are displayed by this transient +command, instead the sub-transient `magit-branch-configure' +has to be used to view and change branch related variables." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-published-branches '("origin/master") + "List of branches that are considered to be published." + :package-version '(magit . "2.13.0") + :group 'magit-commands + :type '(repeat string)) + +;;; Commands + +;;;###autoload (autoload 'magit-branch "magit" nil t) +(define-transient-command magit-branch (branch) + "Add, configure or remove a branch." + :man-page "git-branch" + ["Variables" + :if (lambda () + (and magit-branch-direct-configure + (oref transient--prefix scope))) + ("d" magit-branch..description) + ("u" magit-branch..merge/remote) + ("r" magit-branch..rebase) + ("p" magit-branch..pushRemote)] + [["Checkout" + ("b" "branch/revision" magit-checkout) + ("l" "local branch" magit-branch-checkout) + (6 "o" "new orphan" magit-branch-orphan)] + ["" + ("c" "new branch" magit-branch-and-checkout) + ("s" "new spin-off" magit-branch-spinoff) + (5 "w" "new worktree" magit-worktree-checkout)] + ["Create" + ("n" "new branch" magit-branch-create) + ("S" "new spin-out" magit-branch-spinout) + (5 "W" "new worktree" magit-worktree-branch)] + ["Do" + ("C" "configure..." magit-branch-configure) + ("m" "rename" magit-branch-rename) + ("x" "reset" magit-branch-reset) + ("k" "delete" magit-branch-delete)] + ["" + (7 "h" "shelve" magit-branch-shelve) + (7 "H" "unshelve" magit-branch-unshelve)]] + (interactive (list (magit-get-current-branch))) + (transient-setup 'magit-branch nil nil :scope branch)) + +;;;###autoload +(defun magit-checkout (revision) + "Checkout REVISION, updating the index and the working tree. +If REVISION is a local branch, then that becomes the current +branch. If it is something else, then `HEAD' becomes detached. +Checkout fails if the working tree or the staging area contain +changes. +\n(git checkout REVISION)." + (interactive (list (magit-read-other-branch-or-commit "Checkout"))) + (when (string-match "\\`heads/\\(.+\\)" revision) + (setq revision (match-string 1 revision))) + (magit-run-git "checkout" revision)) + +;;;###autoload +(defun magit-branch-create (branch start-point) + "Create BRANCH at branch or revision START-POINT." + (interactive (magit-branch-read-args "Create branch")) + (magit-call-git "branch" branch start-point) + (magit-branch-maybe-adjust-upstream branch start-point) + (magit-refresh)) + +;;;###autoload +(defun magit-branch-and-checkout (branch start-point) + "Create and checkout BRANCH at branch or revision START-POINT." + (interactive (magit-branch-read-args "Create and checkout branch")) + (if (string-match-p "^stash@{[0-9]+}$" start-point) + (magit-run-git "stash" "branch" branch start-point) + (magit-call-git "checkout" "-b" branch start-point) + (magit-branch-maybe-adjust-upstream branch start-point) + (magit-refresh))) + +;;;###autoload +(defun magit-branch-or-checkout (arg &optional start-point) + "Hybrid between `magit-checkout' and `magit-branch-and-checkout'. + +Ask the user for an existing branch or revision. If the user +input actually can be resolved as a branch or revision, then +check that out, just like `magit-checkout' would. + +Otherwise create and checkout a new branch using the input as +its name. Before doing so read the starting-point for the new +branch. This is similar to what `magit-branch-and-checkout' +does." + (interactive + (let ((arg (magit-read-other-branch-or-commit "Checkout"))) + (list arg + (and (not (magit-commit-p arg)) + (magit-read-starting-point "Create and checkout branch" arg))))) + (when (string-match "\\`heads/\\(.+\\)" arg) + (setq arg (match-string 1 arg))) + (if start-point + (magit-branch-and-checkout arg start-point) + (magit-checkout arg))) + +;;;###autoload +(defun magit-branch-checkout (branch &optional start-point) + "Checkout an existing or new local branch. + +Read a branch name from the user offering all local branches and +a subset of remote branches as candidates. Omit remote branches +for which a local branch by the same name exists from the list +of candidates. The user can also enter a completely new branch +name. + +- If the user selects an existing local branch, then check that + out. + +- If the user selects a remote branch, then create and checkout + a new local branch with the same name. Configure the selected + remote branch as push target. + +- If the user enters a new branch name, then create and check + that out, after also reading the starting-point from the user. + +In the latter two cases the upstream is also set. Whether it is +set to the chosen START-POINT or something else depends on the +value of `magit-branch-adjust-remote-upstream-alist', just like +when using `magit-branch-and-checkout'." + (interactive + (let* ((current (magit-get-current-branch)) + (local (magit-list-local-branch-names)) + (remote (--filter (and (string-match "[^/]+/" it) + (not (member (substring it (match-end 0)) + (cons "HEAD" local)))) + (magit-list-remote-branch-names))) + (choices (nconc (delete current local) remote)) + (atpoint (magit-branch-at-point)) + (choice (magit-completing-read + "Checkout branch" choices + nil nil nil 'magit-revision-history + (or (car (member atpoint choices)) + (and atpoint + (car (member (and (string-match "[^/]+/" atpoint) + (substring atpoint (match-end 0))) + choices))))))) + (cond ((member choice remote) + (list (and (string-match "[^/]+/" choice) + (substring choice (match-end 0))) + choice)) + ((member choice local) + (list choice)) + (t + (list choice (magit-read-starting-point "Create" choice)))))) + (if (not start-point) + (magit-checkout branch) + (when (magit-anything-modified-p) + (user-error "Cannot checkout when there are uncommitted changes")) + (magit-branch-and-checkout branch start-point) + (when (magit-remote-branch-p start-point) + (pcase-let ((`(,remote . ,remote-branch) + (magit-split-branch-name start-point))) + (when (and (equal branch remote-branch) + (not (equal remote (magit-get "remote.pushDefault")))) + (magit-set remote "branch" branch "pushRemote")))))) + +(defun magit-branch-maybe-adjust-upstream (branch start-point) + (--when-let + (or (and (magit-get-upstream-branch branch) + (magit-get-indirect-upstream-branch start-point)) + (and (magit-remote-branch-p start-point) + (let ((name (cdr (magit-split-branch-name start-point)))) + (car (--first (if (listp (cdr it)) + (not (member name (cdr it))) + (string-match-p (cdr it) name)) + magit-branch-adjust-remote-upstream-alist))))) + (magit-call-git "branch" (concat "--set-upstream-to=" it) branch))) + +;;;###autoload +(defun magit-branch-orphan (branch start-point) + "Create and checkout an orphan BRANCH with contents from revision START-POINT." + (interactive (magit-branch-read-args "Create and checkout orphan branch")) + (magit-run-git "checkout" "--orphan" branch start-point)) + +(defun magit-branch-read-args (prompt &optional default-start) + (if magit-branch-read-upstream-first + (let ((choice (magit-read-starting-point prompt nil default-start))) + (if (magit-rev-verify choice) + (list (magit-read-string-ns + (if magit-completing-read--silent-default + (format "%s (starting at `%s')" prompt choice) + "Name for new branch") + (let ((def (mapconcat #'identity + (cdr (split-string choice "/")) + "/"))) + (and (member choice (magit-list-remote-branch-names)) + (not (member def (magit-list-local-branch-names))) + def))) + choice) + (if (eq magit-branch-read-upstream-first 'fallback) + (list choice + (magit-read-starting-point prompt choice default-start)) + (user-error "Not a valid starting-point: %s" choice)))) + (let ((branch (magit-read-string-ns (concat prompt " named")))) + (list branch (magit-read-starting-point prompt branch default-start))))) + +;;;###autoload +(defun magit-branch-spinout (branch &optional from) + "Create new branch from the unpushed commits. +Like `magit-branch-spinoff' but remain on the current branch. +If there are any uncommitted changes, then behave exactly like +`magit-branch-spinoff'." + (interactive (list (magit-read-string-ns "Spin out branch") + (car (last (magit-region-values 'commit))))) + (magit--branch-spinoff branch from nil)) + +;;;###autoload +(defun magit-branch-spinoff (branch &optional from) + "Create new branch from the unpushed commits. + +Create and checkout a new branch starting at and tracking the +current branch. That branch in turn is reset to the last commit +it shares with its upstream. If the current branch has no +upstream or no unpushed commits, then the new branch is created +anyway and the previously current branch is not touched. + +This is useful to create a feature branch after work has already +began on the old branch (likely but not necessarily \"master\"). + +If the current branch is a member of the value of option +`magit-branch-prefer-remote-upstream' (which see), then the +current branch will be used as the starting point as usual, but +the upstream of the starting-point may be used as the upstream +of the new branch, instead of the starting-point itself. + +If optional FROM is non-nil, then the source branch is reset +to `FROM~', instead of to the last commit it shares with its +upstream. Interactively, FROM is only ever non-nil, if the +region selects some commits, and among those commits, FROM is +the commit that is the fewest commits ahead of the source +branch. + +The commit at the other end of the selection actually does not +matter, all commits between FROM and `HEAD' are moved to the new +branch. If FROM is not reachable from `HEAD' or is reachable +from the source branch's upstream, then an error is raised." + (interactive (list (magit-read-string-ns "Spin off branch") + (car (last (magit-region-values 'commit))))) + (magit--branch-spinoff branch from t)) + +(defun magit--branch-spinoff (branch from checkout) + (when (magit-branch-p branch) + (user-error "Cannot spin off %s. It already exists" branch)) + (when (and (not checkout) + (magit-anything-modified-p)) + (message "Staying on HEAD due to uncommitted changes") + (setq checkout t)) + (if-let ((current (magit-get-current-branch))) + (let ((tracked (magit-get-upstream-branch current)) + base) + (when from + (unless (magit-rev-ancestor-p from current) + (user-error "Cannot spin off %s. %s is not reachable from %s" + branch from current)) + (when (and tracked + (magit-rev-ancestor-p from tracked)) + (user-error "Cannot spin off %s. %s is ancestor of upstream %s" + branch from tracked))) + (let ((magit-process-raise-error t)) + (if checkout + (magit-call-git "checkout" "-b" branch current) + (magit-call-git "branch" branch current))) + (--when-let (magit-get-indirect-upstream-branch current) + (magit-call-git "branch" "--set-upstream-to" it branch)) + (when (and tracked + (setq base + (if from + (concat from "^") + (magit-git-string "merge-base" current tracked))) + (not (magit-rev-eq base current))) + (if checkout + (magit-call-git "update-ref" "-m" + (format "reset: moving to %s" base) + (concat "refs/heads/" current) base) + (magit-call-git "reset" "--hard" base)))) + (if checkout + (magit-call-git "checkout" "-b" branch) + (magit-call-git "branch" branch))) + (magit-refresh)) + +;;;###autoload +(defun magit-branch-reset (branch to &optional set-upstream) + "Reset a branch to the tip of another branch or any other commit. + +When the branch being reset is the current branch, then do a +hard reset. If there are any uncommitted changes, then the user +has to confirm the reset because those changes would be lost. + +This is useful when you have started work on a feature branch but +realize it's all crap and want to start over. + +When resetting to another branch and a prefix argument is used, +then also set the target branch as the upstream of the branch +that is being reset." + (interactive + (let* ((atpoint (magit-local-branch-at-point)) + (branch (magit-read-local-branch "Reset branch" atpoint))) + (list branch + (magit-completing-read (format "Reset %s to" branch) + (delete branch (magit-list-branch-names)) + nil nil nil 'magit-revision-history + (or (and (not (equal branch atpoint)) atpoint) + (magit-get-upstream-branch branch))) + current-prefix-arg))) + (let ((inhibit-magit-refresh t)) + (if (equal branch (magit-get-current-branch)) + (if (and (magit-anything-modified-p) + (not (yes-or-no-p + "Uncommitted changes will be lost. Proceed? "))) + (user-error "Abort") + (magit-reset-hard to)) + (magit-call-git "update-ref" + "-m" (format "reset: moving to %s" to) + (magit-git-string "rev-parse" "--symbolic-full-name" + branch) + to)) + (when (and set-upstream (magit-branch-p to)) + (magit-set-upstream-branch branch to) + (magit-branch-maybe-adjust-upstream branch to))) + (magit-refresh)) + +(defvar magit-branch-delete-never-verify nil + "Whether `magit-branch-delete' always pushes with \"--no-verify\".") + +;;;###autoload +(defun magit-branch-delete (branches &optional force) + "Delete one or multiple branches. +If the region marks multiple branches, then offer to delete +those, otherwise prompt for a single branch to be deleted, +defaulting to the branch at point." + ;; One would expect this to be a command as simple as, for example, + ;; `magit-branch-rename'; but it turns out everyone wants to squeeze + ;; a bit of extra functionality into this one, including myself. + (interactive + (let ((branches (magit-region-values 'branch t)) + (force current-prefix-arg)) + (if (> (length branches) 1) + (magit-confirm t nil "Delete %i branches" nil branches) + (setq branches + (list (magit-read-branch-prefer-other + (if force "Force delete branch" "Delete branch"))))) + (unless force + (when-let ((unmerged (-remove #'magit-branch-merged-p branches))) + (if (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" + "Delete %i unmerged branches" + 'noabort unmerged) + (setq force branches) + (or (setq branches (-difference branches unmerged)) + (user-error "Abort"))))) + (list branches force))) + (let* ((refs (mapcar #'magit-ref-fullname branches)) + (ambiguous (--remove it refs))) + (when ambiguous + (user-error + "%s ambiguous. Please cleanup using git directly." + (let ((len (length ambiguous))) + (cond + ((= len 1) + (format "%s is" (-first #'magit-ref-ambiguous-p branches))) + ((= len (length refs)) + (format "These %s names are" len)) + (t + (format "%s of these names are" len)))))) + (cond + ((string-match "^refs/remotes/\\([^/]+\\)" (car refs)) + (let* ((remote (match-string 1 (car refs))) + (offset (1+ (length remote)))) + ;; Assume the branches actually still exists on the remote. + (magit-run-git-async + "push" + (and (or force magit-branch-delete-never-verify) "--no-verify") + remote + (--map (concat ":" (substring it offset)) branches)) + ;; If that is not the case, then this deletes the tracking branches. + (set-process-sentinel + magit-this-process + (apply-partially 'magit-delete-remote-branch-sentinel remote refs)))) + ((> (length branches) 1) + (setq branches (delete (magit-get-current-branch) branches)) + (mapc 'magit-branch-maybe-delete-pr-remote branches) + (mapc 'magit-branch-unset-pushRemote branches) + (magit-run-git "branch" (if force "-D" "-d") branches)) + (t ; And now for something completely different. + (let* ((branch (car branches)) + (prompt (format "Branch %s is checked out. " branch))) + (when (equal branch (magit-get-current-branch)) + (pcase (if (or (equal branch "master") + (not (magit-rev-verify "master"))) + (magit-read-char-case prompt nil + (?d "[d]etach HEAD & delete" 'detach) + (?a "[a]bort" 'abort)) + (magit-read-char-case prompt nil + (?d "[d]etach HEAD & delete" 'detach) + (?c "[c]heckout master & delete" 'master) + (?a "[a]bort" 'abort))) + (`detach (unless (or (equal force '(4)) + (member branch force) + (magit-branch-merged-p branch t)) + (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" "" + nil (list branch))) + (magit-call-git "checkout" "--detach")) + (`master (unless (or (equal force '(4)) + (member branch force) + (magit-branch-merged-p branch "master")) + (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" "" + nil (list branch))) + (magit-call-git "checkout" "master")) + (`abort (user-error "Abort"))) + (setq force t)) + (magit-branch-maybe-delete-pr-remote branch) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" (if force "-D" "-d") branch)))))) + +(put 'magit-branch-delete 'interactive-only t) + +(defun magit-branch-maybe-delete-pr-remote (branch) + (when-let ((remote (magit-get "branch" branch "pullRequestRemote"))) + (let* ((variable (format "remote.%s.fetch" remote)) + (refspecs (magit-get-all variable))) + (unless (member (format "+refs/heads/*:refs/remotes/%s/*" remote) + refspecs) + (let ((refspec + (if (equal (magit-get "branch" branch "pushRemote") remote) + (format "+refs/heads/%s:refs/remotes/%s/%s" + branch remote branch) + (let ((merge (magit-get "branch" branch "merge"))) + (and merge + (string-prefix-p "refs/heads/" merge) + (setq merge (substring merge 11)) + (format "+refs/heads/%s:refs/remotes/%s/%s" + merge remote merge)))))) + (when (member refspec refspecs) + (if (and (= (length refspecs) 1) + (magit-confirm 'delete-pr-remote + (format "Also delete remote %s (%s)" remote + "no pull-request branch remains") + nil t)) + (magit-call-git "remote" "rm" remote) + (magit-call-git "config" "--unset-all" variable + (format "^%s$" (regexp-quote refspec)))))))))) + +(defun magit-branch-unset-pushRemote (branch) + (magit-set nil "branch" branch "pushRemote")) + +(defun magit-delete-remote-branch-sentinel (remote refs process event) + (when (memq (process-status process) '(exit signal)) + (if (= (process-exit-status process) 1) + (if-let ((on-remote (--map (concat "refs/remotes/" remote "/" it) + (magit-remote-list-branches remote))) + (rest (--filter (and (not (member it on-remote)) + (magit-ref-exists-p it)) + refs))) + (progn + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (setq magit-this-error nil) + (message "Some remote branches no longer exist. %s" + "Deleting just the local tracking refs instead...") + (dolist (ref rest) + (magit-call-git "update-ref" "-d" ref)) + (magit-refresh) + (message "Deleting local remote-tracking refs...done")) + (magit-process-sentinel process event)) + (magit-process-sentinel process event)))) + +;;;###autoload +(defun magit-branch-rename (old new &optional force) + "Rename the branch named OLD to NEW. + +With a prefix argument FORCE, rename even if a branch named NEW +already exists. + +If `branch.OLD.pushRemote' is set, then unset it. Depending on +the value of `magit-branch-rename-push-target' (which see) maybe +set `branch.NEW.pushRemote' and maybe rename the push-target on +the remote." + (interactive + (let ((branch (magit-read-local-branch "Rename branch"))) + (list branch + (magit-read-string-ns (format "Rename branch '%s' to" branch) + nil 'magit-revision-history) + current-prefix-arg))) + (when (string-match "\\`heads/\\(.+\\)" old) + (setq old (match-string 1 old))) + (when (equal old new) + (user-error "Old and new branch names are the same")) + (magit-call-git "branch" (if force "-M" "-m") old new) + (when magit-branch-rename-push-target + (let ((remote (magit-get-push-remote old)) + (old-specific (magit-get "branch" old "pushRemote")) + (new-specific (magit-get "branch" new "pushRemote"))) + (when (and old-specific (or force (not new-specific))) + ;; Keep the target setting branch specific, even if that is + ;; redundant. But if a branch by the same name existed before + ;; and the rename isn't forced, then do not change a leftover + ;; setting. Such a leftover setting may or may not conform to + ;; what we expect here... + (magit-set old-specific "branch" new "pushRemote")) + (when (and (equal (magit-get-push-remote new) remote) + ;; ...and if it does not, then we must abort. + (not (eq magit-branch-rename-push-target 'local-only)) + (or (not (memq magit-branch-rename-push-target + '(forge-only github-only))) + (and (require (quote forge) nil t) + (fboundp 'forge--forge-remote-p) + (forge--forge-remote-p remote)))) + (let ((old-target (magit-get-push-branch old t)) + (new-target (magit-get-push-branch new t)) + (remote (magit-get-push-remote new))) + (when (and old-target + (not new-target) + (magit-y-or-n-p (format "Also rename %S to %S on \"%s\"" + old new remote))) + ;; Rename on (i.e. within) the remote, but only if the + ;; destination ref doesn't exist yet. If that ref already + ;; exists, then it probably is of some value and we better + ;; not touch it. Ignore what the local ref points at, + ;; i.e. if the local and the remote ref didn't point at + ;; the same commit before the rename then keep it that way. + (magit-call-git "push" "-v" remote + (format "%s:refs/heads/%s" old-target new) + (format ":refs/heads/%s" old))))))) + (magit-branch-unset-pushRemote old) + (magit-refresh)) + +;;;###autoload +(defun magit-branch-shelve (branch) + "Shelve a BRANCH. +Rename \"refs/heads/BRANCH\" to \"refs/shelved/BRANCH\", +and also rename the respective reflog file." + (interactive (list (magit-read-other-local-branch "Shelve branch"))) + (let ((old (concat "refs/heads/" branch)) + (new (concat "refs/shelved/" branch))) + (magit-git "update-ref" new old "") + (magit--rename-reflog-file old new) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" "-D" branch))) + +;;;###autoload +(defun magit-branch-unshelve (branch) + "Unshelve a BRANCH +Rename \"refs/shelved/BRANCH\" to \"refs/heads/BRANCH\", +and also rename the respective reflog file." + (interactive + (list (magit-completing-read + "Unshelve branch" + (--map (substring it 8) + (magit-list-refnames "refs/shelved")) + nil t))) + (let ((old (concat "refs/shelved/" branch)) + (new (concat "refs/heads/" branch))) + (magit-git "update-ref" new old "") + (magit--rename-reflog-file old new) + (magit-run-git "update-ref" "-d" old))) + +(defun magit--rename-reflog-file (old new) + (let ((old (magit-git-dir (concat "logs/" old))) + (new (magit-git-dir (concat "logs/" new)))) + (when (file-exists-p old) + (make-directory (file-name-directory new) t) + (rename-file old new t)))) + +;;; Configure + +;;;###autoload (autoload 'magit-branch-configure "magit-branch" nil t) +(define-transient-command magit-branch-configure (branch) + "Configure a branch." + :man-page "git-branch" + [:description + (lambda () + (concat + (propertize "Configure " 'face 'transient-heading) + (propertize (oref transient--prefix scope) 'face 'magit-branch-local))) + ("d" magit-branch..description) + ("u" magit-branch..merge/remote) + ("r" magit-branch..rebase) + ("p" magit-branch..pushRemote)] + ["Configure repository defaults" + ("R" magit-pull.rebase) + ("P" magit-remote.pushDefault)] + ["Configure branch creation" + ("a m" magit-branch.autoSetupMerge) + ("a r" magit-branch.autoSetupRebase)] + (interactive + (list (or (and (not current-prefix-arg) + (not (and magit-branch-direct-configure + (eq current-transient-command 'magit-branch))) + (magit-get-current-branch)) + (magit--read-branch-scope)))) + (transient-setup 'magit-branch-configure nil nil :scope branch)) + +(defun magit--read-branch-scope (&optional obj) + (magit-read-local-branch + (if obj + (format "Set %s for branch" + (format (oref obj variable) "")) + "Configure branch"))) + +(define-suffix-command magit-branch..description (branch) + "Edit the description of BRANCH." + :class 'magit--git-variable + :transient nil + :variable "branch.%s.description" + (interactive (list (oref current-transient-prefix scope))) + (magit-run-git-with-editor "branch" "--edit-description" branch)) + +(add-hook 'find-file-hook 'magit-branch-description-check-buffers) + +(defun magit-branch-description-check-buffers () + (and buffer-file-name + (string-match-p "/\\(BRANCH\\|EDIT\\)_DESCRIPTION\\'" buffer-file-name))) + +(defclass magit--git-branch:upstream (magit--git-variable) + ((format :initform " %k %m %M\n %r %R"))) + +(define-infix-command magit-branch..merge/remote () + :class 'magit--git-branch:upstream) + +(cl-defmethod transient-init-value ((obj magit--git-branch:upstream)) + (when-let ((branch (oref transient--prefix scope)) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (oset obj value (list remote merge)))) + +(cl-defmethod transient-infix-read ((obj magit--git-branch:upstream)) + (if (oref obj value) + (oset obj value nil) + (magit-read-upstream-branch (oref transient--prefix scope) "Upstream"))) + +(cl-defmethod transient-infix-set ((obj magit--git-branch:upstream) refname) + (magit-set-upstream-branch (oref transient--prefix scope) refname) + (oset obj value + (let ((branch (oref transient--prefix scope))) + (when-let ((r (magit-get "branch" branch "remote")) + (m (magit-get "branch" branch "merge"))) + (list r m)))) + (magit-refresh)) + +(cl-defmethod transient-format ((obj magit--git-branch:upstream)) + (let ((branch (oref transient--prefix scope))) + (format-spec + (oref obj format) + `((?k . ,(transient-format-key obj)) + (?r . ,(format "branch.%s.remote" branch)) + (?m . ,(format "branch.%s.merge" branch)) + (?R . ,(transient-format-value obj #'car)) + (?M . ,(transient-format-value obj #'cadr)))))) + +(cl-defmethod transient-format-value ((obj magit--git-branch:upstream) key) + (if-let ((value (funcall key (oref obj value)))) + (propertize value 'face 'transient-argument) + (propertize "unset" 'face 'transient-inactive-argument))) + +(define-infix-command magit-branch..rebase () + :class 'magit--git-variable:choices + :scope 'magit--read-branch-scope + :variable "branch.%s.rebase" + :fallback "pull.rebase" + :choices '("true" "false") + :default "false") + +(define-infix-command magit-branch..pushRemote () + :class 'magit--git-variable:choices + :scope 'magit--read-branch-scope + :variable "branch.%s.pushRemote" + :fallback "remote.pushDefault" + :choices 'magit-list-remotes) + +(define-infix-command magit-pull.rebase () + :class 'magit--git-variable:choices + :variable "pull.rebase" + :choices '("true" "false") + :default "false") + +(define-infix-command magit-remote.pushDefault () + :class 'magit--git-variable:choices + :variable "remote.pushDefault" + :choices 'magit-list-remotes) + +(define-infix-command magit-branch.autoSetupMerge () + :class 'magit--git-variable:choices + :variable "branch.autoSetupMerge" + :choices '("always" "true" "false") + :default "true") + +(define-infix-command magit-branch.autoSetupRebase () + :class 'magit--git-variable:choices + :variable "branch.autoSetupRebase" + :choices '("always" "local" "remote" "never") + :default "never") + +;;; _ +(provide 'magit-branch) +;;; magit-branch.el ends here diff --git a/elpa/magit-20200318.1224/magit-branch.elc b/elpa/magit-20200318.1224/magit-branch.elc new file mode 100644 index 00000000..08af3b22 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-branch.elc differ diff --git a/elpa/magit-20200318.1224/magit-clone.el b/elpa/magit-20200318.1224/magit-clone.el new file mode 100644 index 00000000..00bd8048 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-clone.el @@ -0,0 +1,269 @@ +;;; magit-clone.el --- clone a repository -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements clone commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-clone-set-remote-head nil + "Whether cloning creates the symbolic-ref `/HEAD'." + :package-version '(magit . "2.4.2") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-clone-set-remote.pushDefault 'ask + "Whether to set the value of `remote.pushDefault' after cloning. + +If t, then set without asking. If nil, then don't set. If +`ask', then ask." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(choice (const :tag "set" t) + (const :tag "ask" ask) + (const :tag "don't set" nil))) + +(defcustom magit-clone-default-directory nil + "Default directory to use when `magit-clone' reads destination. +If nil (the default), then use the value of `default-directory'. +If a directory, then use that. If a function, then call that +with the remote url as only argument and use the returned value." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type '(choice (const :tag "value of default-directory") + (directory :tag "constant directory") + (function :tag "function's value"))) + +(defcustom magit-clone-always-transient nil + "Whether `magit-clone' always acts as a transient prefix command. +If nil, then a prefix argument has to be used to show the transient +popup instead of invoking the default suffix `magit-clone-regular' +directly." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-clone-name-alist + '(("\\`\\(?:github:\\|gh:\\)?\\([^:]+\\)\\'" "github.com" "github.user") + ("\\`\\(?:gitlab:\\|gl:\\)\\([^:]+\\)\\'" "gitlab.com" "gitlab.user")) + "Alist mapping repository names to repository urls. + +Each element has the form (REGEXP HOSTNAME USER). When the user +enters a name when a cloning command asks for a name or url, then +that is looked up in this list. The first element whose REGEXP +matches is used. + +The format specified by option `magit-clone-url-format' is used +to turn the name into an url, using HOSTNAME and the repository +name. If the provided name contains a slash, then that is used. +Otherwise if the name omits the owner of the repository, then the +default user specified in the matched entry is used. + +If USER contains a dot, then it is treated as a Git variable and +the value of that is used as the username. Otherwise it is used +as the username itself." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type '(repeat (list regexp + (string :tag "hostname") + (string :tag "user name or git variable")))) + +(defcustom magit-clone-url-format "git@%h:%n.git" + "Format used when turning repository names into urls. +%h is the hostname and %n is the repository name, including +the name of the owner. Also see `magit-clone-name-alist'." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'regexp) + +;;; Commands + +;;;###autoload (autoload 'magit-clone "magit-clone" nil t) +(define-transient-command magit-clone (&optional transient) + "Clone a repository." + :man-page "git-clone" + ["Fetch arguments" + ("-B" "Clone a single branch" "--single-branch") + ("-n" "Do not clone tags" "--no-tags") + ("-S" "Clones submodules" "--recurse-submodules" :level 6) + ("-l" "Do not optimize" "--no-local" :level 7)] + ["Setup arguments" + ("-o" "Set name of remote" ("-o" "--origin=")) + ("-b" "Set HEAD branch" ("-b" "--branch=")) + ("-g" "Separate git directory" "--separate-git-dir=" + transient-read-directory :level 7) + ("-t" "Use template directory" "--template=" + transient-read-existing-directory :level 6)] + ["Local sharing arguments" + ("-s" "Share objects" ("-s" "--shared" :level 7)) + ("-h" "Do not use hardlinks" "--no-hardlinks")] + ["Clone" + ("C" "regular" magit-clone-regular) + ("s" "shallow" magit-clone-shallow) + ("d" "shallow since date" magit-clone-shallow-since :level 7) + ("e" "shallow excluding" magit-clone-shallow-exclude :level 7) + ("b" "bare" magit-clone-bare) + ("m" "mirror" magit-clone-mirror)] + (interactive (list (or magit-clone-always-transient current-prefix-arg))) + (if transient + (transient-setup #'magit-clone) + (call-interactively #'magit-clone-regular))) + +;;;###autoload +(defun magit-clone-regular (repository directory args) + "Create a clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory args)) + +;;;###autoload +(defun magit-clone-shallow (repository directory args depth) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +With a prefix argument read the DEPTH of the clone; +otherwise use 1." + (interactive (append (magit-clone-read-args) + (list (if current-prefix-arg + (read-number "Depth: " 1) + 1)))) + (magit-clone-internal repository directory + (cons (format "--depth=%s" depth) args))) + +;;;###autoload +(defun magit-clone-shallow-since (repository directory args date) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits before DATE, which is read from the +user." + (interactive (append (magit-clone-read-args) + (list (transient-read-date "Exclude commits before: " + nil nil)))) + (magit-clone-internal repository directory + (cons (format "--shallow-since=%s" date) args))) + +;;;###autoload +(defun magit-clone-shallow-exclude (repository directory args exclude) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits reachable from EXCLUDE, which is a +branch or tag read from the user." + (interactive (append (magit-clone-read-args) + (list (read-string "Exclude commits reachable from: ")))) + (magit-clone-internal repository directory + (cons (format "--shallow-exclude=%s" exclude) args))) + +;;;###autoload +(defun magit-clone-bare (repository directory args) + "Create a bare clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory (cons "--bare" args))) + +;;;###autoload +(defun magit-clone-mirror (repository directory args) + "Create a mirror of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory (cons "--mirror" args))) + +(defun magit-clone-internal (repository directory args) + (run-hooks 'magit-credential-hook) + (setq directory (file-name-as-directory (expand-file-name directory))) + (magit-run-git-async "clone" args "--" repository + (magit-convert-filename-for-git directory)) + ;; Don't refresh the buffer we're calling from. + (process-put magit-this-process 'inhibit-refresh t) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (let ((magit-process-raise-error t)) + (magit-process-sentinel process event))) + (when (and (eq (process-status process) 'exit) + (= (process-exit-status process) 0)) + (unless (memq (car args) '("--bare" "--mirror")) + (let ((default-directory directory)) + (when (or (eq magit-clone-set-remote.pushDefault t) + (and magit-clone-set-remote.pushDefault + (y-or-n-p "Set `remote.pushDefault' to \"origin\"? "))) + (setf (magit-get "remote.pushDefault") "origin")) + (unless magit-clone-set-remote-head + (magit-remote-unset-head "origin")))) + (with-current-buffer (process-get process 'command-buf) + (magit-status-setup-buffer directory)))))) + +(defun magit-clone-read-args () + (let ((repo (magit-clone-read-repository))) + (list repo + (read-directory-name + "Clone to: " + (if (functionp magit-clone-default-directory) + (funcall magit-clone-default-directory repo) + magit-clone-default-directory) + nil nil + (and (string-match "\\([^/:]+?\\)\\(/?\\.git\\)?$" repo) + (match-string 1 repo))) + (transient-args 'magit-clone)))) + +(defun magit-clone-read-repository () + (magit-read-char-case "Clone from " nil + (?u "[u]rl or name" + (let ((str (magit-read-string-ns "Clone from url or name"))) + (if (string-match-p "\\(://\\|@\\)" str) + str + (magit-clone--name-to-url str)))) + (?p "[p]ath" + (read-directory-name "Clone repository: ")) + (?l "or [l]ocal url" + (concat "file://" (read-directory-name "Clone repository: file://"))))) + +(defun magit-clone--name-to-url (name) + (or (-some + (pcase-lambda (`(,re ,host ,user)) + (and (string-match re name) + (let ((repo (match-string 1 name))) + (magit-clone--format-url host user repo)))) + magit-clone-name-alist) + (user-error "Not an url and no matching entry in `%s'" + 'magit-clone-name-alist))) + +(defun magit-clone--format-url (host user repo) + (format-spec + magit-clone-url-format + `((?h . ,host) + (?n . ,(if (string-match-p "/" repo) + repo + (if (string-match-p "\\." user) + (if-let ((user (magit-get user))) + (concat user "/" repo) + (user-error "Set %S or specify owner explicitly" user)) + (concat user "/" repo))))))) + +;;; _ +(provide 'magit-clone) +;;; magit-clone.el ends here diff --git a/elpa/magit-20200318.1224/magit-clone.elc b/elpa/magit-20200318.1224/magit-clone.elc new file mode 100644 index 00000000..369234b6 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-clone.elc differ diff --git a/elpa/magit-20200318.1224/magit-commit.el b/elpa/magit-20200318.1224/magit-commit.el new file mode 100644 index 00000000..d7572cec --- /dev/null +++ b/elpa/magit-20200318.1224/magit-commit.el @@ -0,0 +1,570 @@ +;;; magit-commit.el --- create Git commits -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements commands for creating Git commits. These +;; commands just initiate the commit, support for writing the commit +;; messages is implemented in `git-commit.el'. + +;;; Code: + +(require 'magit) +(require 'magit-sequence) + +(eval-when-compile (require 'epa)) ; for `epa-protocol' +(eval-when-compile (require 'epg)) +(eval-when-compile (require 'subr-x)) + +;;; Options + +(defcustom magit-commit-ask-to-stage 'verbose + "Whether to ask to stage all unstaged changes when committing and nothing is staged." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type '(choice (const :tag "Ask" t) + (const :tag "Ask showing diff" verbose) + (const :tag "Stage without confirmation" stage) + (const :tag "Don't ask" nil))) + +(defcustom magit-commit-show-diff t + "Whether the relevant diff is automatically shown when committing." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-extend-override-date t + "Whether using `magit-commit-extend' changes the committer date." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-reword-override-date t + "Whether using `magit-commit-reword' changes the committer date." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-squash-confirm t + "Whether the commit targeted by squash and fixup has to be confirmed. +When non-nil then the commit at point (if any) is used as default +choice, otherwise it has to be confirmed. This option only +affects `magit-commit-squash' and `magit-commit-fixup'. The +\"instant\" variants always require confirmation because making +an error while using those is harder to recover from." + :package-version '(magit . "2.1.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-post-commit-hook nil + "Hook run after creating a commit without the user editing a message. + +This hook is run by `magit-refresh' if `this-command' is a member +of `magit-post-stage-hook-commands'. This only includes commands +named `magit-commit-*' that do *not* require that the user edits +the commit message in a buffer and then finishes by pressing +\\\\[with-editor-finish]. + +Also see `git-commit-post-finish-hook'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +(defvar magit-post-commit-hook-commands + '(magit-commit-extend + magit-commit-fixup + magit-commit-augment + magit-commit-instant-fixup + magit-commit-instant-squash)) + +;;; Popup + +;;;###autoload (autoload 'magit-commit "magit-commit" nil t) +(define-transient-command magit-commit () + "Create a new commit or replace an existing commit." + :info-manual "(magit)Initiating a Commit" + :man-page "git-commit" + ["Arguments" + ("-a" "Stage all modified and deleted files" ("-a" "--all")) + ("-e" "Allow empty commit" "--allow-empty") + ("-v" "Show diff of changes to be committed" ("-v" "--verbose")) + ("-n" "Disable hooks" ("-n" "--no-verify")) + ("-R" "Claim authorship and reset author date" "--reset-author") + (magit:--author :description "Override the author") + (7 "-D" "Override the author date" "--date=" transient-read-date) + ("-s" "Add Signed-off-by line" ("-s" "--signoff")) + (5 magit:--gpg-sign) + (magit-commit:--reuse-message)] + [["Create" + ("c" "Commit" magit-commit-create)] + ["Edit HEAD" + ("e" "Extend" magit-commit-extend) + ("w" "Reword" magit-commit-reword) + ("a" "Amend" magit-commit-amend) + (6 "n" "Reshelve" magit-commit-reshelve)] + ["Edit" + ("f" "Fixup" magit-commit-fixup) + ("s" "Squash" magit-commit-squash) + ("A" "Augment" magit-commit-augment) + (6 "x" "Absorb changes" magit-commit-absorb)] + ["" + ("F" "Instant fixup" magit-commit-instant-fixup) + ("S" "Instant squash" magit-commit-instant-squash)]] + (interactive) + (if-let ((buffer (magit-commit-message-buffer))) + (switch-to-buffer buffer) + (transient-setup 'magit-commit))) + +(defun magit-commit-arguments nil + (transient-args 'magit-commit)) + +(define-infix-argument magit:--gpg-sign () + :description "Sign using gpg" + :class 'transient-option + :shortarg "-S" + :argument "--gpg-sign=" + :allow-empty t + :reader 'magit-read-gpg-secret-key) + +(defvar magit-gpg-secret-key-hist nil) + +(defun magit-read-gpg-secret-key (prompt &optional initial-input history) + (require 'epa) + (let* ((keys (mapcar + (lambda (obj) + (let ((key (epg-sub-key-id (car (epg-key-sub-key-list obj)))) + (author + (when-let ((id-obj (car (epg-key-user-id-list obj)))) + (let ((id-str (epg-user-id-string id-obj))) + (if (stringp id-str) + id-str + (epg-decode-dn id-obj)))))) + (propertize key 'display (concat key " " author)))) + (epg-list-keys (epg-make-context epa-protocol) nil t))) + (choice (completing-read prompt keys nil nil nil + history nil initial-input))) + (set-text-properties 0 (length choice) nil choice) + choice)) + +(define-infix-argument magit-commit:--reuse-message () + :description "Reuse commit message" + :class 'transient-option + :shortarg "-C" + :argument "--reuse-message=" + :reader 'magit-read-reuse-message + :history-key 'magit-revision-history) + +(defun magit-read-reuse-message (prompt &optional default history) + (magit-completing-read prompt (magit-list-refnames) + nil nil nil history + (or default + (and (magit-rev-verify "ORIG_HEAD") + "ORIG_HEAD")))) + +;;; Commands + +;;;###autoload +(defun magit-commit-create (&optional args) + "Create a new commit on `HEAD'. +With a prefix argument, amend to the commit at `HEAD' instead. +\n(git commit [--amend] ARGS)" + (interactive (if current-prefix-arg + (list (cons "--amend" (magit-commit-arguments))) + (list (magit-commit-arguments)))) + (when (member "--all" args) + (setq this-command 'magit-commit-all)) + (when (setq args (magit-commit-assert args)) + (let ((default-directory (magit-toplevel))) + (magit-run-git-with-editor "commit" args)))) + +;;;###autoload +(defun magit-commit-amend (&optional args) + "Amend the last commit. +\n(git commit --amend ARGS)" + (interactive (list (magit-commit-arguments))) + (magit-commit-amend-assert) + (magit-run-git-with-editor "commit" "--amend" args)) + +;;;###autoload +(defun magit-commit-extend (&optional args override-date) + "Amend the last commit, without editing the message. + +With a prefix argument keep the committer date, otherwise change +it. The option `magit-commit-extend-override-date' can be used +to inverse the meaning of the prefix argument. \n(git commit +--amend --no-edit)" + (interactive (list (magit-commit-arguments) + (if current-prefix-arg + (not magit-commit-extend-override-date) + magit-commit-extend-override-date))) + (when (setq args (magit-commit-assert args (not override-date))) + (magit-commit-amend-assert) + (let ((process-environment process-environment)) + (unless override-date + (push (magit-rev-format "GIT_COMMITTER_DATE=%cD") process-environment)) + (magit-run-git-with-editor "commit" "--amend" "--no-edit" args)))) + +;;;###autoload +(defun magit-commit-reword (&optional args override-date) + "Reword the last commit, ignoring staged changes. + +With a prefix argument keep the committer date, otherwise change +it. The option `magit-commit-reword-override-date' can be used +to inverse the meaning of the prefix argument. + +Non-interactively respect the optional OVERRIDE-DATE argument +and ignore the option. +\n(git commit --amend --only)" + (interactive (list (magit-commit-arguments) + (if current-prefix-arg + (not magit-commit-reword-override-date) + magit-commit-reword-override-date))) + (magit-commit-amend-assert) + (let ((process-environment process-environment)) + (unless override-date + (push (magit-rev-format "GIT_COMMITTER_DATE=%cD") process-environment)) + (cl-pushnew "--allow-empty" args :test #'equal) + (magit-run-git-with-editor "commit" "--amend" "--only" args))) + +;;;###autoload +(defun magit-commit-fixup (&optional commit args) + "Create a fixup commit. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup" commit args)) + +;;;###autoload +(defun magit-commit-squash (&optional commit args) + "Create a squash commit, without editing the squash message. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash" commit args)) + +;;;###autoload +(defun magit-commit-augment (&optional commit args) + "Create a squash commit, editing the squash message. + +With a prefix argument the target COMMIT has to be confirmed. +Otherwise the commit at point may be used without confirmation +depending on the value of option `magit-commit-squash-confirm'." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash" commit args nil t)) + +;;;###autoload +(defun magit-commit-instant-fixup (&optional commit args) + "Create a fixup commit targeting COMMIT and instantly rebase." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup" commit args t)) + +;;;###autoload +(defun magit-commit-instant-squash (&optional commit args) + "Create a squash commit targeting COMMIT and instantly rebase." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash" commit args t)) + +(defun magit-commit-squash-internal + (option commit &optional args rebase edit confirmed) + (when-let ((args (magit-commit-assert args t))) + (when commit + (when (and rebase (not (magit-rev-ancestor-p commit "HEAD"))) + (magit-read-char-case + (format "%s isn't an ancestor of HEAD. " commit) nil + (?c "[c]reate without rebasing" (setq rebase nil)) + (?s "[s]elect other" (setq commit nil)) + (?a "[a]bort" (user-error "Quit"))))) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit + (or confirmed + (not (or rebase + current-prefix-arg + magit-commit-squash-confirm)))) + (let ((magit-commit-show-diff nil)) + (push (concat option "=" commit) args) + (unless edit + (push "--no-edit" args)) + (if rebase + (magit-with-editor + (magit-call-git + "commit" "--no-gpg-sign" + (-remove-first + (apply-partially #'string-match-p "\\`--gpg-sign=") + args))) + (magit-run-git-with-editor "commit" args)) + t) ; The commit was created; used by below lambda. + (magit-log-select + (lambda (commit) + (when (and (magit-commit-squash-internal option commit args + rebase edit t) + rebase) + (magit-commit-amend-assert commit) + (magit-rebase-interactive-1 commit + (list "--autosquash" "--autostash" "--keep-empty") + "" "true" nil t))) + (format "Type %%p on a commit to %s into it," + (substring option 2)) + nil nil nil commit) + (when magit-commit-show-diff + (let ((magit-display-buffer-noselect t)) + (apply #'magit-diff-staged nil (magit-diff-arguments))))))) + +(defun magit-commit-amend-assert (&optional commit) + (--when-let (magit-list-publishing-branches commit) + (let ((m1 "This commit has already been published to ") + (m2 ".\nDo you really want to modify it")) + (magit-confirm 'amend-published + (concat m1 "%s" m2) + (concat m1 "%i public branches" m2) + nil it)))) + +(defun magit-commit-assert (args &optional strict) + (cond + ((or (magit-anything-staged-p) + (and (magit-anything-unstaged-p) + ;; ^ Everything of nothing is still nothing. + (member "--all" args)) + (and (not strict) + ;; ^ For amend variants that don't make sense otherwise. + (or (member "--amend" args) + (member "--allow-empty" args)))) + (or args (list "--"))) + ((and (magit-rebase-in-progress-p) + (not (magit-anything-unstaged-p)) + (y-or-n-p "Nothing staged. Continue in-progress rebase? ")) + (setq this-command 'magit-rebase-continue) + (magit-run-git-sequencer "rebase" "--continue") + nil) + ((and (file-exists-p (magit-git-dir "MERGE_MSG")) + (not (magit-anything-unstaged-p))) + (or args (list "--"))) + ((not (magit-anything-unstaged-p)) + (user-error "Nothing staged (or unstaged)")) + (magit-commit-ask-to-stage + (when (eq magit-commit-ask-to-stage 'verbose) + (magit-diff-unstaged)) + (prog1 (when (or (eq magit-commit-ask-to-stage 'stage) + (y-or-n-p "Nothing staged. Stage and commit all unstaged changes? ")) + (magit-run-git "add" "-u" ".") + (or args (list "--"))) + (when (and (eq magit-commit-ask-to-stage 'verbose) + (derived-mode-p 'magit-diff-mode)) + (magit-mode-bury-buffer)))) + (t + (user-error "Nothing staged")))) + +(defvar magit--reshelve-history nil) + +;;;###autoload +(defun magit-commit-reshelve (date) + "Change the committer date and possibly the author date of `HEAD'. + +If you are the author of `HEAD', then both dates are changed, +otherwise only the committer date. The current time is used +as the initial minibuffer input and the original author (if +that is you) or committer date is available as the previous +history element." + (interactive + (let ((author-p (magit-rev-author-p "HEAD"))) + (push (magit-rev-format (if author-p "%ad" "%cd") "HEAD" + (concat "--date=format:%F %T %z")) + magit--reshelve-history) + (list (read-string (if author-p + "Change author and committer dates to: " + "Change committer date to: ") + (cons (format-time-string "%F %T %z") 17) + 'magit--reshelve-history)))) + (let ((process-environment process-environment)) + (push (concat "GIT_COMMITTER_DATE=" date) process-environment) + (magit-run-git "commit" "--amend" "--no-edit" + (and (magit-rev-author-p "HEAD") + (concat "--date=" date))))) + +;;;###autoload (autoload 'magit-commit-absorb "magit-commit" nil t) +(define-transient-command magit-commit-absorb (phase commit args) + "Spread unstaged changes across recent commits. +With a prefix argument use a transient command to select infix +arguments. This command requires the git-autofixup script, which +is available from https://github.com/torbiak/git-autofixup." + ["Arguments" + (magit-autofixup:--context) + (magit-autofixup:--strict)] + ["Actions" + ("x" "Absorb" magit-commit-absorb)] + (interactive (if current-prefix-arg + (list 'transient nil nil) + (list 'select + (magit-get-upstream-branch) + (transient-args 'magit-commit-absorb)))) + (if (eq phase 'transient) + (transient-setup 'magit-commit-absorb) + (unless (executable-find "git-autofixup") + (user-error "This command requires the git-autofixup script, which %s" + "is available from https://github.com/torbiak/git-autofixup")) + (when (magit-anything-staged-p) + (user-error "Cannot absorb when there are staged changes")) + (unless (magit-anything-unstaged-p) + (user-error "There are no unstaged changes that could be absorbed")) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit (eq phase 'run)) + (progn (magit-run-git-async "autofixup" "-vv" args commit) t) + (magit-log-select + (lambda (commit) + (with-no-warnings ; about non-interactive use + (magit-commit-absorb 'run commit args))) + nil nil nil nil commit)))) + +(define-infix-argument magit-autofixup:--context () + :description "Diff context lines" + :class 'transient-option + :shortarg "-c" + :argument "--context=" + :reader 'transient-read-number-N0) + +(define-infix-argument magit-autofixup:--strict () + :description "Strictness" + :class 'transient-option + :shortarg "-s" + :argument "--strict=" + :reader 'transient-read-number-N0) + +;;; Pending Diff + +(defun magit-commit-diff () + (when (and git-commit-mode magit-commit-show-diff) + (when-let ((diff-buffer (magit-get-mode-buffer 'magit-diff-mode))) + ;; This window just started displaying the commit message + ;; buffer. Without this that buffer would immediately be + ;; replaced with the diff buffer. See #2632. + (unrecord-window-buffer nil diff-buffer)) + (condition-case nil + (let ((args (car (magit-diff-arguments))) + (magit-inhibit-save-previous-winconf 'unset) + (magit-display-buffer-noselect t) + (inhibit-quit nil)) + (message "Diffing changes to be committed (C-g to abort diffing)") + (cl-case last-command + (magit-commit + (magit-diff-staged nil args)) + (magit-commit-all + (magit-diff-working-tree nil args)) + ((magit-commit-amend + magit-commit-reword + magit-rebase-reword-commit) + (magit-diff-while-amending args)) + (t (if (magit-anything-staged-p) + (magit-diff-staged nil args) + (magit-diff-while-amending args))))) + (quit)))) + +;; Mention `magit-diff-while-committing' because that's +;; always what I search for when I try to find this line. +(add-hook 'server-switch-hook 'magit-commit-diff) + +(add-to-list 'with-editor-server-window-alist + (cons git-commit-filename-regexp 'switch-to-buffer)) + +;;; Message Utilities + +(defun magit-commit-message-buffer () + (let* ((find-file-visit-truename t) ; git uses truename of COMMIT_EDITMSG + (topdir (magit-toplevel))) + (--first (equal topdir (with-current-buffer it + (and git-commit-mode (magit-toplevel)))) + (append (buffer-list (selected-frame)) + (buffer-list))))) + +(defvar magit-commit-add-log-insert-function 'magit-commit-add-log-insert + "Used by `magit-commit-add-log' to insert a single entry.") + +(defun magit-commit-add-log () + "Add a stub for the current change into the commit message buffer. +If no commit is in progress, then initiate it. Use the function +specified by variable `magit-commit-add-log-insert-function' to +actually insert the entry." + (interactive) + (pcase-let* ((hunk (and (magit-section-match 'hunk) + (magit-current-section))) + (log (magit-commit-message-buffer)) + (`(,buf ,pos) (magit-diff-visit-file--noselect))) + (unless log + (unless (magit-commit-assert nil) + (user-error "Abort")) + (magit-commit-create) + (while (not (setq log (magit-commit-message-buffer))) + (sit-for 0.01))) + (magit--with-temp-position buf pos + (funcall magit-commit-add-log-insert-function log + (magit-file-relative-name) + (and hunk (add-log-current-defun)))))) + +(defun magit-commit-add-log-insert (buffer file defun) + (with-current-buffer buffer + (undo-boundary) + (goto-char (point-max)) + (while (re-search-backward (concat "^" comment-start) nil t)) + (save-restriction + (narrow-to-region (point-min) (point)) + (cond ((re-search-backward (format "* %s\\(?: (\\([^)]+\\))\\)?: " file) + nil t) + (when (equal (match-string 1) defun) + (setq defun nil)) + (re-search-forward ": ")) + (t + (when (re-search-backward "^[\\*(].+\n" nil t) + (goto-char (match-end 0))) + (while (re-search-forward "^[^\\*\n].*\n" nil t)) + (if defun + (progn (insert (format "* %s (%s): \n" file defun)) + (setq defun nil)) + (insert (format "* %s: \n" file))) + (backward-char) + (unless (looking-at "\n[\n\\']") + (insert ?\n) + (backward-char)))) + (when defun + (forward-line) + (let ((limit (save-excursion + (and (re-search-forward "^\\*" nil t) + (point))))) + (unless (or (looking-back (format "(%s): " defun) + (line-beginning-position)) + (re-search-forward (format "^(%s): " defun) limit t)) + (while (re-search-forward "^[^\\*\n].*\n" limit t)) + (insert (format "(%s): \n" defun)) + (backward-char))))))) + +;;; _ +(provide 'magit-commit) +;;; magit-commit.el ends here diff --git a/elpa/magit-20200318.1224/magit-commit.elc b/elpa/magit-20200318.1224/magit-commit.elc new file mode 100644 index 00000000..2b75604e Binary files /dev/null and b/elpa/magit-20200318.1224/magit-commit.elc differ diff --git a/elpa/magit-20200318.1224/magit-core.el b/elpa/magit-20200318.1224/magit-core.el new file mode 100644 index 00000000..900f2c54 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-core.el @@ -0,0 +1,128 @@ +;;; magit-core.el --- core functionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library requires several other libraries, so that yet other +;; libraries can just require this one, instead of having to require +;; all the other ones. In other words this separates the low-level +;; stuff from the rest. It also defines some Custom groups. + +;;; Code: + +(require 'magit-utils) +(require 'magit-section) +(require 'magit-git) +(require 'magit-mode) +(require 'magit-margin) +(require 'magit-process) +(require 'magit-transient) +(require 'magit-autorevert) + +(when (magit--libgit-available-p) + (condition-case err + (require 'magit-libgit) + (error + (setq magit-inhibit-libgit 'error) + (message "Error while loading `magit-libgit': %S" err) + (message "That is not fatal. The `libegit2' module just won't be used.")))) + +(defgroup magit nil + "Controlling Git from Emacs." + :link '(url-link "https://magit.vc") + :link '(info-link "(magit)FAQ") + :link '(info-link "(magit)") + :group 'tools) + +(defgroup magit-essentials nil + "Options that every Magit user should briefly think about. + +Each of these options falls into one or more of these categories: + +* Options that affect Magit's behavior in fundamental ways. +* Options that affect safety. +* Options that affect performance. +* Options that are of a personal nature." + :link '(info-link "(magit)Essential Settings") + :group 'magit) + +(defgroup magit-miscellaneous nil + "Miscellaneous Magit options." + :group 'magit) + +(defgroup magit-commands nil + "Options controlling behavior of certain commands." + :group 'magit) + +(defgroup magit-modes nil + "Modes used or provided by Magit." + :group 'magit) + +(defgroup magit-buffers nil + "Options concerning Magit buffers." + :link '(info-link "(magit)Modes and Buffers") + :group 'magit) + +(defgroup magit-refresh nil + "Options controlling how Magit buffers are refreshed." + :link '(info-link "(magit)Automatic Refreshing of Magit Buffers") + :group 'magit + :group 'magit-buffers) + +(defgroup magit-faces nil + "Faces used by Magit." + :group 'magit + :group 'faces) + +(defgroup magit-extensions nil + "Extensions to Magit." + :group 'magit) + +(custom-add-to-group 'magit-modes 'git-commit 'custom-group) +(custom-add-to-group 'magit-faces 'git-commit-faces 'custom-group) +(custom-add-to-group 'magit-modes 'git-rebase 'custom-group) +(custom-add-to-group 'magit-faces 'git-rebase-faces 'custom-group) +(custom-add-to-group 'magit 'magit-section 'custom-group) +(custom-add-to-group 'magit-faces 'magit-section-faces 'custom-group) +(custom-add-to-group 'magit-process 'with-editor 'custom-group) + +(defgroup magit-related nil + "Options that are relevant to Magit but that are defined elsewhere." + :link '(custom-group-link vc) + :link '(custom-group-link smerge) + :link '(custom-group-link ediff) + :link '(custom-group-link auto-revert) + :group 'magit + :group 'magit-extensions + :group 'magit-essentials) + +(custom-add-to-group 'magit-related 'auto-revert-check-vc-info 'custom-variable) +(custom-add-to-group 'magit-auto-revert 'auto-revert-check-vc-info 'custom-variable) + +(custom-add-to-group 'magit-related 'ediff-window-setup-function 'custom-variable) +(custom-add-to-group 'magit-related 'smerge-refine-ignore-whitespace 'custom-variable) +(custom-add-to-group 'magit-related 'vc-follow-symlinks 'custom-variable) + +;;; _ +(provide 'magit-core) +;;; magit-core.el ends here diff --git a/elpa/magit-20200318.1224/magit-core.elc b/elpa/magit-20200318.1224/magit-core.elc new file mode 100644 index 00000000..53d77f1d Binary files /dev/null and b/elpa/magit-20200318.1224/magit-core.elc differ diff --git a/elpa/magit-20200318.1224/magit-diff.el b/elpa/magit-20200318.1224/magit-diff.el new file mode 100644 index 00000000..6763e760 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-diff.el @@ -0,0 +1,3263 @@ +;;; magit-diff.el --- inspect Git diffs -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for looking at Git diffs and +;; commits. + +;;; Code: + +(eval-when-compile + (require 'ansi-color) + (require 'subr-x)) + +(require 'git-commit) +(require 'magit-core) + +;; For `magit-diff-popup' +(declare-function magit-stash-show "magit-stash" (stash &optional args files)) +;; For `magit-diff-visit-file' +(declare-function dired-jump "dired-x" (&optional other-window file-name)) +(declare-function magit-find-file-noselect "magit-files" (rev file)) +(declare-function magit-status-setup-buffer "magit-status" (directory)) +;; For `magit-diff-while-committing' +(declare-function magit-commit-message-buffer "magit-commit" ()) +;; For `magit-insert-revision-gravatar' +(defvar gravatar-size) +;; For `magit-show-commit' and `magit-diff-show-or-scroll' +(declare-function magit-current-blame-chunk "magit-blame" ()) +(declare-function magit-blame-mode "magit-blame" (&optional arg)) +(defvar magit-blame-mode) +;; For `magit-diff-show-or-scroll' +(declare-function git-rebase-current-line "git-rebase" ()) +;; For `magit-diff-unmerged' +(declare-function magit-merge-in-progress-p "magit-merge" ()) +(declare-function magit--merge-range "magit-merge" (&optional head)) +;; For `magit-diff--dwim' +(declare-function forge--pullreq-ref "forge-pullreq" (pullreq)) +;; For `magit-diff-wash-diff' +(declare-function ansi-color-apply-on-region "ansi-color" (begin end)) + +(eval-when-compile + (cl-pushnew 'base-ref eieio--known-slot-names) + (cl-pushnew 'orig-rev eieio--known-slot-names) + (cl-pushnew 'action-type eieio--known-slot-names) + (cl-pushnew 'target eieio--known-slot-names)) + +(require 'diff-mode) +(require 'smerge-mode) + +;;; Options +;;;; Diff Mode + +(defgroup magit-diff nil + "Inspect and manipulate Git diffs." + :link '(info-link "(magit)Diffing") + :group 'magit-modes) + +(defcustom magit-diff-mode-hook nil + "Hook run after entering Magit-Diff mode." + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-sections-hook + '(magit-insert-diff + magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-diff-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-expansion-threshold 60 + "After how many seconds not to expand anymore diffs. + +Except in status buffers, diffs are usually start out fully +expanded. Because that can take a long time, all diffs that +haven't been fontified during a refresh before the threshold +defined here are instead displayed with their bodies collapsed. + +Note that this can cause sections that were previously expanded +to be collapsed. So you should not pick a very low value here. + +The hook function `magit-diff-expansion-threshold' has to be a +member of `magit-section-set-visibility-hook' for this option +to have any effect." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'float) + +(defcustom magit-diff-highlight-hunk-body t + "Whether to highlight bodies of selected hunk sections. +This only has an effect if `magit-diff-highlight' is a +member of `magit-section-highlight-hook', which see." + :package-version '(magit . "2.1.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-highlight-hunk-region-functions + '(magit-diff-highlight-hunk-region-dim-outside + magit-diff-highlight-hunk-region-using-overlays) + "The functions used to highlight the hunk-internal region. + +`magit-diff-highlight-hunk-region-dim-outside' overlays the outside +of the hunk internal selection with a face that causes the added and +removed lines to have the same background color as context lines. +This function should not be removed from the value of this option. + +`magit-diff-highlight-hunk-region-using-overlays' and +`magit-diff-highlight-hunk-region-using-underline' emphasize the +region by placing delimiting horizontal lines before and after it. +The underline variant was implemented because Eli said that is +how we should do it. However the overlay variant actually works +better. Also see https://github.com/magit/magit/issues/2758. + +Instead of, or in addition to, using delimiting horizontal lines, +to emphasize the boundaries, you may which to emphasize the text +itself, using `magit-diff-highlight-hunk-region-using-face'. + +In terminal frames it's not possible to draw lines as the overlay +and underline variants normally do, so there they fall back to +calling the face function instead." + :package-version '(magit . "2.9.0") + :set-after '(magit-diff-show-lines-boundaries) + :group 'magit-diff + :type 'hook + :options '(magit-diff-highlight-hunk-region-dim-outside + magit-diff-highlight-hunk-region-using-underline + magit-diff-highlight-hunk-region-using-overlays + magit-diff-highlight-hunk-region-using-face)) + +(defcustom magit-diff-unmarked-lines-keep-foreground t + "Whether `magit-diff-highlight-hunk-region-dim-outside' preserves foreground. +When this is set to nil, then that function only adjusts the +foreground color but added and removed lines outside the region +keep their distinct foreground colors." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-refine-hunk nil + "Whether to show word-granularity differences within diff hunks. + +nil Never show fine differences. +t Show fine differences for the current diff hunk only. +`all' Show fine differences for all displayed diff hunks." + :group 'magit-diff + :safe (lambda (val) (memq val '(nil t all))) + :type '(choice (const :tag "Never" nil) + (const :tag "Current" t) + (const :tag "All" all))) + +(defcustom magit-diff-refine-ignore-whitespace smerge-refine-ignore-whitespace + "Whether to ignore whitespace changes in word-granularity differences." + :package-version '(magit . "3.0.0") + :set-after '(smerge-refine-ignore-whitespace) + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(put 'magit-diff-refine-hunk 'permanent-local t) + +(defcustom magit-diff-adjust-tab-width nil + "Whether to adjust the width of tabs in diffs. + +Determining the correct width can be expensive if it requires +opening large and/or many files, so the widths are cached in +the variable `magit-diff--tab-width-cache'. Set that to nil +to invalidate the cache. + +nil Never adjust tab width. Use `tab-width's value from + the Magit buffer itself instead. + +t If the corresponding file-visiting buffer exits, then + use `tab-width's value from that buffer. Doing this is + cheap, so this value is used even if a corresponding + cache entry exists. + +`always' If there is no such buffer, then temporarily visit the + file to determine the value. + +NUMBER Like `always', but don't visit files larger than NUMBER + bytes." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type '(choice (const :tag "Never" nil) + (const :tag "If file-visiting buffer exists" t) + (integer :tag "If file isn't larger than N bytes") + (const :tag "Always" always))) + +(defcustom magit-diff-paint-whitespace t + "Specify where to highlight whitespace errors. + +nil Never highlight whitespace errors. +t Highlight whitespace errors everywhere. +`uncommitted' Only highlight whitespace errors in diffs + showing uncommitted changes. + +For backward compatibility `status' is treated as a synonym +for `uncommitted'. + +The option `magit-diff-paint-whitespace-lines' controls for +what lines (added/remove/context) errors are highlighted. + +The options `magit-diff-highlight-trailing' and +`magit-diff-highlight-indentation' control what kind of +whitespace errors are highlighted." + :group 'magit-diff + :safe (lambda (val) (memq val '(t nil uncommitted status))) + :type '(choice (const :tag "In all diffs" t) + (const :tag "Only in uncommitted changes" uncommitted) + (const :tag "Never" nil))) + +(defcustom magit-diff-paint-whitespace-lines t + "Specify in what kind of lines to highlight whitespace errors. + +t Highlight only in added lines. +`both' Highlight in added and removed lines. +`all' Highlight in added, removed and context lines." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :safe (lambda (val) (memq val '(t both all))) + :type '(choice (const :tag "in added lines" t) + (const :tag "in added and removed lines" both) + (const :tag "in added, removed and context lines" all))) + +(defcustom magit-diff-highlight-trailing t + "Whether to highlight whitespace at the end of a line in diffs. +Used only when `magit-diff-paint-whitespace' is non-nil." + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(defcustom magit-diff-highlight-indentation nil + "Highlight the \"wrong\" indentation style. +Used only when `magit-diff-paint-whitespace' is non-nil. + +The value is an alist of the form ((REGEXP . INDENT)...). The +path to the current repository is matched against each element +in reverse order. Therefore if a REGEXP matches, then earlier +elements are not tried. + +If the used INDENT is `tabs', highlight indentation with tabs. +If INDENT is an integer, highlight indentation with at least +that many spaces. Otherwise, highlight neither." + :group 'magit-diff + :type `(repeat (cons (string :tag "Directory regexp") + (choice (const :tag "Tabs" tabs) + (integer :tag "Spaces" :value ,tab-width) + (const :tag "Neither" nil))))) + +(defcustom magit-diff-hide-trailing-cr-characters + (and (memq system-type '(ms-dos windows-nt)) t) + "Whether to hide ^M characters at the end of a line in diffs." + :package-version '(magit . "2.6.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-highlight-keywords t + "Whether to highlight bracketed keywords in commit messages." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type 'boolean) + +;;;; File Diff + +(defcustom magit-diff-buffer-file-locked t + "Whether `magit-diff-buffer-file' uses a dedicated buffer." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :group 'magit-diff + :type 'boolean) + +;;;; Revision Mode + +(defgroup magit-revision nil + "Inspect and manipulate Git commits." + :link '(info-link "(magit)Revision Buffer") + :group 'magit-modes) + +(defcustom magit-revision-mode-hook '(bug-reference-mode) + "Hook run after entering Magit-Revision mode." + :group 'magit-revision + :type 'hook + :options '(bug-reference-mode)) + +(defcustom magit-revision-sections-hook + '(magit-insert-revision-tag + magit-insert-revision-headers + magit-insert-revision-message + magit-insert-revision-notes + magit-insert-revision-diff + magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-revision-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'hook) + +(defcustom magit-revision-headers-format "\ +Author: %aN <%aE> +AuthorDate: %ad +Commit: %cN <%cE> +CommitDate: %cd +" + "Format string used to insert headers in revision buffers. + +All headers in revision buffers are inserted by the section +inserter `magit-insert-revision-headers'. Some of the headers +are created by calling `git show --format=FORMAT' where FORMAT +is the format specified here. Other headers are hard coded or +subject to option `magit-revision-insert-related-refs'." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'string) + +(defcustom magit-revision-insert-related-refs t + "Whether to show related branches in revision buffers + +`nil' Don't show any related branches. +`t' Show related local branches. +`all' Show related local and remote branches. +`mixed' Show all containing branches and local merged branches." + :package-version '(magit . "2.1.0") + :group 'magit-revision + :type '(choice (const :tag "don't" nil) + (const :tag "local only" t) + (const :tag "all related" all) + (const :tag "all containing, local merged" mixed))) + +(defcustom magit-revision-use-hash-sections 'quicker + "Whether to turn hashes inside the commit message into sections. + +If non-nil, then hashes inside the commit message are turned into +`commit' sections. There is a trade off to be made between +performance and reliability: + +- `slow' calls git for every word to be absolutely sure. +- `quick' skips words less than seven characters long. +- `quicker' additionally skips words that don't contain a number. +- `quickest' uses all words that are at least seven characters + long and which contain at least one number as well as at least + one letter. + +If nil, then no hashes are turned into sections, but you can +still visit the commit at point using \"RET\"." + :package-version '(magit . "2.12.0") + :group 'magit-revision + :type '(choice (const :tag "Use sections, quickest" quickest) + (const :tag "Use sections, quicker" quicker) + (const :tag "Use sections, quick" quick) + (const :tag "Use sections, slow" slow) + (const :tag "Don't use sections" nil))) + +(defcustom magit-revision-show-gravatars nil + "Whether to show gravatar images in revision buffers. + +If nil, then don't insert any gravatar images. If t, then insert +both images. If `author' or `committer', then insert only the +respective image. + +If you have customized the option `magit-revision-header-format' +and want to insert the images then you might also have to specify +where to do so. In that case the value has to be a cons-cell of +two regular expressions. The car specifies where to insert the +author's image. The top half of the image is inserted right +after the matched text, the bottom half on the next line in the +same column. The cdr specifies where to insert the committer's +image, accordingly. Either the car or the cdr may be nil." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type '(choice (const :tag "Don't show gravatars" nil) + (const :tag "Show gravatars" t) + (const :tag "Show author gravatar" author) + (const :tag "Show committer gravatar" committer) + (cons :tag "Show gravatars using custom pattern." + (regexp :tag "Author regexp" "^Author: ") + (regexp :tag "Committer regexp" "^Commit: ")))) + +(defcustom magit-revision-use-gravatar-kludge nil + "Whether to work around a bug which affects display of gravatars. + +Gravatar images are spliced into two halves which are then +displayed on separate lines. On OS X the splicing has a bug in +some Emacs builds, which causes the top and bottom halves to be +interchanged. Enabling this option works around this issue by +interchanging the halves once more, which cancels out the effect +of the bug. + +See https://github.com/magit/magit/issues/2265 +and https://debbugs.gnu.org/cgi/bugreport.cgi?bug=7847. + +Starting with Emacs 26.1 this kludge should not be required for +any build." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'boolean) + +(defcustom magit-revision-fill-summary-line nil + "Whether to fill excessively long summary lines. + +If this is an integer, then the summary line is filled if it is +longer than either the limit specified here or `window-width'. + +You may want to only set this locally in \".dir-locals-2.el\" for +repositories known to contain bad commit messages. + +The body of the message is left alone because (a) most people who +write excessively long summary lines usually don't add a body and +(b) even people who have the decency to wrap their lines may have +a good reason to include a long line in the body sometimes." + :package-version '(magit . "2.90.0") + :group 'magit-revision + :type '(choice (const :tag "Don't fill" nil) + (integer :tag "Fill if longer than"))) + +(defcustom magit-revision-filter-files-on-follow nil + "Whether to honor file filter if log arguments include --follow. + +When a commit is displayed from a log buffer, the resulting +revision buffer usually shares the log's file arguments, +restricting the diff to those files. However, there's a +complication when the log arguments include --follow: if the log +follows a file across a rename event, keeping the file +restriction would mean showing an empty diff in revision buffers +for commits before the rename event. + +When this option is nil, the revision buffer ignores the log's +filter if the log arguments include --follow. If non-nil, the +log's file filter is always honored." + :package-version '(magit . "3.0.0") + :group 'magit-revision + :type 'boolean) + +;;;; Visit Commands + +(defcustom magit-diff-visit-previous-blob t + "Whether `magit-diff-visit-file' may visit the previous blob. + +When this is t and point is on a removed line in a diff for a +committed change, then `magit-diff-visit-file' visits the blob +from the last revision which still had that line. + +Currently this is only supported for committed changes, for +staged and unstaged changes `magit-diff-visit-file' always +visits the file in the working tree." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-visit-avoid-head-blob nil + "Whether `magit-diff-visit-file' avoids visiting a blob from `HEAD'. + +By default `magit-diff-visit-file' always visits the blob that +added the current line, while `magit-diff-visit-worktree-file' +visits the respective file in the working tree. For the `HEAD' +commit, the former command used to visit the worktree file too, +but that made it impossible to visit a blob from `HEAD'. + +When point is on a removed line and that change has not been +committed yet, then `magit-diff-visit-file' now visits the last +blob that still had that line, which is a blob from `HEAD'. +Previously this function used to visit the worktree file not +only for added lines but also for such removed lines. + +If you prefer the old behaviors, then set this to t." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :type 'boolean) + +;;; Faces + +(defface magit-diff-file-heading + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :weight bold)) + "Face for diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-highlight + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-section-highlight)) + "Face for current diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-selection + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-file-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-file-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff file headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey80" + :foreground "grey30") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey25" + :foreground "grey70")) + "Face for diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey75" + :foreground "grey30") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey35" + :foreground "grey70")) + "Face for current diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-selection + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-region + `((t :inherit bold + ,@(and (>= emacs-major-version 27) + (list :extend (ignore-errors (face-attribute 'region :extend)))))) + "Face used by `magit-diff-highlight-hunk-region-using-face'. + +This face is overlaid over text that uses other hunk faces, +and those normally set the foreground and background colors. +The `:foreground' and especially the `:background' properties +should be avoided here. Setting the latter would cause the +loss of information. Good properties to set here are `:weight' +and `:slant'." + :group 'magit-faces) + +(defface magit-diff-revision-summary + '((t :inherit magit-diff-hunk-heading)) + "Face for commit message summaries." + :group 'magit-faces) + +(defface magit-diff-revision-summary-highlight + '((t :inherit magit-diff-hunk-heading-highlight)) + "Face for highlighted commit message summaries." + :group 'magit-faces) + +(defface magit-diff-lines-heading + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :background "LightSalmon3") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "grey80" + :background "salmon4")) + "Face for diff hunk heading when lines are marked." + :group 'magit-faces) + +(defface magit-diff-lines-boundary + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) ; !important + :inherit magit-diff-lines-heading)) + "Face for boundary of marked lines in diff hunk." + :group 'magit-faces) + +(defface magit-diff-conflict-heading + '((t :inherit magit-diff-hunk-heading)) + "Face for conflict markers." + :group 'magit-faces) + +(defface magit-diff-added + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ddffdd" + :foreground "#22aa22") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#335533" + :foreground "#ddffdd")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ffdddd" + :foreground "#aa2222") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#553333" + :foreground "#ffdddd")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our + '((t :inherit magit-diff-removed)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ffffcc" + :foreground "#aaaa11") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#555522" + :foreground "#ffffcc")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their + '((t :inherit magit-diff-added)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "grey50") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "grey70")) + "Face for lines in a diff that are unchanged." + :group 'magit-faces) + +(defface magit-diff-added-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#cceecc" + :foreground "#22aa22") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#336633" + :foreground "#cceecc")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#eecccc" + :foreground "#aa2222") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#663333" + :foreground "#eecccc")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our-highlight + '((t :inherit magit-diff-removed-highlight)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#eeeebb" + :foreground "#aaaa11") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#666622" + :foreground "#eeeebb")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their-highlight + '((t :inherit magit-diff-added-highlight)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey95" + :foreground "grey50") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey20" + :foreground "grey70")) + "Face for lines in the current context in a diff." + :group 'magit-faces) + +(defface magit-diff-whitespace-warning + '((t :inherit trailing-whitespace)) + "Face for highlighting whitespace errors added lines." + :group 'magit-faces) + +(defface magit-diffstat-added + '((((class color) (background light)) :foreground "#22aa22") + (((class color) (background dark)) :foreground "#448844")) + "Face for plus sign in diffstat." + :group 'magit-faces) + +(defface magit-diffstat-removed + '((((class color) (background light)) :foreground "#aa2222") + (((class color) (background dark)) :foreground "#aa4444")) + "Face for minus sign in diffstat." + :group 'magit-faces) + +;;; Arguments +;;;; Prefix Classes + +(defclass magit-diff-prefix (transient-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform 'magit-diff-mode))) + +(defclass magit-diff-refresh-prefix (magit-diff-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform nil))) + +;;;; Prefix Methods + +(cl-defmethod transient-init-value ((obj magit-diff-prefix)) + (pcase-let ((`(,args ,files) + (magit-diff--get-value 'magit-diff-mode + magit-prefix-use-buffer-arguments))) + (unless (eq current-transient-command 'magit-dispatch) + (when-let ((file (magit-file-relative-name))) + (setq files (list file)))) + (oset obj value (if files `(("--" ,@files) ,args) args)))) + +(cl-defmethod transient-init-value ((obj magit-diff-refresh-prefix)) + (oset obj value (if magit-buffer-diff-files + `(("--" ,@magit-buffer-diff-files) + ,magit-buffer-diff-args) + magit-buffer-diff-args))) + +(cl-defmethod transient-set-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj)) + +(cl-defmethod transient-save-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj 'save)) + +;;;; Argument Access + +(defun magit-diff-arguments (&optional mode) + "Return the current diff arguments." + (if (memq current-transient-command '(magit-diff magit-diff-refresh)) + (pcase-let ((`(,args ,alist) + (-separate #'atom (transient-get-value)))) + (list args (cdr (assoc "--" alist)))) + (magit-diff--get-value (or mode 'magit-diff-mode)))) + +(defun magit-diff--get-value (mode &optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args files) + (cond + ((and (memq use-buffer-args '(always selected current)) + (eq major-mode mode)) + (setq args magit-buffer-diff-args) + (setq files magit-buffer-diff-files)) + ((and (memq use-buffer-args '(always selected)) + (when-let ((buffer (magit-get-mode-buffer + mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-diff-args buffer)) + (setq files (buffer-local-value 'magit-buffer-diff-files buffer)) + t))) + ((plist-member (symbol-plist mode) 'magit-diff-current-arguments) + (setq args (get mode 'magit-diff-current-arguments))) + ((when-let ((elt (assq (intern (format "magit-diff:%s" mode)) + transient-values))) + (setq args (cdr elt)) + t)) + (t + (setq args (get mode 'magit-diff-default-arguments)))) + (list args files))) + +(defun magit-diff--set-value (obj &optional save) + (pcase-let* ((obj (oref obj prototype)) + (mode (or (oref obj major-mode) major-mode)) + (key (intern (format "magit-diff:%s" mode))) + (`(,args ,alist) + (-separate #'atom (transient-get-value))) + (files (cdr (assoc "--" alist)))) + (put mode 'magit-diff-current-arguments args) + (when save + (setf (alist-get key transient-values) args) + (transient-save-values)) + (transient--history-push obj) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files) + (magit-refresh))) + +;;; Section Classes + +(defclass magit-file-section (magit-section) + ((source :initform nil) + (header :initform nil))) + +(defclass magit-module-section (magit-file-section) + ()) + +(defclass magit-hunk-section (magit-section) + ((refined :initform nil) + (combined :initform nil) + (from-range :initform nil) + (from-ranges :initform nil) + (to-range :initform nil) + (about :initform nil))) + +(setf (alist-get 'hunk magit--section-type-alist) 'magit-hunk-section) +(setf (alist-get 'module magit--section-type-alist) 'magit-module-section) +(setf (alist-get 'file magit--section-type-alist) 'magit-file-section) + +;;; Commands +;;;; Prefix Commands + +;;;###autoload (autoload 'magit-diff "magit-diff" nil t) +(define-transient-command magit-diff () + "Show changes between different versions." + :man-page "git-diff" + :class 'magit-diff-prefix + ["Limit arguments" + (magit:--) + (magit-diff:--ignore-submodules) + ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) + (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] + ["Context arguments" + (magit-diff:-U) + ("-W" "Show surrounding functions" ("-W" "--function-context"))] + ["Tune arguments" + (magit-diff:--diff-algorithm) + (magit-diff:-M) + (magit-diff:-C) + ("-x" "Disallow external diff drivers" "--no-ext-diff") + ("-s" "Show stats" "--stat") + ("=g" "Show signature" "--show-signature") + (5 magit-diff:--color-moved) + (5 magit-diff:--color-moved-ws)] + ["Actions" + [("d" "Dwim" magit-diff-dwim) + ("r" "Diff range" magit-diff-range) + ("p" "Diff paths" magit-diff-paths)] + [("u" "Diff unstaged" magit-diff-unstaged) + ("s" "Diff staged" magit-diff-staged) + ("w" "Diff worktree" magit-diff-working-tree)] + [("c" "Show commit" magit-show-commit) + ("t" "Show stash" magit-stash-show)]]) + +;;;###autoload (autoload 'magit-diff-refresh "magit-diff" nil t) +(define-transient-command magit-diff-refresh () + "Change the arguments used for the diff(s) in the current buffer." + :man-page "git-diff" + :class 'magit-diff-refresh-prefix + ["Limit arguments" + (magit:--) + (magit-diff:--ignore-submodules) + ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) + (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] + ["Context arguments" + (magit-diff:-U) + ("-W" "Show surrounding functions" ("-W" "--function-context"))] + ["Tune arguments" + (magit-diff:--diff-algorithm) + (magit-diff:-M) + (magit-diff:-C) + ("-x" "Disallow external diff drivers" "--no-ext-diff") + ("-s" "Show stats" "--stat" + :if-derived magit-diff-mode) + ("=g" "Show signature" "--show-signature" + :if-derived magit-diff-mode) + (5 magit-diff:--color-moved) + (5 magit-diff:--color-moved-ws)] + [["Refresh" + ("g" "buffer" magit-diff-refresh) + ("s" "buffer and set defaults" transient-set :transient nil) + ("w" "buffer and save defaults" transient-save :transient nil)] + ["Toggle" + ("t" "hunk refinement" magit-diff-toggle-refine-hunk) + ("F" "file filter" magit-diff-toggle-file-filter) + ("b" "buffer lock" magit-toggle-buffer-lock + :if-mode (magit-diff-mode magit-revision-mode magit-stash-mode))] + [:if-mode magit-diff-mode + :description "Do" + ("r" "switch range type" magit-diff-switch-range-type) + ("f" "flip revisions" magit-diff-flip-revs)]] + (interactive) + (if (not (eq current-transient-command 'magit-diff-refresh)) + (transient-setup 'magit-diff-refresh) + (pcase-let ((`(,args ,files) (magit-diff-arguments))) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files)) + (magit-refresh))) + +;;;; Infix Commands + +(define-infix-argument magit:-- () + :description "Limit to files" + :class 'transient-files + :key "--" + :argument "--" + :prompt "Limit to file(s): " + :reader 'magit-read-files + :multi-value t) + +(defun magit-read-files (prompt initial-input history) + (magit-completing-read-multiple* prompt + (magit-list-files) + nil nil initial-input history)) + +(define-infix-argument magit-diff:-U () + :description "Context lines" + :class 'transient-option + :argument "-U" + :reader 'transient-read-number-N+) + +(define-infix-argument magit-diff:-M () + :description "Detect renames" + :class 'transient-option + :argument "-M" + :reader 'transient-read-number-N+) + +(define-infix-argument magit-diff:-C () + :description "Detect copies" + :class 'transient-option + :argument "-C" + :reader 'transient-read-number-N+) + +(define-infix-argument magit-diff:--diff-algorithm () + :description "Diff algorithm" + :class 'transient-option + :key "-A" + :argument "--diff-algorithm=" + :reader 'magit-diff-select-algorithm) + +(defun magit-diff-select-algorithm (&rest _ignore) + (magit-read-char-case nil t + (?d "[d]efault" "default") + (?m "[m]inimal" "minimal") + (?p "[p]atience" "patience") + (?h "[h]istogram" "histogram"))) + +(define-infix-argument magit-diff:--ignore-submodules () + :description "Ignore submodules" + :class 'transient-option + :key "-i" + :argument "--ignore-submodules=" + :reader 'magit-diff-select-ignore-submodules) + +(defun magit-diff-select-ignore-submodules (&rest _ignored) + (magit-read-char-case "Ignore submodules " t + (?u "[u]ntracked" "untracked") + (?d "[d]irty" "dirty") + (?a "[a]ll" "all"))) + +(define-infix-argument magit-diff:--color-moved () + :description "Color moved lines" + :class 'transient-option + :key "-m" + :argument "--color-moved=" + :reader 'magit-diff-select-color-moved-mode) + +(defun magit-diff-select-color-moved-mode (&rest _ignore) + (magit-read-char-case "Color moved " t + (?d "[d]efault" "default") + (?p "[p]lain" "plain") + (?b "[b]locks" "blocks") + (?z "[z]ebra" "zebra") + (?Z "[Z] dimmed-zebra" "dimmed-zebra"))) + +(define-infix-argument magit-diff:--color-moved-ws () + :description "Whitespace treatment for --color-moved" + :class 'transient-option + :key "=w" + :argument "--color-moved-ws=" + :reader 'magit-diff-select-color-moved-ws-mode) + +(defun magit-diff-select-color-moved-ws-mode (&rest _ignore) + (magit-read-char-case "Ignore whitespace " t + (?i "[i]ndentation" "allow-indentation-change") + (?e "[e]nd of line" "ignore-space-at-eol") + (?s "[s]pace change" "ignore-space-change") + (?a "[a]ll space" "ignore-all-space") + (?n "[n]o" "no"))) + +;;;; Setup Commands + +;;;###autoload +(defun magit-diff-dwim (&optional args files) + "Show changes for the thing at point." + (interactive (magit-diff-arguments)) + (pcase (magit-diff--dwim) + (`unmerged (magit-diff-unmerged args files)) + (`unstaged (magit-diff-unstaged args files)) + (`staged + (let ((file (magit-file-at-point))) + (if (and file (equal (cddr (car (magit-file-status file))) '(?D ?U))) + ;; File was deleted by us and modified by them. Show the latter. + (magit-diff-unmerged args (list file)) + (magit-diff-staged nil args files)))) + (`(commit . ,value) + (magit-diff-range (format "%s^..%s" value value) args files)) + (`(stash . ,value) (magit-stash-show value args)) + ((and range (pred stringp)) + (magit-diff-range range args files)) + (_ + (call-interactively #'magit-diff-range)))) + +(defun magit-diff--dwim () + "Return information for performing DWIM diff. + +The information can be in three forms: +1. TYPE + A symbol describing a type of diff where no additional information + is needed to generate the diff. Currently, this includes `staged', + `unstaged' and `unmerged'. +2. (TYPE . VALUE) + Like #1 but the diff requires additional information, which is + given by VALUE. Currently, this includes `commit' and `stash', + where VALUE is the given commit or stash, respectively. +3. RANGE + A string indicating a diff range. + +If no DWIM context is found, nil is returned." + (cond + ((--when-let (magit-region-values '(commit branch) t) + (deactivate-mark) + (concat (car (last it)) ".." (car it)))) + (magit-buffer-refname + (cons 'commit magit-buffer-refname)) + ((derived-mode-p 'magit-stash-mode) + (cons 'commit + (magit-section-case + (commit (oref it value)) + (file (-> it + (oref parent) + (oref value))) + (hunk (-> it + (oref parent) + (oref parent) + (oref value)))))) + ((derived-mode-p 'magit-revision-mode) + (cons 'commit magit-buffer-revision)) + ((derived-mode-p 'magit-diff-mode) + magit-buffer-range) + (t + (magit-section-case + ([* unstaged] 'unstaged) + ([* staged] 'staged) + (unmerged 'unmerged) + (unpushed (oref it value)) + (unpulled (oref it value)) + (branch (let ((current (magit-get-current-branch)) + (atpoint (oref it value))) + (if (equal atpoint current) + (--if-let (magit-get-upstream-branch) + (format "%s...%s" it current) + (if (magit-anything-modified-p) + current + (cons 'commit current))) + (format "%s...%s" + (or current "HEAD") + atpoint)))) + (commit (cons 'commit (oref it value))) + (stash (cons 'stash (oref it value))) + (pullreq (let ((pullreq (oref it value))) + (format "%s...%s" + (oref pullreq base-ref) + (forge--pullreq-ref pullreq)))))))) + +(defun magit-diff-read-range-or-commit (prompt &optional secondary-default mbase) + "Read range or revision with special diff range treatment. +If MBASE is non-nil, prompt for which rev to place at the end of +a \"revA...revB\" range. Otherwise, always construct +\"revA..revB\" range." + (--if-let (magit-region-values '(commit branch) t) + (let ((revA (car (last it))) + (revB (car it))) + (deactivate-mark) + (if mbase + (let ((base (magit-git-string "merge-base" revA revB))) + (cond + ((string= (magit-rev-parse revA) base) + (format "%s..%s" revA revB)) + ((string= (magit-rev-parse revB) base) + (format "%s..%s" revB revA)) + (t + (let ((main (magit-completing-read "View changes along" + (list revA revB) + nil t nil nil revB))) + (format "%s...%s" + (if (string= main revB) revA revB) main))))) + (format "%s..%s" revA revB))) + (magit-read-range prompt + (or (pcase (magit-diff--dwim) + (`(commit . ,value) + (format "%s^..%s" value value)) + ((and range (pred stringp)) + range)) + secondary-default + (magit-get-current-branch))))) + +;;;###autoload +(defun magit-diff-range (rev-or-range &optional args files) + "Show differences between two commits. + +REV-OR-RANGE should be a range or a single revision. If it is a +revision, then show changes in the working tree relative to that +revision. If it is a range, but one side is omitted, then show +changes relative to `HEAD'. + +If the region is active, use the revisions on the first and last +line of the region as the two sides of the range. With a prefix +argument, instead of diffing the revisions, choose a revision to +view changes along, starting at the common ancestor of both +revisions (i.e., use a \"...\" range)." + (interactive (cons (magit-diff-read-range-or-commit "Diff for range" + nil current-prefix-arg) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev-or-range nil args files)) + +;;;###autoload +(defun magit-diff-working-tree (&optional rev args files) + "Show changes between the current working tree and the `HEAD' commit. +With a prefix argument show changes between the working tree and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff working tree and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer (or rev "HEAD") nil args files)) + +;;;###autoload +(defun magit-diff-staged (&optional rev args files) + "Show changes between the index and the `HEAD' commit. +With a prefix argument show changes between the index and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff index and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev "--cached" args files)) + +;;;###autoload +(defun magit-diff-unstaged (&optional args files) + "Show changes between the working tree and the index." + (interactive (magit-diff-arguments)) + (magit-diff-setup-buffer nil nil args files)) + +;;;###autoload +(defun magit-diff-unmerged (&optional args files) + "Show changes that are being merged." + (interactive (magit-diff-arguments)) + (unless (magit-merge-in-progress-p) + (user-error "No merge is in progress")) + (magit-diff-setup-buffer (magit--merge-range) nil args files)) + +;;;###autoload +(defun magit-diff-while-committing (&optional args) + "While committing, show the changes that are about to be committed. +While amending, invoking the command again toggles between +showing just the new changes or all the changes that will +be committed." + (interactive (list (car (magit-diff-arguments)))) + (unless (magit-commit-message-buffer) + (user-error "No commit in progress")) + (let ((magit-display-buffer-noselect t)) + (if-let ((diff-buf (magit-get-mode-buffer 'magit-diff-mode 'selected))) + (with-current-buffer diff-buf + (cond ((and (equal magit-buffer-range "HEAD^") + (equal magit-buffer-typearg "--cached")) + (magit-diff-staged nil args)) + ((and (equal magit-buffer-range nil) + (equal magit-buffer-typearg "--cached")) + (magit-diff-while-amending args)) + ((magit-anything-staged-p) + (magit-diff-staged nil args)) + (t + (magit-diff-while-amending args)))) + (if (magit-anything-staged-p) + (magit-diff-staged nil args) + (magit-diff-while-amending args))))) + +(define-key git-commit-mode-map + (kbd "C-c C-d") 'magit-diff-while-committing) + +(defun magit-diff-while-amending (&optional args) + (magit-diff-setup-buffer "HEAD^" "--cached" args nil)) + +;;;###autoload +(defun magit-diff-buffer-file () + "Show diff for the blob or file visited in the current buffer. + +When the buffer visits a blob, then show the respective commit. +When the buffer visits a file, then show the differenced between +`HEAD' and the working tree. In both cases limit the diff to +the file or blob." + (interactive) + (require 'magit) + (if-let ((file (magit-file-relative-name))) + (if magit-buffer-refname + (magit-show-commit magit-buffer-refname + (car (magit-show-commit--arguments)) + (list file)) + (save-buffer) + (let ((line (line-number-at-pos)) + (col (current-column))) + (with-current-buffer + (magit-diff-setup-buffer (or (magit-get-current-branch) "HEAD") + nil + (car (magit-diff-arguments)) + (list file) + magit-diff-buffer-file-locked) + (magit-diff--goto-position file line col)))) + (user-error "Buffer isn't visiting a file"))) + +;;;###autoload +(defun magit-diff-paths (a b) + "Show changes between any two files on disk." + (interactive (list (read-file-name "First file: " nil nil t) + (read-file-name "Second file: " nil nil t))) + (magit-diff-setup-buffer nil "--no-index" + nil (list (magit-convert-filename-for-git + (expand-file-name a)) + (magit-convert-filename-for-git + (expand-file-name b))))) + +(defun magit-show-commit--arguments () + (pcase-let ((`(,args ,diff-files) + (magit-diff-arguments 'magit-revision-mode))) + (list args (if (derived-mode-p 'magit-log-mode) + (and (or magit-revision-filter-files-on-follow + (not (member "--follow" magit-buffer-log-args))) + magit-buffer-log-files) + diff-files)))) + +;;;###autoload +(defun magit-show-commit (rev &optional args files module) + "Visit the revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision." + (interactive + (pcase-let* ((mcommit (magit-section-value-if 'module-commit)) + (atpoint (or (and (bound-and-true-p magit-blame-mode) + (oref (magit-current-blame-chunk) orig-rev)) + mcommit + (magit-branch-or-commit-at-point))) + (`(,args ,files) (magit-show-commit--arguments))) + (list (or (and (not current-prefix-arg) atpoint) + (magit-read-branch-or-commit "Show commit" atpoint)) + args + files + (and mcommit + (magit-section-parent-value (magit-current-section)))))) + (require 'magit) + (let ((file (magit-file-relative-name))) + (magit-with-toplevel + (when module + (setq default-directory + (expand-file-name (file-name-as-directory module)))) + (unless (magit-commit-p rev) + (user-error "%s is not a commit" rev)) + (let ((buf (magit-revision-setup-buffer rev args files))) + (when file + (save-buffer) + (let ((line (magit-diff-visit--offset file (list "-R" rev) + (line-number-at-pos))) + (col (current-column))) + (with-current-buffer buf + (magit-diff--goto-position file line col)))))))) + +(defun magit-diff--locate-hunk (file line &optional parent) + (when-let ((diff (cl-find-if (lambda (section) + (and (cl-typep section 'magit-file-section) + (equal (oref section value) file))) + (oref (or parent magit-root-section) children)))) + (let (hunk (hunks (oref diff children))) + (cl-block nil + (while (setq hunk (pop hunks)) + (pcase-let* ((`(,beg ,len) (oref hunk to-range)) + (end (+ beg len))) + (cond ((> beg line) (cl-return (list diff nil))) + ((<= beg line end) (cl-return (list hunk t))) + ((null hunks) (cl-return (list hunk nil)))))))))) + +(defun magit-diff--goto-position (file line column &optional parent) + (when-let ((pos (magit-diff--locate-hunk file line parent))) + (pcase-let ((`(,section ,exact) pos)) + (cond ((cl-typep section 'magit-file-section) + (goto-char (oref section start))) + (exact + (goto-char (oref section content)) + (let ((pos (car (oref section to-range)))) + (while (or (< pos line) + (= (char-after) ?-)) + (unless (= (char-after) ?-) + (cl-incf pos)) + (forward-line))) + (forward-char (1+ column))) + (t + (goto-char (oref section start)) + (setq section (oref section parent)))) + (while section + (when (oref section hidden) + (magit-section-show section)) + (setq section (oref section parent)))) + (magit-section-update-highlight) + t)) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-revision-mode)) + (cons magit-buffer-range magit-buffer-diff-files)) + +;;;; Setting Commands + +(defun magit-diff-switch-range-type () + "Convert diff range type. +Change \"revA..revB\" to \"revA...revB\", or vice versa." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (setq magit-buffer-range + (replace-match (if (string= (match-string 2 magit-buffer-range) "..") + "..." + "..") + t t magit-buffer-range 2)) + (user-error "No range to change")) + (magit-refresh)) + +(defun magit-diff-flip-revs () + "Swap revisions in diff range. +Change \"revA..revB\" to \"revB..revA\"." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (progn + (setq magit-buffer-range + (concat (match-string 3 magit-buffer-range) + (match-string 2 magit-buffer-range) + (match-string 1 magit-buffer-range))) + (magit-refresh)) + (user-error "No range to swap"))) + +(defun magit-diff-toggle-file-filter () + "Toggle the file restriction of the current buffer's diffs. +If the current buffer's mode is derived from `magit-log-mode', +toggle the file restriction in the repository's revision buffer +instead." + (interactive) + (cl-flet ((toggle () + (if (or magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (cl-rotatef magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (setq magit-buffer-diff-files + (magit-read-files "Limit to file(s): " + (magit-file-at-point) + nil))) + (magit-refresh))) + (cond + ((derived-mode-p 'magit-log-mode + 'magit-cherry-mode + 'magit-reflog-mode) + (if-let ((buffer (magit-get-mode-buffer 'magit-revision-mode))) + (with-current-buffer buffer (toggle)) + (message "No revision buffer"))) + ((local-variable-p 'magit-buffer-diff-files) + (toggle)) + (t + (user-error "Cannot toggle file filter in this buffer"))))) + +(defun magit-diff-less-context (&optional count) + "Decrease the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context `(lambda (cur) (max 0 (- (or cur 0) ,count))))) + +(defun magit-diff-more-context (&optional count) + "Increase the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context `(lambda (cur) (+ (or cur 0) ,count)))) + +(defun magit-diff-default-context () + "Reset context for diff hunks to the default height." + (interactive) + (magit-diff-set-context #'ignore)) + +(defun magit-diff-set-context (fn) + (let* ((def (--if-let (magit-get "diff.context") (string-to-number it) 3)) + (val magit-buffer-diff-args) + (arg (--first (string-match "^-U\\([0-9]+\\)?$" it) val)) + (num (--if-let (and arg (match-string 1 arg)) (string-to-number it) def)) + (val (delete arg val)) + (num (funcall fn num)) + (arg (and num (not (= num def)) (format "-U%i" num))) + (val (if arg (cons arg val) val))) + (setq magit-buffer-diff-args val)) + (magit-refresh)) + +(defun magit-diff-context-p () + (if-let ((arg (--first (string-match "^-U\\([0-9]+\\)$" it) + magit-buffer-diff-args))) + (not (equal arg "-U0")) + t)) + +(defun magit-diff-ignore-any-space-p () + (--any-p (member it magit-buffer-diff-args) + '("--ignore-cr-at-eol" + "--ignore-space-at-eol" + "--ignore-space-change" "-b" + "--ignore-all-space" "-w" + "--ignore-blank-space"))) + +(defun magit-diff-toggle-refine-hunk (&optional style) + "Turn diff-hunk refining on or off. + +If hunk refining is currently on, then hunk refining is turned off. +If hunk refining is off, then hunk refining is turned on, in +`selected' mode (only the currently selected hunk is refined). + +With a prefix argument, the \"third choice\" is used instead: +If hunk refining is currently on, then refining is kept on, but +the refining mode (`selected' or `all') is switched. +If hunk refining is off, then hunk refining is turned on, in +`all' mode (all hunks refined). + +Customize variable `magit-diff-refine-hunk' to change the default mode." + (interactive "P") + (setq-local magit-diff-refine-hunk + (if style + (if (eq magit-diff-refine-hunk 'all) t 'all) + (not magit-diff-refine-hunk))) + (magit-diff-update-hunk-refinement)) + +;;;; Visit Commands +;;;;; Dwim Variants + +(defun magit-diff-visit-file (file &optional other-window) + "From a diff visit the appropriate version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +Visit the worktree version of the appropriate file. The location +of point inside the diff determines which file is being visited. +The visited version depends on what changes the diff is about. + +1. If the diff shows uncommitted changes (i.e. stage or unstaged + changes), then visit the file in the working tree (i.e. the + same \"real\" file that `find-file' would visit. In all other + cases visit a \"blob\" (i.e. the version of a file as stored + in some commit). + +2. If point is on a removed line, then visit the blob for the + first parent of the commit that removed that line, i.e. the + last commit where that line still exists. + +3. If point is on an added or context line, then visit the blob + that adds that line, or if the diff shows from more than a + single commit, then visit the blob from the last of these + commits. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. + +Note that this command only works if point is inside a diff. In +other cases `magit-find-file' (which see) had to be used." + (interactive (list (magit-file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file nil + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-file-other-window (file) + "From a diff visit the appropriate version of FILE in another window. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-file-other-frame (file) + "From a diff visit the appropriate version of FILE in another frame. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-frame)) + +;;;;; Worktree Variants + +(defun magit-diff-visit-worktree-file (file &optional other-window) + "From a diff visit the worktree version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +Visit the worktree version of the appropriate file. The location +of point inside the diff determines which file is being visited. + +Unlike `magit-diff-visit-file' always visits the \"real\" file in +the working tree, i.e the \"current version\" of the file. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. Lines that were added +or removed in the working tree, the index and other commits in +between are automatically accounted for." + (interactive (list (magit-file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file t + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-worktree-file-other-window (file) + "From a diff visit the worktree version of FILE in another window. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-worktree-file-other-frame (file) + "From a diff visit the worktree version of FILE in another frame. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-frame)) + +;;;;; Internal + +(defun magit-diff-visit-file--internal (file force-worktree fn) + "From a diff visit the appropriate version of FILE. +If FORCE-WORKTREE is non-nil, then visit the worktree version of +the file, even if the diff is about a committed change. USE FN +to display the buffer in some window." + (if (magit-file-accessible-directory-p file) + (magit-diff-visit-directory file force-worktree) + (pcase-let ((`(,buf ,pos) + (magit-diff-visit-file--noselect file force-worktree))) + (funcall fn buf) + (magit-diff-visit-file--setup buf pos) + buf))) + +(defun magit-diff-visit-directory (directory &optional other-window) + "Visit DIRECTORY in some window. +Display the buffer in the selected window unless OTHER-WINDOW is +non-nil. If DIRECTORY is the top-level directory of the current +repository, then visit the containing directory using Dired and +in the Dired buffer put point on DIRECTORY. Otherwise display +the Magit-Status buffer for DIRECTORY." + (if (equal (magit-toplevel directory) + (magit-toplevel)) + (dired-jump other-window (concat directory "/.")) + (let ((display-buffer-overriding-action + (if other-window + '(nil (inhibit-same-window t)) + '(display-buffer-same-window)))) + (magit-status-setup-buffer directory)))) + +(defun magit-diff-visit-file--setup (buf pos) + (if-let ((win (get-buffer-window buf 'visible))) + (with-selected-window win + (when pos + (unless (<= (point-min) pos (point-max)) + (widen)) + (goto-char pos)) + (when (and buffer-file-name + (magit-anything-unmerged-p buffer-file-name)) + (smerge-start-session)) + (run-hooks 'magit-diff-visit-file-hook)) + (error "File buffer is not visible"))) + +(defun magit-diff-visit-file--noselect (&optional file goto-worktree) + (unless file + (setq file (magit-file-at-point t t))) + (let* ((hunk (magit-diff-visit--hunk)) + (goto-from (and hunk + (magit-diff-visit--goto-from-p hunk goto-worktree))) + (line (and hunk (magit-diff-hunk-line hunk goto-from))) + (col (and hunk (magit-diff-hunk-column hunk goto-from))) + (spec (magit-diff--dwim)) + (rev (if goto-from + (magit-diff-visit--range-from spec) + (magit-diff-visit--range-to spec))) + (buf (if (or goto-worktree + (and (not (stringp rev)) + (or magit-diff-visit-avoid-head-blob + (not goto-from)))) + (or (get-file-buffer file) + (find-file-noselect file)) + (magit-find-file-noselect (if (stringp rev) rev "HEAD") + file)))) + (if line + (with-current-buffer buf + (cond ((eq rev 'staged) + (setq line (magit-diff-visit--offset file nil line))) + ((and goto-worktree + (stringp rev)) + (setq line (magit-diff-visit--offset file rev line)))) + (list buf (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column col) + (point)))) + (list buf nil)))) + +(defun magit-diff-visit--hunk () + (when-let ((scope (magit-diff-scope))) + (let ((section (magit-current-section))) + (cl-case scope + ((file files) + (setq section (car (oref section children)))) + (list + (setq section (car (oref section children))) + (when section + (setq section (car (oref section children)))))) + (and + ;; Unmerged files appear in the list of staged changes + ;; but unlike in the list of unstaged changes no diffs + ;; are shown here. In that case `section' is nil. + section + ;; Currently the `hunk' type is also abused for file + ;; mode changes, which we are not interested in here. + ;; Such sections have no value. + (oref section value) + section)))) + +(defun magit-diff-visit--goto-from-p (section in-worktree) + (and magit-diff-visit-previous-blob + (not in-worktree) + (not (oref section combined)) + (not (< (point) (oref section content))) + (= (char-after (line-beginning-position)) ?-))) + +(defun magit-diff-hunk-line (section goto-from) + (save-excursion + (goto-char (line-beginning-position)) + (with-slots (content combined from-ranges from-range to-range) section + (when (< (point) content) + (goto-char content) + (re-search-forward "^[-+]")) + (+ (car (if goto-from from-range to-range)) + (let ((prefix (if combined (length from-ranges) 1)) + (target (point)) + (offset 0)) + (goto-char content) + (while (< (point) target) + (unless (string-match-p + (if goto-from "\\+" "-") + (buffer-substring (point) (+ (point) prefix))) + (cl-incf offset)) + (forward-line)) + offset))))) + +(defun magit-diff-hunk-column (section goto-from) + (if (or (< (point) + (oref section content)) + (and (not goto-from) + (= (char-after (line-beginning-position)) ?-))) + 0 + (max 0 (- (+ (current-column) 2) + (length (oref section value)))))) + +(defun magit-diff-visit--range-from (spec) + (cond ((consp spec) + (concat (cdr spec) "^")) + ((stringp spec) + (car (magit-split-range spec))) + (t + spec))) + +(defun magit-diff-visit--range-to (spec) + (if (symbolp spec) + spec + (let ((rev (if (consp spec) + (cdr spec) + (cdr (magit-split-range spec))))) + (if (and magit-diff-visit-avoid-head-blob + (magit-rev-head-p spec)) + 'unstaged + rev)))) + +(defun magit-diff-visit--offset (file rev line) + (let ((offset 0)) + (with-temp-buffer + (save-excursion + (magit-with-toplevel + (magit-git-insert "diff" rev "--" file))) + (catch 'found + (while (re-search-forward + "^@@ -\\([0-9]+\\),\\([0-9]+\\) \\+\\([0-9]+\\),\\([0-9]+\\) @@.*\n" + nil t) + (let ((from-beg (string-to-number (match-string 1))) + (from-len (string-to-number (match-string 2))) + ( to-len (string-to-number (match-string 4)))) + (if (<= from-beg line) + (if (< (+ from-beg from-len) line) + (cl-incf offset (- to-len from-len)) + (let ((rest (- line from-beg))) + (while (> rest 0) + (pcase (char-after) + (?\s (cl-decf rest)) + (?- (cl-decf offset) (cl-decf rest)) + (?+ (cl-incf offset))) + (forward-line)))) + (throw 'found nil)))))) + (+ line offset))) + +;;;; Scroll Commands + +(defun magit-diff-show-or-scroll-up () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer up. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll 'scroll-up)) + +(defun magit-diff-show-or-scroll-down () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer down. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll 'scroll-down)) + +(defun magit-diff-show-or-scroll (fn) + (let (rev cmd buf win) + (cond + (magit-blame-mode + (setq rev (oref (magit-current-blame-chunk) orig-rev)) + (setq cmd 'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + ((derived-mode-p 'git-rebase-mode) + (with-slots (action-type target) + (git-rebase-current-line) + (if (not (eq action-type 'commit)) + (user-error "No commit on this line") + (setq rev target) + (setq cmd 'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))))) + (t + (magit-section-case + (branch + (setq rev (magit-ref-maybe-qualify (oref it value))) + (setq cmd 'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (commit + (setq rev (oref it value)) + (setq cmd 'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (stash + (setq rev (oref it value)) + (setq cmd 'magit-stash-show) + (setq buf (magit-get-mode-buffer 'magit-stash-mode)))))) + (if rev + (if (and buf + (setq win (get-buffer-window buf)) + (with-current-buffer buf + (and (equal rev magit-buffer-revision) + (equal (magit-rev-parse rev) + magit-buffer-revision-hash)))) + (with-selected-window win + (condition-case nil + (funcall fn) + (error + (goto-char (pcase fn + (`scroll-up (point-min)) + (`scroll-down (point-max))))))) + (let ((magit-display-buffer-noselect t)) + (if (eq cmd 'magit-show-commit) + (apply #'magit-show-commit rev (magit-show-commit--arguments)) + (funcall cmd rev)))) + (call-interactively #'magit-show-commit)))) + +;;;; Section Commands + +(defun magit-section-cycle-diffs () + "Cycle visibility of diff-related sections in the current buffer." + (interactive) + (when-let ((sections + (cond ((derived-mode-p 'magit-status-mode) + (--mapcat + (when it + (when (oref it hidden) + (magit-section-show it)) + (oref it children)) + (list (magit-get-section '((staged) (status))) + (magit-get-section '((unstaged) (status)))))) + ((derived-mode-p 'magit-diff-mode) + (-filter #'magit-file-section-p + (oref magit-root-section children)))))) + (if (--any-p (oref it hidden) sections) + (dolist (s sections) + (magit-section-show s) + (magit-section-hide-children s)) + (let ((children (--mapcat (oref it children) sections))) + (cond ((and (--any-p (oref it hidden) children) + (--any-p (oref it children) children)) + (mapc 'magit-section-show-headings sections)) + ((-any-p 'magit-section-hidden-body children) + (mapc 'magit-section-show-children sections)) + (t + (mapc 'magit-section-hide sections))))))) + +;;; Diff Mode + +(defvar magit-diff-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + (define-key map (kbd "C-c C-d") 'magit-diff-while-committing) + (define-key map (kbd "C-c C-b") 'magit-go-backward) + (define-key map (kbd "C-c C-f") 'magit-go-forward) + (define-key map (kbd "SPC") 'scroll-up) + (define-key map (kbd "DEL") 'scroll-down) + (define-key map (kbd "j") 'magit-jump-to-diffstat-or-diff) + (define-key map [remap write-file] 'magit-patch-save) + map) + "Keymap for `magit-diff-mode'.") + +(define-derived-mode magit-diff-mode magit-mode "Magit Diff" + "Mode for looking at a Git diff. + +This mode is documented in info node `(magit)Diff Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-diff-mode-map}" + :group 'magit-diff + (hack-dir-local-variables-non-file-buffer) + (setq imenu-prev-index-position-function + 'magit-imenu--diff-prev-index-position-function) + (setq imenu-extract-index-name-function + 'magit-imenu--diff-extract-index-name-function)) + +(put 'magit-diff-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-diff-setup-buffer (range typearg args files &optional locked) + (require 'magit) + (magit-setup-buffer #'magit-diff-mode locked + (magit-buffer-range range) + (magit-buffer-typearg typearg) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files))) + +(defun magit-diff-refresh-buffer () + "Refresh the current `magit-diff-mode' buffer." + (magit-set-header-line-format + (if (equal magit-buffer-typearg "--no-index") + (apply #'format "Differences between %s and %s" magit-buffer-diff-files) + (concat (if magit-buffer-range + (if (string-match-p "\\(\\.\\.\\|\\^-\\)" + magit-buffer-range) + (format "Changes in %s" magit-buffer-range) + (format "Changes from %s to working tree" magit-buffer-range)) + (if (equal magit-buffer-typearg "--cached") + "Staged changes" + "Unstaged changes")) + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " in file " (car magit-buffer-diff-files))) + (_ (concat " in files " + (mapconcat #'identity magit-buffer-diff-files ", "))))))) + (setq magit-buffer-range-hashed + (and magit-buffer-range (magit-hash-range magit-buffer-range))) + (magit-insert-section (diffbuf) + (magit-run-section-hook 'magit-diff-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-diff-mode)) + (nconc (cond (magit-buffer-range + (delq nil (list magit-buffer-range magit-buffer-typearg))) + ((equal magit-buffer-typearg "--cached") + (list 'staged)) + (t + (list 'unstaged magit-buffer-typearg))) + (and magit-buffer-diff-files (cons "--" magit-buffer-diff-files)))) + +(defvar magit-file-section-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-j") 'magit-diff-visit-worktree-file) + (define-key map [C-return] 'magit-diff-visit-worktree-file) + (define-key map [remap magit-visit-thing] 'magit-diff-visit-file) + (define-key map [remap magit-delete-thing] 'magit-discard) + (define-key map [remap magit-revert-no-commit] 'magit-reverse) + (define-key map "a" 'magit-apply) + (define-key map "C" 'magit-commit-add-log) + (define-key map "s" 'magit-stage) + (define-key map "u" 'magit-unstage) + (define-key map "&" 'magit-do-async-shell-command) + (define-key map "\C-c\C-t" 'magit-diff-trace-definition) + (define-key map "\C-c\C-e" 'magit-diff-edit-hunk-commit) + map) + "Keymap for `file' sections.") + +(defvar magit-hunk-section-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-j") 'magit-diff-visit-worktree-file) + (define-key map [C-return] 'magit-diff-visit-worktree-file) + (define-key map [remap magit-visit-thing] 'magit-diff-visit-file) + (define-key map [remap magit-delete-thing] 'magit-discard) + (define-key map [remap magit-revert-no-commit] 'magit-reverse) + (define-key map "a" 'magit-apply) + (define-key map "C" 'magit-commit-add-log) + (define-key map "s" 'magit-stage) + (define-key map "u" 'magit-unstage) + (define-key map "&" 'magit-do-async-shell-command) + (define-key map "\C-c\C-t" 'magit-diff-trace-definition) + (define-key map "\C-c\C-e" 'magit-diff-edit-hunk-commit) + map) + "Keymap for `hunk' sections.") + +(defconst magit-diff-headline-re + (concat "^\\(@@@?\\|diff\\|Submodule\\|" + "\\* Unmerged path\\|merged\\|changed in both\\|" + "added in remote\\|removed in remote\\)")) + +(defconst magit-diff-statline-re + (concat "^ ?" + "\\(.*\\)" ; file + "\\( +| +\\)" ; separator + "\\([0-9]+\\|Bin\\(?: +[0-9]+ -> [0-9]+ bytes\\)?$\\) ?" + "\\(\\+*\\)" ; add + "\\(-*\\)$")) ; del + +(defvar magit-diff--reset-non-color-moved + (list + "-c" "color.diff.context=normal" + "-c" "color.diff.plain=normal" ; historical synonym for context + "-c" "color.diff.meta=normal" + "-c" "color.diff.frag=normal" + "-c" "color.diff.func=normal" + "-c" "color.diff.old=normal" + "-c" "color.diff.new=normal" + "-c" "color.diff.commit=normal" + "-c" "color.diff.whitespace=normal" + ;; "git-range-diff" does not support "--color-moved", so we don't + ;; need to reset contextDimmed, oldDimmed, newDimmed, contextBold, + ;; oldBold, and newBold. + )) + +(defun magit-insert-diff () + "Insert the diff into this `magit-diff-mode' buffer." + (magit--insert-diff + "diff" magit-buffer-range "-p" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-typearg + magit-buffer-diff-args "--" + magit-buffer-diff-files)) + +(defun magit--insert-diff (&rest args) + (declare (indent 0)) + (let ((magit-git-global-arguments + (remove "--literal-pathspecs" magit-git-global-arguments))) + (setq args (-flatten args)) + ;; As of Git 2.19.0, we need to generate diffs with + ;; --ita-visible-in-index so that `magit-stage' can work with + ;; intent-to-add files (see #4026). Cache the result for each + ;; repo to avoid a `git version' call for every diff insertion. + (when (pcase (magit-repository-local-get 'diff-ita-kludge-p 'unset) + (`unset + (let ((val (version<= "2.19.0" (magit-git-version)))) + (magit-repository-local-set 'diff-ita-kludge-p val) + val)) + (val val)) + (push "--ita-visible-in-index" (cdr args))) + (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) + (push "--color=always" (cdr args)) + (setq magit-git-global-arguments + (append magit-diff--reset-non-color-moved + magit-git-global-arguments))) + (magit-git-wash #'magit-diff-wash-diffs args))) + +(defun magit-diff-wash-diffs (args &optional limit) + (when (member "--show-signature" args) + (magit-diff-wash-signature)) + (when (member "--stat" args) + (magit-diff-wash-diffstat)) + (when (re-search-forward magit-diff-headline-re limit t) + (goto-char (line-beginning-position)) + (magit-wash-sequence (apply-partially 'magit-diff-wash-diff args)) + (insert ?\n))) + +(defun magit-jump-to-diffstat-or-diff () + "Jump to the diffstat or diff. +When point is on a file inside the diffstat section, then jump +to the respective diff section, otherwise jump to the diffstat +section or a child thereof." + (interactive) + (--if-let (magit-get-section + (append (magit-section-case + ([file diffstat] `((file . ,(oref it value)))) + (file `((file . ,(oref it value)) (diffstat))) + (t '((diffstat)))) + (magit-section-ident magit-root-section))) + (magit-section-goto it) + (user-error "No diffstat in this buffer"))) + +(defun magit-diff-wash-signature () + (when (looking-at "^gpg: ") + (magit-insert-section (signature) + (while (looking-at "^gpg: ") + (forward-line)) + (insert "\n")))) + +(defun magit-diff-wash-diffstat () + (let (heading (beg (point))) + (when (re-search-forward "^ ?\\([0-9]+ +files? change[^\n]*\n\\)" nil t) + (setq heading (match-string 1)) + (magit-delete-match) + (goto-char beg) + (magit-insert-section (diffstat) + (insert (propertize heading 'font-lock-face 'magit-diff-file-heading)) + (magit-insert-heading) + (let (files) + (while (looking-at "^[-0-9]+\t[-0-9]+\t\\(.+\\)$") + (push (magit-decode-git-path + (let ((f (match-string 1))) + (cond + ((string-match "\\`\\([^{]+\\){\\(.+\\) => \\(.+\\)}\\'" f) + (concat (match-string 1 f) + (match-string 3 f))) + ((string-match " => " f) + (substring f (match-end 0))) + (t f)))) + files) + (magit-delete-line)) + (setq files (nreverse files)) + (while (looking-at magit-diff-statline-re) + (magit-bind-match-strings (file sep cnt add del) nil + (magit-delete-line) + (when (string-match " +$" file) + (setq sep (concat (match-string 0 file) sep)) + (setq file (substring file 0 (match-beginning 0)))) + (let ((le (length file)) ld) + (setq file (magit-decode-git-path file)) + (setq ld (length file)) + (when (> le ld) + (setq sep (concat (make-string (- le ld) ?\s) sep)))) + (magit-insert-section (file (pop files)) + (insert (propertize file 'font-lock-face 'magit-filename) + sep cnt " ") + (when add + (insert (propertize add 'font-lock-face + 'magit-diffstat-added))) + (when del + (insert (propertize del 'font-lock-face + 'magit-diffstat-removed))) + (insert "\n"))))) + (if (looking-at "^$") (forward-line) (insert "\n")))))) + +(defun magit-diff-wash-diff (args) + (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) + (require 'ansi-color) + (ansi-color-apply-on-region (point-min) (point-max))) + (cond + ((looking-at "^Submodule") + (magit-diff-wash-submodule)) + ((looking-at "^\\* Unmerged path \\(.*\\)") + (let ((file (magit-decode-git-path (match-string 1)))) + (magit-delete-line) + (unless (and (derived-mode-p 'magit-status-mode) + (not (member "--cached" args))) + (magit-insert-section (file file) + (insert (propertize + (format "unmerged %s%s" file + (pcase (cddr (car (magit-file-status file))) + (`(?D ?D) " (both deleted)") + (`(?D ?U) " (deleted by us)") + (`(?U ?D) " (deleted by them)") + (`(?A ?A) " (both added)") + (`(?A ?U) " (added by us)") + (`(?U ?A) " (added by them)") + (`(?U ?U) ""))) + 'font-lock-face 'magit-diff-file-heading)) + (insert ?\n)))) + t) + ((looking-at (concat "^\\(merged\\|changed in both\\|" + "added in remote\\|removed in remote\\)")) + (let ((status (pcase (match-string 1) + ("merged" "merged") + ("changed in both" "conflict") + ("added in remote" "new file") + ("removed in remote" "deleted"))) + file orig base modes) + (magit-delete-line) + (while (looking-at + "^ \\([^ ]+\\) +[0-9]\\{6\\} \\([a-z0-9]\\{40\\}\\) \\(.+\\)$") + (magit-bind-match-strings (side _blob name) nil + (pcase side + ("result" (setq file name)) + ("our" (setq orig name)) + ("their" (setq file name)) + ("base" (setq base name)))) + (magit-delete-line)) + (when orig (setq orig (magit-decode-git-path orig))) + (when file (setq file (magit-decode-git-path file))) + (magit-diff-insert-file-section (or file base) orig status modes nil))) + ((looking-at + "^diff --\\(?:\\(git\\) \\(?:\\(.+?\\) \\2\\)?\\|\\(cc\\|combined\\) \\(.+\\)\\)") + (let ((status (cond ((equal (match-string 1) "git") "modified") + ((derived-mode-p 'magit-revision-mode) "resolved") + (t "unmerged"))) + (file (or (match-string 2) (match-string 4))) + (beg (point)) + orig header modes) + (save-excursion + (forward-line 1) + (setq header (buffer-substring + beg (if (re-search-forward magit-diff-headline-re nil t) + (match-beginning 0) + (point-max))))) + (magit-delete-line) + (while (not (or (eobp) (looking-at magit-diff-headline-re))) + (if (looking-at "^old mode \\([^\n]+\\)\nnew mode \\([^\n]+\\)\n") + (progn (setq modes (match-string 0)) + (magit-delete-match)) + (cond + ((looking-at "^--- \\([^/].*?\\)\t?$") ; i.e. not /dev/null + (setq orig (match-string 1))) + ((looking-at "^\\+\\+\\+ \\([^/].*?\\)\t?$") + (setq file (match-string 1))) + ((looking-at "^\\(copy\\|rename\\) from \\(.+\\)$") + (setq orig (match-string 2))) + ((looking-at "^\\(copy\\|rename\\) to \\(.+\\)$") + (setq file (match-string 2)) + (setq status (if (equal (match-string 1) "copy") "new file" "renamed"))) + ((looking-at "^\\(new file\\|deleted\\)") + (setq status (match-string 1)))) + (magit-delete-line))) + (when orig + (setq orig (magit-decode-git-path orig))) + (setq file (magit-decode-git-path file)) + ;; KLUDGE `git-log' ignores `--no-prefix' when `-L' is used. + (when (and (derived-mode-p 'magit-log-mode) + (--first (string-match-p "\\`-L" it) magit-buffer-log-args)) + (setq file (substring file 2)) + (when orig + (setq orig (substring orig 2)))) + (magit-diff-insert-file-section file orig status modes header))))) + +(defun magit-diff-insert-file-section (file orig status modes header) + (magit-insert-section section + (file file (or (equal status "deleted") + (derived-mode-p 'magit-status-mode))) + (insert (propertize (format "%-10s %s\n" status + (if (or (not orig) (equal orig file)) + file + (format "%s -> %s" orig file))) + 'font-lock-face 'magit-diff-file-heading)) + (magit-insert-heading) + (unless (equal orig file) + (oset section source orig)) + (oset section header header) + (when modes + (magit-insert-section (hunk) + (insert modes) + (magit-insert-heading))) + (magit-wash-sequence #'magit-diff-wash-hunk))) + +(defun magit-diff-wash-submodule () + ;; See `show_submodule_summary' in submodule.c and "this" commit. + (when (looking-at "^Submodule \\([^ ]+\\)") + (let ((module (match-string 1)) + untracked modified) + (when (looking-at "^Submodule [^ ]+ contains untracked content$") + (magit-delete-line) + (setq untracked t)) + (when (looking-at "^Submodule [^ ]+ contains modified content$") + (magit-delete-line) + (setq modified t)) + (cond + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ :]+\\)\\( (rewind)\\)?:$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module range rewind) nil + (magit-delete-line) + (while (looking-at "^ \\([<>]\\) \\(.+\\)$") + (magit-delete-line)) + (when rewind + (setq range (replace-regexp-in-string "[^.]\\(\\.\\.\\)[^.]" + "..." range t t 1))) + (magit-insert-section (magit-module-section module t) + (magit-insert-heading + (propertize (concat "modified " module) + 'font-lock-face 'magit-diff-file-heading) + " (" + (cond (rewind "rewind") + ((string-match-p "\\.\\.\\." range) "non-ff") + (t "new commits")) + (and (or modified untracked) + (concat ", " + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content")) + ")") + (let ((default-directory + (file-name-as-directory + (expand-file-name module (magit-toplevel))))) + (magit-git-wash (apply-partially 'magit-log-wash-log 'module) + "log" "--oneline" "--left-right" range) + (delete-char -1))))) + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ ]+\\) (\\([^)]+\\))$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module _range msg) nil + (magit-delete-line) + (magit-insert-section (magit-module-section module) + (magit-insert-heading + (propertize (concat "submodule " module) + 'font-lock-face 'magit-diff-file-heading) + " (" msg ")")))) + (t + (magit-insert-section (magit-module-section module) + (magit-insert-heading + (propertize (concat "modified " module) + 'font-lock-face 'magit-diff-file-heading) + " (" + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content)"))))))) + +(defun magit-diff-wash-hunk () + (when (looking-at "^@\\{2,\\} \\(.+?\\) @\\{2,\\}\\(?: \\(.*\\)\\)?") + (let* ((heading (match-string 0)) + (ranges (mapcar (lambda (str) + (mapcar (lambda (n) (string-to-number n)) + (split-string (substring str 1) ","))) + (split-string (match-string 1)))) + (about (match-string 2)) + (combined (= (length ranges) 3)) + (value (cons about ranges))) + (magit-delete-line) + (magit-insert-section section (hunk value) + (insert (propertize (concat heading "\n") + 'font-lock-face 'magit-diff-hunk-heading)) + (magit-insert-heading) + (while (not (or (eobp) (looking-at "^[^-+\s\\]"))) + (forward-line)) + (oset section end (point)) + (oset section washer 'magit-diff-paint-hunk) + (oset section combined combined) + (if combined + (oset section from-ranges (butlast ranges)) + (oset section from-range (car ranges))) + (oset section to-range (car (last ranges))) + (oset section about about))) + t)) + +(defun magit-diff-expansion-threshold (section) + "Keep new diff sections collapsed if washing takes too long." + (and (magit-file-section-p section) + (> (float-time (time-subtract (current-time) magit-refresh-start-time)) + magit-diff-expansion-threshold) + 'hide)) + +(add-hook 'magit-section-set-visibility-hook #'magit-diff-expansion-threshold) + +;;; Revision Mode + +(define-derived-mode magit-revision-mode magit-diff-mode "Magit Rev" + "Mode for looking at a Git commit. + +This mode is documented in info node `(magit)Revision Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-revision-mode-map}" + :group 'magit-revision + (hack-dir-local-variables-non-file-buffer)) + +(put 'magit-revision-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-revision-setup-buffer (rev args files) + (magit-setup-buffer #'magit-revision-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files))) + +(defun magit-revision-refresh-buffer () + (magit-set-header-line-format + (concat (capitalize (magit-object-type magit-buffer-revision)) + " " magit-buffer-revision + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " limited to file " (car magit-buffer-diff-files))) + (_ (concat " limited to files " + (mapconcat #'identity magit-buffer-diff-files ", ")))))) + (setq magit-buffer-revision-hash (magit-rev-parse magit-buffer-revision)) + (magit-insert-section (commitbuf) + (magit-run-section-hook 'magit-revision-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-revision-mode)) + (cons magit-buffer-revision magit-buffer-diff-files)) + +(defun magit-insert-revision-diff () + "Insert the diff into this `magit-revision-mode' buffer." + (magit--insert-diff + "show" "-p" "--cc" "--format=" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-diff-args + (concat magit-buffer-revision "^{commit}") + "--" magit-buffer-diff-files)) + +(defun magit-insert-revision-tag () + "Insert tag message and headers into a revision buffer. +This function only inserts anything when `magit-show-commit' is +called with a tag as argument, when that is called with a commit +or a ref which is not a branch, then it inserts nothing." + (when (equal (magit-object-type magit-buffer-revision) "tag") + (magit-insert-section (taginfo) + (let ((beg (point))) + ;; "git verify-tag -v" would output what we need, but the gpg + ;; output is send to stderr and we have no control over the + ;; order in which stdout and stderr are inserted, which would + ;; make parsing hard. We are forced to use "git cat-file tag" + ;; instead, which inserts the signature instead of verifying + ;; it. We remove that later and then insert the verification + ;; output using "git verify-tag" (without the "-v"). + (magit-git-insert "cat-file" "tag" magit-buffer-revision) + (goto-char beg) + (forward-line 3) + (delete-region beg (point))) + (looking-at "^tagger \\([^<]+\\) <\\([^>]+\\)") + (let ((heading (format "Tagger: %s <%s>" + (match-string 1) + (match-string 2)))) + (magit-delete-line) + (insert (propertize heading 'font-lock-face + 'magit-section-secondary-heading))) + (magit-insert-heading) + (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) + (progn + (let ((beg (match-beginning 0))) + (re-search-forward "-----END PGP SIGNATURE-----") + (delete-region beg (point))) + (insert ?\n) + (process-file magit-git-executable nil t nil + "verify-tag" magit-buffer-revision)) + (goto-char (point-max))) + (insert ?\n)))) + +(defvar magit-commit-message-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-show-commit) + map) + "Keymap for `commit-message' sections.") + +(defun magit-insert-revision-message () + "Insert the commit message into a revision buffer." + (magit-insert-section section (commit-message) + (oset section heading-highlight-face 'magit-diff-revision-summary-highlight) + (let ((beg (point)) + (rev magit-buffer-revision)) + (insert (with-temp-buffer + (magit-rev-insert-format "%B" rev) + (magit-revision--wash-message))) + (if (= (point) (+ beg 2)) + (progn (backward-delete-char 2) + (insert "(no message)\n")) + (goto-char beg) + (save-excursion + (while (search-forward "\r\n" nil t) ; Remove trailing CRs. + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + (when magit-revision-fill-summary-line + (let ((fill-column (min magit-revision-fill-summary-line + (window-width)))) + (fill-region (point) (line-end-position)))) + (when magit-revision-use-hash-sections + (save-excursion + (while (not (eobp)) + (re-search-forward "\\_<" nil 'move) + (let ((beg (point))) + (re-search-forward "\\_>" nil t) + (when (> (point) beg) + (let ((text (buffer-substring-no-properties beg (point)))) + (when (pcase magit-revision-use-hash-sections + (`quickest ; false negatives and positives + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (string-match-p "[a-z]" text))) + (`quicker ; false negatives (number-less hashes) + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (magit-commit-p text))) + (`quick ; false negatives (short hashes) + (and (>= (length text) 7) + (magit-commit-p text))) + (`slow + (magit-commit-p text))) + (put-text-property beg (point) + 'font-lock-face 'magit-hash) + (let ((end (point))) + (goto-char beg) + (magit-insert-section (commit text) + (goto-char end)))))))))) + (save-excursion + (forward-line) + (magit--add-face-text-property + beg (point) 'magit-diff-revision-summary) + (magit-insert-heading)) + (when magit-diff-highlight-keywords + (save-excursion + (while (re-search-forward "\\[[^[]*\\]" nil t) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (put-text-property + beg end 'font-lock-face + (if-let ((face (get-text-property beg 'font-lock-face))) + (list face 'magit-keyword) + 'magit-keyword)))))) + (goto-char (point-max)))))) + +(defun magit-insert-revision-notes () + "Insert commit notes into a revision buffer." + (let* ((var "core.notesRef") + (def (or (magit-get var) "refs/notes/commits"))) + (dolist (ref (or (magit-list-active-notes-refs))) + (magit-insert-section section (notes ref (not (equal ref def))) + (oset section heading-highlight-face 'magit-diff-hunk-heading-highlight) + (let ((beg (point)) + (rev magit-buffer-revision)) + (insert (with-temp-buffer + (magit-git-insert "-c" (concat "core.notesRef=" ref) + "notes" "show" rev) + (magit-revision--wash-message))) + (if (= (point) beg) + (magit-cancel-section) + (goto-char beg) + (end-of-line) + (insert (format " (%s)" + (propertize (if (string-prefix-p "refs/notes/" ref) + (substring ref 11) + ref) + 'font-lock-face 'magit-refname))) + (forward-char) + (magit--add-face-text-property beg (point) 'magit-diff-hunk-heading) + (magit-insert-heading) + (goto-char (point-max)) + (insert ?\n))))))) + +(defun magit-revision--wash-message () + (let ((major-mode 'git-commit-mode)) + (hack-dir-local-variables) + (hack-local-variables-apply)) + (unless (memq git-commit-major-mode '(nil text-mode)) + (funcall git-commit-major-mode) + (font-lock-ensure)) + (buffer-string)) + +(defun magit-insert-revision-headers () + "Insert headers about the commit into a revision buffer." + (magit-insert-section (headers) + (--when-let (magit-rev-format "%D" magit-buffer-revision "--decorate=full") + (insert (magit-format-ref-labels it) ?\s)) + (insert (propertize + (magit-rev-parse (concat magit-buffer-revision "^{commit}")) + 'font-lock-face 'magit-hash)) + (magit-insert-heading) + (let ((beg (point))) + (magit-rev-insert-format magit-revision-headers-format + magit-buffer-revision) + (magit-insert-revision-gravatars magit-buffer-revision beg)) + (when magit-revision-insert-related-refs + (dolist (parent (magit-commit-parents magit-buffer-revision)) + (magit-insert-section (commit parent) + (let ((line (magit-rev-format "%h %s" parent))) + (string-match "^\\([^ ]+\\) \\(.*\\)" line) + (magit-bind-match-strings (hash msg) line + (insert "Parent: ") + (insert (propertize hash 'font-lock-face 'magit-hash)) + (insert " " msg "\n"))))) + (magit--insert-related-refs + magit-buffer-revision "--merged" "Merged" + (eq magit-revision-insert-related-refs 'all)) + (magit--insert-related-refs + magit-buffer-revision "--contains" "Contained" + (eq magit-revision-insert-related-refs '(all mixed))) + (when-let ((follows (magit-get-current-tag magit-buffer-revision t))) + (let ((tag (car follows)) + (cnt (cadr follows))) + (magit-insert-section (tag tag) + (insert + (format "Follows: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-branch-local)))))) + (when-let ((precedes (magit-get-next-tag magit-buffer-revision t))) + (let ((tag (car precedes)) + (cnt (cadr precedes))) + (magit-insert-section (tag tag) + (insert (format "Precedes: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-tag)))))) + (insert ?\n)))) + +(defun magit--insert-related-refs (rev arg title remote) + (when-let ((refs (magit-list-related-branches arg rev (and remote "-a")))) + (insert title ":" (make-string (- 10 (length title)) ?\s)) + (dolist (branch refs) + (if (<= (+ (current-column) 1 (length branch)) + (window-width)) + (insert ?\s) + (insert ?\n (make-string 12 ?\s))) + (magit-insert-section (branch branch) + (insert (propertize branch 'font-lock-face + (if (string-prefix-p "remotes/" branch) + 'magit-branch-remote + 'magit-branch-local))))) + (insert ?\n))) + +(defun magit-insert-revision-gravatars (rev beg) + (when (and magit-revision-show-gravatars + (window-system)) + (require 'gravatar) + (pcase-let ((`(,author . ,committer) + (pcase magit-revision-show-gravatars + (`t '("^Author: " . "^Commit: ")) + (`author '("^Author: " . nil)) + (`committer '(nil . "^Commit: ")) + (_ magit-revision-show-gravatars)))) + (--when-let (and author (magit-rev-format "%aE" rev)) + (magit-insert-revision-gravatar beg rev it author)) + (--when-let (and committer (magit-rev-format "%cE" rev)) + (magit-insert-revision-gravatar beg rev it committer))))) + +(defun magit-insert-revision-gravatar (beg rev email regexp) + (save-excursion + (goto-char beg) + (when (re-search-forward regexp nil t) + (when-let ((window (get-buffer-window))) + (let* ((column (length (match-string 0))) + (font-obj (query-font (font-at (point) window))) + (size (* 2 (+ (aref font-obj 4) + (aref font-obj 5)))) + (align-to (+ column + (ceiling (/ size (aref font-obj 7) 1.0)) + 1)) + (gravatar-size (- size 2))) + (ignore-errors ; service may be unreachable + (gravatar-retrieve email 'magit-insert-revision-gravatar-cb + (list rev (point-marker) align-to column)))))))) + +(defun magit-insert-revision-gravatar-cb (image rev marker align-to column) + (unless (eq image 'error) + (when-let ((buffer (marker-buffer marker))) + (with-current-buffer buffer + (save-excursion + (goto-char marker) + ;; The buffer might display another revision by now or + ;; it might have been refreshed, in which case another + ;; process might already have inserted the image. + (when (and (equal rev magit-buffer-revision) + (not (eq (car-safe + (car-safe + (get-text-property (point) 'display))) + 'image))) + (let ((top `((,@image :ascent center :relief 1) + (slice 0.0 0.0 1.0 0.5))) + (bot `((,@image :ascent center :relief 1) + (slice 0.0 0.5 1.0 1.0))) + (align `((space :align-to ,align-to)))) + (when magit-revision-use-gravatar-kludge + (cl-rotatef top bot)) + (let ((inhibit-read-only t)) + (insert (propertize " " 'display top)) + (insert (propertize " " 'display align)) + (forward-line) + (forward-char column) + (insert (propertize " " 'display bot)) + (insert (propertize " " 'display align)))))))))) + +;;; Merge-Preview Mode + +(define-derived-mode magit-merge-preview-mode magit-diff-mode "Magit Merge" + "Mode for previewing a merge." + :group 'magit-diff + (hack-dir-local-variables-non-file-buffer)) + +(put 'magit-merge-preview-mode 'magit-diff-default-arguments + '("--no-ext-diff")) + +(defun magit-merge-preview-setup-buffer (rev) + (magit-setup-buffer #'magit-merge-preview-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)))) + +(defun magit-merge-preview-refresh-buffer () + (let* ((branch (magit-get-current-branch)) + (head (or branch (magit-rev-verify "HEAD")))) + (magit-set-header-line-format (format "Preview merge of %s into %s" + magit-buffer-revision + (or branch "HEAD"))) + (magit-insert-section (diffbuf) + (magit--insert-diff + "merge-tree" (magit-git-string "merge-base" head magit-buffer-revision) + head magit-buffer-revision)))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-merge-preview-mode)) + magit-buffer-revision) + +;;; Diff Sections + +(defun magit-hunk-set-window-start (section) + "When SECTION is a `hunk', ensure that its beginning is visible. +It the SECTION has a different type, then do nothing." + (when (magit-hunk-section-p section) + (magit-section-set-window-start section))) + +(add-hook 'magit-section-movement-hook #'magit-hunk-set-window-start) + +(defun magit-hunk-goto-successor (section arg) + (and (magit-hunk-section-p section) + (when-let ((parent (magit-get-section + (magit-section-ident + (oref section parent))))) + (let* ((children (oref parent children)) + (siblings (magit-section-siblings section 'prev)) + (previous (nth (length siblings) children))) + (if (not arg) + (--when-let (or previous (car (last children))) + (magit-section-goto it) + t) + (when previous + (magit-section-goto previous)) + (if (and (stringp arg) + (re-search-forward arg (oref parent end) t)) + (goto-char (match-beginning 0)) + (goto-char (oref (car (last children)) end)) + (forward-line -1) + (while (looking-at "^ ") (forward-line -1)) + (while (looking-at "^[-+]") (forward-line -1)) + (forward-line))))))) + +(add-hook 'magit-section-goto-successor-hook #'magit-hunk-goto-successor) + +(defvar magit-unstaged-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-diff-unstaged) + (define-key map [remap magit-delete-thing] 'magit-discard) + (define-key map "s" 'magit-stage) + (define-key map "u" 'magit-unstage) + map) + "Keymap for the `unstaged' section.") + +(magit-define-section-jumper magit-jump-to-unstaged "Unstaged changes" unstaged) + +(defun magit-insert-unstaged-changes () + "Insert section showing unstaged changes." + (magit-insert-section (unstaged) + (magit-insert-heading "Unstaged changes:") + (magit--insert-diff + "diff" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files))) + +(defvar magit-staged-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-diff-staged) + (define-key map [remap magit-delete-thing] 'magit-discard) + (define-key map [remap magit-revert-no-commit] 'magit-reverse) + (define-key map "s" 'magit-stage) + (define-key map "u" 'magit-unstage) + map) + "Keymap for the `staged' section.") + +(magit-define-section-jumper magit-jump-to-staged "Staged changes" staged) + +(defun magit-insert-staged-changes () + "Insert section showing staged changes." + ;; Avoid listing all files as deleted when visiting a bare repo. + (unless (magit-bare-repo-p) + (magit-insert-section (staged) + (magit-insert-heading "Staged changes:") + (magit--insert-diff + "diff" "--cached" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files)))) + +;;; Diff Type + +(defun magit-diff-type (&optional section) + "Return the diff type of SECTION. + +The returned type is one of the symbols `staged', `unstaged', +`committed', or `undefined'. This type serves a similar purpose +as the general type common to all sections (which is stored in +the `type' slot of the corresponding `magit-section' struct) but +takes additional information into account. When the SECTION +isn't related to diffs and the buffer containing it also isn't +a diff-only buffer, then return nil. + +Currently the type can also be one of `tracked' and `untracked' +but these values are not handled explicitly everywhere they +should be and a possible fix could be to just return nil here. + +The section has to be a `diff' or `hunk' section, or a section +whose children are of type `diff'. If optional SECTION is nil, +return the diff type for the current section. In buffers whose +major mode is `magit-diff-mode' SECTION is ignored and the type +is determined using other means. In `magit-revision-mode' +buffers the type is always `committed'. + +Do not confuse this with `magit-diff-scope' (which see)." + (--when-let (or section (magit-current-section)) + (cond ((derived-mode-p 'magit-revision-mode 'magit-stash-mode) 'committed) + ((derived-mode-p 'magit-diff-mode) + (let ((range magit-buffer-range) + (const magit-buffer-typearg)) + (cond ((equal const "--no-index") 'undefined) + ((or (not range) + (magit-rev-eq range "HEAD")) + (if (equal const "--cached") + 'staged + 'unstaged)) + ((equal const "--cached") + (if (magit-rev-head-p range) + 'staged + 'undefined)) ; i.e. committed and staged + (t 'committed)))) + ((derived-mode-p 'magit-status-mode) + (let ((stype (oref it type))) + (if (memq stype '(staged unstaged tracked untracked)) + stype + (pcase stype + ((or `file `module) + (let* ((parent (oref it parent)) + (type (oref parent type))) + (if (memq type '(file module)) + (magit-diff-type parent) + type))) + (`hunk (-> it + (oref parent) + (oref parent) + (oref type))))))) + ((derived-mode-p 'magit-log-mode) + (if (or (and (magit-section-match 'commit section) + (oref section children)) + (magit-section-match [* file commit] section)) + 'committed + 'undefined)) + (t 'undefined)))) + +(cl-defun magit-diff-scope (&optional (section nil ssection) strict) + "Return the diff scope of SECTION or the selected section(s). + +A diff's \"scope\" describes what part of a diff is selected, it is +a symbol, one of `region', `hunk', `hunks', `file', `files', or +`list'. Do not confuse this with the diff \"type\", as returned by +`magit-diff-type'. + +If optional SECTION is non-nil, then return the scope of that, +ignoring the sections selected by the region. Otherwise return +the scope of the current section, or if the region is active and +selects a valid group of diff related sections, the type of these +sections, i.e. `hunks' or `files'. If SECTION, or if that is nil +the current section, is a `hunk' section; and the region region +starts and ends inside the body of a that section, then the type +is `region'. If the region is empty after a mouse click, then +`hunk' is returned instead of `region'. + +If optional STRICT is non-nil, then return nil if the diff type of +the section at point is `untracked' or the section at point is not +actually a `diff' but a `diffstat' section." + (let ((siblings (and (not ssection) (magit-region-sections nil t)))) + (setq section (or section (car siblings) (magit-current-section))) + (when (and section + (or (not strict) + (and (not (eq (magit-diff-type section) 'untracked)) + (not (eq (--when-let (oref section parent) + (oref it type)) + 'diffstat))))) + (pcase (list (oref section type) + (and siblings t) + (magit-diff-use-hunk-region-p) + ssection) + (`(hunk nil t ,_) + (if (magit-section-internal-region-p section) 'region 'hunk)) + (`(hunk t t nil) 'hunks) + (`(hunk ,_ ,_ ,_) 'hunk) + (`(file t t nil) 'files) + (`(file ,_ ,_ ,_) 'file) + (`(module t t nil) 'files) + (`(module ,_ ,_ ,_) 'file) + (`(,(or `staged `unstaged `untracked) + nil ,_ ,_) 'list))))) + +(defun magit-diff-use-hunk-region-p () + (and (region-active-p) + ;; TODO implement this from first principals + ;; currently it's trial-and-error + (not (and (or (eq this-command 'mouse-drag-region) + (eq last-command 'mouse-drag-region) + ;; When another window was previously + ;; selected then the last-command is + ;; some byte-code function. + (byte-code-function-p last-command)) + (eq (region-end) (region-beginning)))))) + +;;; Diff Highlight + +(add-hook 'magit-section-unhighlight-hook #'magit-diff-unhighlight) +(add-hook 'magit-section-highlight-hook #'magit-diff-highlight) + +(defun magit-diff-unhighlight (section selection) + "Remove the highlighting of the diff-related SECTION." + (when (magit-hunk-section-p section) + (magit-diff-paint-hunk section selection nil) + t)) + +(defun magit-diff-highlight (section selection) + "Highlight the diff-related SECTION. +If SECTION is not a diff-related section, then do nothing and +return nil. If SELECTION is non-nil, then it is a list of sections +selected by the region, including SECTION. All of these sections +are highlighted." + (if (and (magit-section-match 'commit section) + (oref section children)) + (progn (if selection + (dolist (section selection) + (magit-diff-highlight-list section selection)) + (magit-diff-highlight-list section)) + t) + (when-let ((scope (magit-diff-scope section t))) + (cond ((eq scope 'region) + (magit-diff-paint-hunk section selection t)) + (selection + (dolist (section selection) + (magit-diff-highlight-recursive section selection))) + (t + (magit-diff-highlight-recursive section))) + t))) + +(defun magit-diff-highlight-recursive (section &optional selection) + (pcase (magit-diff-scope section) + (`list (magit-diff-highlight-list section selection)) + (`file (magit-diff-highlight-file section selection)) + (`hunk (magit-diff-highlight-heading section selection) + (magit-diff-paint-hunk section selection t)) + (_ (magit-section-highlight section nil)))) + +(defun magit-diff-highlight-list (section &optional selection) + (let ((beg (oref section start)) + (cnt (oref section content)) + (end (oref section end))) + (when (or (eq this-command 'mouse-drag-region) + (not selection)) + (unless (and (region-active-p) + (<= (region-beginning) beg)) + (magit-section-make-overlay beg cnt 'magit-section-highlight)) + (unless (oref section hidden) + (dolist (child (oref section children)) + (when (or (eq this-command 'mouse-drag-region) + (not (and (region-active-p) + (<= (region-beginning) + (oref child start))))) + (magit-diff-highlight-recursive child selection))))) + (when magit-diff-highlight-hunk-body + (magit-section-make-overlay (1- end) end 'magit-section-highlight)))) + +(defun magit-diff-highlight-file (section &optional selection) + (magit-diff-highlight-heading section selection) + (unless (oref section hidden) + (dolist (child (oref section children)) + (magit-diff-highlight-recursive child selection)))) + +(defun magit-diff-highlight-heading (section &optional selection) + (magit-section-make-overlay + (oref section start) + (or (oref section content) + (oref section end)) + (pcase (list (oref section type) + (and (member section selection) + (not (eq this-command 'mouse-drag-region)))) + (`(file t) 'magit-diff-file-heading-selection) + (`(file nil) 'magit-diff-file-heading-highlight) + (`(module t) 'magit-diff-file-heading-selection) + (`(module nil) 'magit-diff-file-heading-highlight) + (`(hunk t) 'magit-diff-hunk-heading-selection) + (`(hunk nil) 'magit-diff-hunk-heading-highlight)))) + +;;; Hunk Paint + +(cl-defun magit-diff-paint-hunk + (section &optional selection + (highlight (magit-section-selected-p section selection))) + (let (paint) + (unless magit-diff-highlight-hunk-body + (setq highlight nil)) + (cond (highlight + (unless (oref section hidden) + (add-to-list 'magit-section-highlighted-sections section) + (cond ((memq section magit-section-unhighlight-sections) + (setq magit-section-unhighlight-sections + (delq section magit-section-unhighlight-sections))) + (magit-diff-highlight-hunk-body + (setq paint t))))) + (t + (cond ((and (oref section hidden) + (memq section magit-section-unhighlight-sections)) + (add-to-list 'magit-section-highlighted-sections section) + (setq magit-section-unhighlight-sections + (delq section magit-section-unhighlight-sections))) + (t + (setq paint t))))) + (when paint + (save-excursion + (goto-char (oref section start)) + (let ((end (oref section end)) + (merging (looking-at "@@@")) + (diff-type (magit-diff-type)) + (stage nil) + (tab-width (magit-diff-tab-width + (magit-section-parent-value section)))) + (forward-line) + (while (< (point) end) + (when (and magit-diff-hide-trailing-cr-characters + (char-equal ?\r (char-before (line-end-position)))) + (put-text-property (1- (line-end-position)) (line-end-position) + 'invisible t)) + (put-text-property + (point) (1+ (line-end-position)) 'font-lock-face + (cond + ((looking-at "^\\+\\+?\\([<=|>]\\)\\{7\\}") + (setq stage (pcase (list (match-string 1) highlight) + (`("<" nil) 'magit-diff-our) + (`("<" t) 'magit-diff-our-highlight) + (`("|" nil) 'magit-diff-base) + (`("|" t) 'magit-diff-base-highlight) + (`("=" nil) 'magit-diff-their) + (`("=" t) 'magit-diff-their-highlight) + (`(">" nil) nil))) + 'magit-diff-conflict-heading) + ((looking-at (if merging "^\\(\\+\\| \\+\\)" "^\\+")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'added diff-type) + (or stage + (if highlight 'magit-diff-added-highlight 'magit-diff-added))) + ((looking-at (if merging "^\\(-\\| -\\)" "^-")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'removed diff-type) + (if highlight 'magit-diff-removed-highlight 'magit-diff-removed)) + (t + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'context diff-type) + (if highlight 'magit-diff-context-highlight 'magit-diff-context)))) + (forward-line)))))) + (magit-diff-update-hunk-refinement section)) + +(defvar magit-diff--tab-width-cache nil) + +(defun magit-diff-tab-width (file) + (setq file (expand-file-name file)) + (cl-flet ((cache (value) + (let ((elt (assoc file magit-diff--tab-width-cache))) + (if elt + (setcdr elt value) + (setq magit-diff--tab-width-cache + (cons (cons file value) + magit-diff--tab-width-cache)))) + value)) + (cond + ((not magit-diff-adjust-tab-width) + tab-width) + ((--when-let (find-buffer-visiting file) + (cache (buffer-local-value 'tab-width it)))) + ((--when-let (assoc file magit-diff--tab-width-cache) + (or (cdr it) + tab-width))) + ((or (eq magit-diff-adjust-tab-width 'always) + (and (numberp magit-diff-adjust-tab-width) + (>= magit-diff-adjust-tab-width + (nth 7 (file-attributes file))))) + (cache (buffer-local-value 'tab-width (find-file-noselect file)))) + (t + (cache nil) + tab-width)))) + +(defun magit-diff-paint-tab (merging width) + (save-excursion + (forward-char (if merging 2 1)) + (while (= (char-after) ?\t) + (put-text-property (point) (1+ (point)) + 'display (list (list 'space :width width))) + (forward-char)))) + +(defun magit-diff-paint-whitespace (merging line-type diff-type) + (when (and magit-diff-paint-whitespace + (or (not (memq magit-diff-paint-whitespace '(uncommitted status))) + (memq diff-type '(staged unstaged))) + (cl-case line-type + (added t) + (removed (memq magit-diff-paint-whitespace-lines '(all both))) + (context (memq magit-diff-paint-whitespace-lines '(all))))) + (let ((prefix (if merging "^[-\\+\s]\\{2\\}" "^[-\\+\s]")) + (indent + (if (local-variable-p 'magit-diff-highlight-indentation) + magit-diff-highlight-indentation + (setq-local + magit-diff-highlight-indentation + (cdr (--first (string-match-p (car it) default-directory) + (nreverse + (default-value + 'magit-diff-highlight-indentation)))))))) + (when (and magit-diff-highlight-trailing + (looking-at (concat prefix ".*?\\([ \t]+\\)$"))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t))) + (when (or (and (eq indent 'tabs) + (looking-at (concat prefix "\\( *\t[ \t]*\\)"))) + (and (integerp indent) + (looking-at (format "%s\\([ \t]* \\{%s,\\}[ \t]*\\)" + prefix indent)))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t)))))) + +(defun magit-diff-update-hunk-refinement (&optional section) + (if section + (unless (oref section hidden) + (pcase (list magit-diff-refine-hunk + (oref section refined) + (eq section (magit-current-section))) + ((or `(all nil ,_) `(t nil t)) + (oset section refined t) + (save-excursion + (goto-char (oref section start)) + ;; `diff-refine-hunk' does not handle combined diffs. + (unless (looking-at "@@@") + (let ((smerge-refine-ignore-whitespace + magit-diff-refine-ignore-whitespace) + ;; Avoid fsyncing many small temp files + (write-region-inhibit-fsync t)) + (diff-refine-hunk))))) + ((or `(nil t ,_) `(t t nil)) + (oset section refined nil) + (remove-overlays (oref section start) + (oref section end) + 'diff-mode 'fine)))) + (cl-labels ((recurse (section) + (if (magit-section-match 'hunk section) + (magit-diff-update-hunk-refinement section) + (dolist (child (oref section children)) + (recurse child))))) + (recurse magit-root-section)))) + + +;;; Hunk Region + +(defun magit-diff-hunk-region-beginning () + (save-excursion (goto-char (region-beginning)) + (line-beginning-position))) + +(defun magit-diff-hunk-region-end () + (save-excursion (goto-char (region-end)) + (line-end-position))) + +(defun magit-diff-update-hunk-region (section) + "Highlight the hunk-internal region if any." + (when (eq (magit-diff-scope section t) 'region) + (magit-diff--make-hunk-overlay + (oref section start) + (1- (oref section content)) + 'font-lock-face 'magit-diff-lines-heading + 'display (magit-diff-hunk-region-header section) + 'after-string (magit-diff--hunk-after-string 'magit-diff-lines-heading)) + (run-hook-with-args 'magit-diff-highlight-hunk-region-functions section) + t)) + +(defun magit-diff-highlight-hunk-region-dim-outside (section) + "Dim the parts of the hunk that are outside the hunk-internal region. +This is done by using the same foreground and background color +for added and removed lines as for context lines." + (let ((face (if magit-diff-highlight-hunk-body + 'magit-diff-context-highlight + 'magit-diff-context))) + (when magit-diff-unmarked-lines-keep-foreground + (setq face `(,@(and (>= emacs-major-version 27) '(:extend t)) + :background ,(face-attribute face :background)))) + (magit-diff--make-hunk-overlay (oref section content) + (magit-diff-hunk-region-beginning) + 'font-lock-face face + 'priority 2) + (magit-diff--make-hunk-overlay (1+ (magit-diff-hunk-region-end)) + (oref section end) + 'font-lock-face face + 'priority 2))) + +(defun magit-diff-highlight-hunk-region-using-face (_section) + "Highlight the hunk-internal region by making it bold. +Or rather highlight using the face `magit-diff-hunk-region', though +changing only the `:weight' and/or `:slant' is recommended for that +face." + (magit-diff--make-hunk-overlay (magit-diff-hunk-region-beginning) + (1+ (magit-diff-hunk-region-end)) + 'font-lock-face 'magit-diff-hunk-region)) + +(defun magit-diff-highlight-hunk-region-using-overlays (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented as single-pixel newlines places inside overlays." + (if (window-system) + (let ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (str (propertize + (concat (propertize "\s" 'display '(space :height (1))) + (propertize "\n" 'line-height t)) + 'font-lock-face 'magit-diff-lines-boundary))) + (magit-diff--make-hunk-overlay beg (1+ beg) 'before-string str) + (magit-diff--make-hunk-overlay end (1+ end) 'after-string str)) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff-highlight-hunk-region-using-underline (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented by overlining and underlining the first and +last (visual) lines of the region." + (if (window-system) + (let* ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (beg-eol (save-excursion (goto-char beg) + (end-of-visual-line) + (point))) + (end-bol (save-excursion (goto-char end) + (beginning-of-visual-line) + (point))) + (color (face-background 'magit-diff-lines-boundary nil t))) + (cl-flet ((ln (b e &rest face) + (magit-diff--make-hunk-overlay + b e 'font-lock-face face 'after-string + (magit-diff--hunk-after-string face)))) + (if (= beg end-bol) + (ln beg beg-eol :overline color :underline color) + (ln beg beg-eol :overline color) + (ln end-bol end :underline color)))) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff--make-hunk-overlay (start end &rest args) + (let ((ov (make-overlay start end nil t))) + (overlay-put ov 'evaporate t) + (while args (overlay-put ov (pop args) (pop args))) + (push ov magit-section--region-overlays) + ov)) + +(defun magit-diff--hunk-after-string (face) + (propertize "\s" + 'font-lock-face face + 'display (list 'space :align-to + `(+ (0 . right) + ,(min (window-hscroll) + (- (line-end-position) + (line-beginning-position))))) + ;; This prevents the cursor from being rendered at the + ;; edge of the window. + 'cursor t)) + +;;; Hunk Utilities + +(defun magit-diff-inside-hunk-body-p () + "Return non-nil if point is inside the body of a hunk." + (and (magit-section-match 'hunk) + (when-let ((content (oref (magit-current-section) content))) + (> (point) content)))) + +;;; Diff Extract + +(defun magit-diff-file-header (section) + (when (magit-hunk-section-p section) + (setq section (oref section parent))) + (when (magit-file-section-p section) + (oref section header))) + +(defun magit-diff-hunk-region-header (section) + (let ((patch (magit-diff-hunk-region-patch section))) + (string-match "\n" patch) + (substring patch 0 (1- (match-end 0))))) + +(defun magit-diff-hunk-region-patch (section &optional args) + (let ((op (if (member "--reverse" args) "+" "-")) + (sbeg (oref section start)) + (rbeg (magit-diff-hunk-region-beginning)) + (rend (region-end)) + (send (oref section end)) + (patch nil)) + (save-excursion + (goto-char sbeg) + (while (< (point) send) + (looking-at "\\(.\\)\\([^\n]*\n\\)") + (cond ((or (string-match-p "[@ ]" (match-string-no-properties 1)) + (and (>= (point) rbeg) + (<= (point) rend))) + (push (match-string-no-properties 0) patch)) + ((equal op (match-string-no-properties 1)) + (push (concat " " (match-string-no-properties 2)) patch))) + (forward-line))) + (let ((buffer-list-update-hook nil)) ; #3759 + (with-temp-buffer + (insert (mapconcat #'identity (reverse patch) "")) + (diff-fixup-modifs (point-min) (point-max)) + (setq patch (buffer-string)))) + patch)) + +;;; _ +(provide 'magit-diff) +;;; magit-diff.el ends here diff --git a/elpa/magit-20200318.1224/magit-diff.elc b/elpa/magit-20200318.1224/magit-diff.elc new file mode 100644 index 00000000..5693a82d Binary files /dev/null and b/elpa/magit-20200318.1224/magit-diff.elc differ diff --git a/elpa/magit-20200318.1224/magit-ediff.el b/elpa/magit-20200318.1224/magit-ediff.el new file mode 100644 index 00000000..058dd882 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-ediff.el @@ -0,0 +1,509 @@ +;;; magit-ediff.el --- Ediff extension for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library provides basic support for Ediff. + +;;; Code: + +(require 'magit) + +(require 'ediff) +(require 'smerge-mode) + +(defvar smerge-ediff-buf) +(defvar smerge-ediff-windows) + +;;; Options + +(defgroup magit-ediff nil + "Ediff support for Magit." + :link '(info-link "(magit)Ediffing") + :group 'magit-extensions) + +(defcustom magit-ediff-quit-hook + '(magit-ediff-cleanup-auxiliary-buffers + magit-ediff-restore-previous-winconf) + "Hooks to run after finishing Ediff, when that was invoked using Magit. +The hooks are run in the Ediff control buffer. This is similar +to `ediff-quit-hook' but takes the needs of Magit into account. +The `ediff-quit-hook' is ignored by Ediff sessions which were +invoked using Magit." + :package-version '(magit . "2.2.0") + :group 'magit-ediff + :type 'hook + :get 'magit-hook-custom-get + :options '(magit-ediff-cleanup-auxiliary-buffers + magit-ediff-restore-previous-winconf)) + +(defcustom magit-ediff-dwim-show-on-hunks nil + "Whether `magit-ediff-dwim' runs show variants on hunks. +If non-nil, `magit-ediff-show-staged' or +`magit-ediff-show-unstaged' are called based on what section the +hunk is in. Otherwise, `magit-ediff-dwim' runs +`magit-ediff-stage' when point is on an uncommitted hunk." + :package-version '(magit . "2.2.0") + :group 'magit-ediff + :type 'boolean) + +(defcustom magit-ediff-show-stash-with-index t + "Whether `magit-ediff-show-stash' shows the state of the index. + +If non-nil, use a third Ediff buffer to distinguish which changes +in the stash were staged. In cases where the stash contains no +staged changes, fall back to a two-buffer Ediff. + +More specifically, a stash is a merge commit, stash@{N}, with +potentially three parents. + +* stash@{N}^1 represents the `HEAD' commit at the time the stash + was created. + +* stash@{N}^2 records any changes that were staged when the stash + was made. + +* stash@{N}^3, if it exists, contains files that were untracked + when stashing. + +If this option is non-nil, `magit-ediff-show-stash' will run +Ediff on a file using three buffers: one for stash@{N}, another +for stash@{N}^1, and a third for stash@{N}^2. + +Otherwise, Ediff uses two buffers, comparing +stash@{N}^1..stash@{N}. Along with any unstaged changes, changes +in the index commit, stash@{N}^2, will be shown in this +comparison unless they conflicted with changes in the working +tree at the time of stashing." + :package-version '(magit . "2.6.0") + :group 'magit-ediff + :type 'boolean) + +;;; Commands + +(defvar magit-ediff-previous-winconf nil) + +;;;###autoload (autoload 'magit-ediff "magit-ediff" nil) +(define-transient-command magit-ediff () + "Show differences using the Ediff package." + :info-manual "(ediff)" + ["Ediff" + [("E" "Dwim" magit-ediff-dwim) + ("s" "Stage" magit-ediff-stage) + ("m" "Resolve" magit-ediff-resolve)] + [("u" "Show unstaged" magit-ediff-show-unstaged) + ("i" "Show staged" magit-ediff-show-staged) + ("w" "Show worktree" magit-ediff-show-working-tree)] + [("c" "Show commit" magit-ediff-show-commit) + ("r" "Show range" magit-ediff-compare) + ("z" "Show stash" magit-ediff-show-stash)]]) + +;;;###autoload +(defun magit-ediff-resolve (file) + "Resolve outstanding conflicts in FILE using Ediff. +FILE has to be relative to the top directory of the repository. + +In the rare event that you want to manually resolve all +conflicts, including those already resolved by Git, use +`ediff-merge-revisions-with-ancestor'." + (interactive + (let ((current (magit-current-file)) + (unmerged (magit-unmerged-files))) + (unless unmerged + (user-error "There are no unresolved conflicts")) + (list (magit-completing-read "Resolve file" unmerged nil t nil nil + (car (member current unmerged)))))) + (magit-with-toplevel + (with-current-buffer (find-file-noselect file) + (smerge-ediff) + (setq-local + ediff-quit-hook + (lambda () + (let ((bufC ediff-buffer-C) + (bufS smerge-ediff-buf)) + (with-current-buffer bufS + (when (yes-or-no-p (format "Conflict resolution finished; save %s? " + buffer-file-name)) + (erase-buffer) + (insert-buffer-substring bufC) + (save-buffer)))) + (when (buffer-live-p ediff-buffer-A) (kill-buffer ediff-buffer-A)) + (when (buffer-live-p ediff-buffer-B) (kill-buffer ediff-buffer-B)) + (when (buffer-live-p ediff-buffer-C) (kill-buffer ediff-buffer-C)) + (when (buffer-live-p ediff-ancestor-buffer) + (kill-buffer ediff-ancestor-buffer)) + (let ((magit-ediff-previous-winconf smerge-ediff-windows)) + (run-hooks 'magit-ediff-quit-hook))))))) + +;;;###autoload +(defun magit-ediff-stage (file) + "Stage and unstage changes to FILE using Ediff. +FILE has to be relative to the top directory of the repository." + (interactive + (let ((files (magit-tracked-files))) + (list (magit-completing-read "Selectively stage file" files nil t nil nil + (car (member (magit-current-file) files)))))) + (magit-with-toplevel + (let* ((conf (current-window-configuration)) + (bufA (magit-get-revision-buffer "HEAD" file)) + (bufB (magit-get-revision-buffer "{index}" file)) + (bufBrw (and bufB (with-current-buffer bufB (not buffer-read-only)))) + (bufC (get-file-buffer file)) + (fileBufC (or bufC (find-file-noselect file))) + (coding-system-for-read + (with-current-buffer fileBufC buffer-file-coding-system))) + (ediff-buffers3 + (or bufA (magit-find-file-noselect "HEAD" file)) + (with-current-buffer (magit-find-file-index-noselect file t) + (setq buffer-read-only nil) + (current-buffer)) + fileBufC + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + (and (buffer-live-p ediff-buffer-B) + (buffer-modified-p ediff-buffer-B) + (with-current-buffer ediff-buffer-B + (magit-update-index))) + (and (buffer-live-p ediff-buffer-C) + (buffer-modified-p ediff-buffer-C) + (with-current-buffer ediff-buffer-C + (when (y-or-n-p + (format "Save file %s? " buffer-file-name)) + (save-buffer)))) + ,@(unless bufA '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(if bufB + (unless bufBrw '((with-current-buffer ediff-buffer-B + (setq buffer-read-only t)))) + '((ediff-kill-buffer-carefully ediff-buffer-B))) + ,@(unless bufC '((ediff-kill-buffer-carefully ediff-buffer-C))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-buffers3)))) + +;;;###autoload +(defun magit-ediff-compare (revA revB fileA fileB) + "Compare REVA:FILEA with REVB:FILEB using Ediff. + +FILEA and FILEB have to be relative to the top directory of the +repository. If REVA or REVB is nil, then this stands for the +working tree state. + +If the region is active, use the revisions on the first and last +line of the region. With a prefix argument, instead of diffing +the revisions, choose a revision to view changes along, starting +at the common ancestor of both revisions (i.e., use a \"...\" +range)." + (interactive + (pcase-let ((`(,revA ,revB) (magit-ediff-compare--read-revisions + nil current-prefix-arg))) + (nconc (list revA revB) + (magit-ediff-read-files revA revB)))) + (magit-with-toplevel + (let ((conf (current-window-configuration)) + (bufA (if revA + (magit-get-revision-buffer revA fileA) + (get-file-buffer fileA))) + (bufB (if revB + (magit-get-revision-buffer revB fileB) + (get-file-buffer fileB)))) + (ediff-buffers + (or bufA (if revA + (magit-find-file-noselect revA fileA) + (find-file-noselect fileA))) + (or bufB (if revB + (magit-find-file-noselect revB fileB) + (find-file-noselect fileB))) + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + ,@(unless bufA '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(unless bufB '((ediff-kill-buffer-carefully ediff-buffer-B))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-revision)))) + +(defun magit-ediff-compare--read-revisions (&optional arg mbase) + (let ((input (or arg (magit-diff-read-range-or-commit + "Compare range or commit" + nil mbase)))) + (--if-let (magit-split-range input) + (-cons-to-list it) + (list input nil)))) + +(defun magit-ediff-read-files (revA revB &optional fileB) + "Read file in REVB, return it and the corresponding file in REVA. +When FILEB is non-nil, use this as REVB's file instead of +prompting for it." + (unless fileB + (setq fileB (magit-read-file-choice + (format "File to compare between %s and %s" + revA (or revB "the working tree")) + (magit-changed-files revA revB) + (format "No changed files between %s and %s" + revA (or revB "the working tree"))))) + (list (or (car (member fileB (magit-revision-files revA))) + (cdr (assoc fileB (magit-renamed-files revB revA))) + (magit-read-file-choice + (format "File in %s to compare with %s in %s" + revA fileB (or revB "the working tree")) + (magit-changed-files revB revA) + (format "No files have changed between %s and %s" + revA revB))) + fileB)) + +;;;###autoload +(defun magit-ediff-dwim () + "Compare, stage, or resolve using Ediff. +This command tries to guess what file, and what commit or range +the user wants to compare, stage, or resolve using Ediff. It +might only be able to guess either the file, or range or commit, +in which case the user is asked about the other. It might not +always guess right, in which case the appropriate `magit-ediff-*' +command has to be used explicitly. If it cannot read the user's +mind at all, then it asks the user for a command to run." + (interactive) + (magit-section-case + (hunk (save-excursion + (goto-char (oref (oref it parent) start)) + (magit-ediff-dwim))) + (t + (let ((range (magit-diff--dwim)) + (file (magit-current-file)) + command revA revB) + (pcase range + ((and (guard (not magit-ediff-dwim-show-on-hunks)) + (or `unstaged `staged)) + (setq command (if (magit-anything-unmerged-p) + #'magit-ediff-resolve + #'magit-ediff-stage))) + (`unstaged (setq command #'magit-ediff-show-unstaged)) + (`staged (setq command #'magit-ediff-show-staged)) + (`(commit . ,value) + (setq command #'magit-ediff-show-commit) + (setq revB value)) + (`(stash . ,value) + (setq command #'magit-ediff-show-stash) + (setq revB value)) + ((pred stringp) + (pcase-let ((`(,a ,b) (magit-ediff-compare--read-revisions range))) + (setq command #'magit-ediff-compare) + (setq revA a) + (setq revB b))) + (_ + (when (derived-mode-p 'magit-diff-mode) + (pcase (magit-diff-type) + (`committed (pcase-let ((`(,a ,b) + (magit-ediff-compare--read-revisions + magit-buffer-range))) + (setq revA a) + (setq revB b))) + ((guard (not magit-ediff-dwim-show-on-hunks)) + (setq command #'magit-ediff-stage)) + (`unstaged (setq command #'magit-ediff-show-unstaged)) + (`staged (setq command #'magit-ediff-show-staged)) + (`undefined (setq command nil)) + (_ (setq command nil)))))) + (cond ((not command) + (call-interactively + (magit-read-char-case + "Failed to read your mind; do you want to " t + (?c "[c]ommit" 'magit-ediff-show-commit) + (?r "[r]ange" 'magit-ediff-compare) + (?s "[s]tage" 'magit-ediff-stage) + (?v "resol[v]e" 'magit-ediff-resolve)))) + ((eq command 'magit-ediff-compare) + (apply 'magit-ediff-compare revA revB + (magit-ediff-read-files revA revB file))) + ((eq command 'magit-ediff-show-commit) + (magit-ediff-show-commit revB)) + ((eq command 'magit-ediff-show-stash) + (magit-ediff-show-stash revB)) + (file + (funcall command file)) + (t + (call-interactively command))))))) + +;;;###autoload +(defun magit-ediff-show-staged (file) + "Show staged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show staged changes for file" + (magit-staged-files) + "No staged files"))) + (let ((conf (current-window-configuration)) + (bufA (magit-get-revision-buffer "HEAD" file)) + (bufB (get-buffer (concat file ".~{index}~")))) + (ediff-buffers + (or bufA (magit-find-file-noselect "HEAD" file)) + (or bufB (magit-find-file-index-noselect file t)) + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + ,@(unless bufA '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(unless bufB '((ediff-kill-buffer-carefully ediff-buffer-B))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-buffers))) + +;;;###autoload +(defun magit-ediff-show-unstaged (file) + "Show unstaged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show unstaged changes for file" + (magit-unstaged-files) + "No unstaged files"))) + (magit-with-toplevel + (let ((conf (current-window-configuration)) + (bufA (get-buffer (concat file ".~{index}~"))) + (bufB (get-file-buffer file))) + (ediff-buffers + (or bufA (magit-find-file-index-noselect file t)) + (or bufB (find-file-noselect file)) + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + ,@(unless bufA '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(unless bufB '((ediff-kill-buffer-carefully ediff-buffer-B))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-buffers)))) + +;;;###autoload +(defun magit-ediff-show-working-tree (file) + "Show changes between `HEAD' and working tree using Ediff. +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show changes in file" + (magit-changed-files "HEAD") + "No changed files"))) + (magit-with-toplevel + (let ((conf (current-window-configuration)) + (bufA (magit-get-revision-buffer "HEAD" file)) + (bufB (get-file-buffer file))) + (ediff-buffers + (or bufA (magit-find-file-noselect "HEAD" file)) + (or bufB (find-file-noselect file)) + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + ,@(unless bufA '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(unless bufB '((ediff-kill-buffer-carefully ediff-buffer-B))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-buffers)))) + +;;;###autoload +(defun magit-ediff-show-commit (commit) + "Show changes introduced by COMMIT using Ediff." + (interactive (list (magit-read-branch-or-commit "Revision"))) + (let ((revA (concat commit "^")) + (revB commit)) + (apply #'magit-ediff-compare + revA revB + (magit-ediff-read-files revA revB (magit-current-file))))) + +;;;###autoload +(defun magit-ediff-show-stash (stash) + "Show changes introduced by STASH using Ediff. +`magit-ediff-show-stash-with-index' controls whether a +three-buffer Ediff is used in order to distinguish changes in the +stash that were staged." + (interactive (list (magit-read-stash "Stash"))) + (pcase-let* ((revA (concat stash "^1")) + (revB (concat stash "^2")) + (revC stash) + (`(,fileA ,fileC) (magit-ediff-read-files revA revC)) + (fileB fileC)) + (if (and magit-ediff-show-stash-with-index + (member fileA (magit-changed-files revB revA))) + (let ((conf (current-window-configuration)) + (bufA (magit-get-revision-buffer revA fileA)) + (bufB (magit-get-revision-buffer revB fileB)) + (bufC (magit-get-revision-buffer revC fileC))) + (ediff-buffers3 + (or bufA (magit-find-file-noselect revA fileA)) + (or bufB (magit-find-file-noselect revB fileB)) + (or bufC (magit-find-file-noselect revC fileC)) + `((lambda () + (setq-local + ediff-quit-hook + (lambda () + ,@(unless bufA + '((ediff-kill-buffer-carefully ediff-buffer-A))) + ,@(unless bufB + '((ediff-kill-buffer-carefully ediff-buffer-B))) + ,@(unless bufC + '((ediff-kill-buffer-carefully ediff-buffer-C))) + (let ((magit-ediff-previous-winconf ,conf)) + (run-hooks 'magit-ediff-quit-hook)))))) + 'ediff-buffers3)) + (magit-ediff-compare revA revC fileA fileC)))) + +(defun magit-ediff-cleanup-auxiliary-buffers () + (let* ((ctl-buf ediff-control-buffer) + (ctl-win (ediff-get-visible-buffer-window ctl-buf)) + (ctl-frm ediff-control-frame) + (main-frame (cond ((window-live-p ediff-window-A) + (window-frame ediff-window-A)) + ((window-live-p ediff-window-B) + (window-frame ediff-window-B))))) + (ediff-kill-buffer-carefully ediff-diff-buffer) + (ediff-kill-buffer-carefully ediff-custom-diff-buffer) + (ediff-kill-buffer-carefully ediff-fine-diff-buffer) + (ediff-kill-buffer-carefully ediff-tmp-buffer) + (ediff-kill-buffer-carefully ediff-error-buffer) + (ediff-kill-buffer-carefully ediff-msg-buffer) + (ediff-kill-buffer-carefully ediff-debug-buffer) + (when (boundp 'ediff-patch-diagnostics) + (ediff-kill-buffer-carefully ediff-patch-diagnostics)) + (cond ((and (ediff-window-display-p) + (frame-live-p ctl-frm)) + (delete-frame ctl-frm)) + ((window-live-p ctl-win) + (delete-window ctl-win))) + (ediff-kill-buffer-carefully ctl-buf) + (when (frame-live-p main-frame) + (select-frame main-frame)))) + +(defun magit-ediff-restore-previous-winconf () + (set-window-configuration magit-ediff-previous-winconf)) + +;;; _ +(provide 'magit-ediff) +;;; magit-ediff.el ends here diff --git a/elpa/magit-20200318.1224/magit-ediff.elc b/elpa/magit-20200318.1224/magit-ediff.elc new file mode 100644 index 00000000..11d7108f Binary files /dev/null and b/elpa/magit-20200318.1224/magit-ediff.elc differ diff --git a/elpa/magit-20200318.1224/magit-extras.el b/elpa/magit-20200318.1224/magit-extras.el new file mode 100644 index 00000000..0b67f7b8 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-extras.el @@ -0,0 +1,671 @@ +;;; magit-extras.el --- additional functionality for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Additional functionality for Magit. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +(declare-function dired-read-shell-command "dired-aux" (prompt arg files)) + +(defvar ido-exit) +(defvar ido-fallback) + +(defgroup magit-extras nil + "Additional functionality for Magit." + :group 'magit-extensions) + +;;; External Tools + +(defcustom magit-gitk-executable + (or (and (eq system-type 'windows-nt) + (let ((exe (magit-git-string + "-c" "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" + "X" "gitk.exe"))) + (and exe (file-executable-p exe) exe))) + (executable-find "gitk") "gitk") + "The Gitk executable." + :group 'magit-extras + :set-after '(magit-git-executable) + :type 'string) + +;;;###autoload +(defun magit-run-git-gui () + "Run `git gui' for the current git repository." + (interactive) + (magit-with-toplevel + (magit-process-file magit-git-executable nil 0 nil "gui"))) + +;;;###autoload +(defun magit-run-git-gui-blame (commit filename &optional linenum) + "Run `git gui blame' on the given FILENAME and COMMIT. +Interactively run it for the current file and the `HEAD', with a +prefix or when the current file cannot be determined let the user +choose. When the current buffer is visiting FILENAME instruct +blame to center around the line point is on." + (interactive + (let (revision filename) + (when (or current-prefix-arg + (not (setq revision "HEAD" + filename (magit-file-relative-name nil 'tracked)))) + (setq revision (magit-read-branch-or-commit "Blame from revision")) + (setq filename (magit-read-file-from-rev revision "Blame file"))) + (list revision filename + (and (equal filename + (ignore-errors + (magit-file-relative-name buffer-file-name))) + (line-number-at-pos))))) + (magit-with-toplevel + (apply #'magit-process-file magit-git-executable nil 0 nil "gui" "blame" + `(,@(and linenum (list (format "--line=%d" linenum))) + ,commit + ,filename)))) + +;;;###autoload +(defun magit-run-gitk () + "Run `gitk' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0)) + +;;;###autoload +(defun magit-run-gitk-branches () + "Run `gitk --branches' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0 nil "--branches")) + +;;;###autoload +(defun magit-run-gitk-all () + "Run `gitk --all' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0 nil "--all")) + +;;; Emacs Tools + +;;;###autoload +(defun ido-enter-magit-status () + "Drop into `magit-status' from file switching. + +This command does not work in Emacs 26.1. +See https://github.com/magit/magit/issues/3634 +and https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31707. + +To make this command available use something like: + + (add-hook \\='ido-setup-hook + (lambda () + (define-key ido-completion-map + (kbd \"C-x g\") \\='ido-enter-magit-status))) + +Starting with Emacs 25.1 the Ido keymaps are defined just once +instead of every time Ido is invoked, so now you can modify it +like pretty much every other keymap: + + (define-key ido-common-completion-map + (kbd \"C-x g\") \\='ido-enter-magit-status)" + (interactive) + (setq ido-exit 'fallback) + (setq ido-fallback 'magit-status) ; for Emacs >= 26.2 + (with-no-warnings (setq fallback 'magit-status)) ; for Emacs 25 + (exit-minibuffer)) + +;;;###autoload +(defun magit-dired-jump (&optional other-window) + "Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'." + (interactive "P") + (dired-jump other-window + (when-let ((file (magit-file-at-point))) + (expand-file-name (if (file-directory-p file) + (file-name-as-directory file) + file))))) + +;;;###autoload +(defun magit-dired-log (&optional follow) + "Show log for all marked files, or the current file." + (interactive "P") + (if-let ((topdir (magit-toplevel default-directory))) + (let ((args (car (magit-log-arguments))) + (files (dired-get-marked-files nil nil #'magit-file-tracked-p))) + (unless files + (user-error "No marked file is being tracked by Git")) + (when (and follow + (not (member "--follow" args)) + (not (cdr files))) + (push "--follow" args)) + (magit-log-setup-buffer + (list (or (magit-get-current-branch) "HEAD")) + args + (let ((default-directory topdir)) + (mapcar #'file-relative-name files)) + magit-log-buffer-file-locked)) + (magit--not-inside-repository-error))) + +;;;###autoload +(defun magit-do-async-shell-command (file) + "Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point." + (interactive (list (or (magit-file-at-point) + (completing-read "Act on file: " + (magit-list-files))))) + (require 'dired-aux) + (dired-do-async-shell-command + (dired-read-shell-command "& on %s: " current-prefix-arg (list file)) + nil (list file))) + +;;; Shift Selection + +(defun magit--turn-on-shift-select-mode-p () + (and shift-select-mode + this-command-keys-shift-translated + (not mark-active) + (not (eq (car-safe transient-mark-mode) 'only)))) + +;;;###autoload +(defun magit-previous-line (&optional arg try-vscroll) + "Like `previous-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects an +area that is larger than the region. This causes `previous-line' +when invoked while holding the shift key to move up one line and +thereby select two lines. When invoked inside a hunk body this +command does not move point on the first invocation and thereby +it only selects a single line. Which inconsistency you prefer +is a matter of preference." + (declare (interactive-only + "use `forward-line' with negative argument instead.")) + (interactive "p\np") + (unless arg (setq arg 1)) + (let ((stay (or (magit-diff-inside-hunk-body-p) + (magit-section-position-in-heading-p)))) + (if (and stay (= arg 1) (magit--turn-on-shift-select-mode-p)) + (push-mark nil nil t) + (with-no-warnings + (handle-shift-selection) + (previous-line (if stay (max (1- arg) 1) arg) try-vscroll))))) + +;;;###autoload +(defun magit-next-line (&optional arg try-vscroll) + "Like `next-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects +an area that is larger than the region. This causes `next-line' +when invoked while holding the shift key to move down one line +and thereby select two lines. When invoked inside a hunk body +this command does not move point on the first invocation and +thereby it only selects a single line. Which inconsistency you +prefer is a matter of preference." + (declare (interactive-only forward-line)) + (interactive "p\np") + (unless arg (setq arg 1)) + (let ((stay (or (magit-diff-inside-hunk-body-p) + (magit-section-position-in-heading-p)))) + (if (and stay (= arg 1) (magit--turn-on-shift-select-mode-p)) + (push-mark nil nil t) + (with-no-warnings + (handle-shift-selection) + (next-line (if stay (max (1- arg) 1) arg) try-vscroll))))) + +;;; Clean + +;;;###autoload +(defun magit-clean (&optional arg) + "Remove untracked files from the working tree. +With a prefix argument also remove ignored files, +with two prefix arguments remove ignored files only. +\n(git clean -f -d [-x|-X])" + (interactive "p") + (when (yes-or-no-p (format "Remove %s files? " + (pcase arg + (1 "untracked") + (4 "untracked and ignored") + (_ "ignored")))) + (magit-wip-commit-before-change) + (magit-run-git "clean" "-f" "-d" (pcase arg (4 "-x") (16 "-X"))))) + +(put 'magit-clean 'disabled t) + +;;; ChangeLog + +;;;###autoload +(defun magit-add-change-log-entry (&optional whoami file-name other-window) + "Find change log file and add date entry and item for current change. +This differs from `add-change-log-entry' (which see) in that +it acts on the current hunk in a Magit buffer instead of on +a position in a file-visiting buffer." + (interactive (list current-prefix-arg + (prompt-for-change-log-name))) + (pcase-let ((`(,buf ,pos) (magit-diff-visit-file--noselect))) + (magit--with-temp-position buf pos + (let ((add-log-buffer-file-name-function + (lambda () + (or magit-buffer-file-name + (buffer-file-name))))) + (add-change-log-entry whoami file-name other-window))))) + +;;;###autoload +(defun magit-add-change-log-entry-other-window (&optional whoami file-name) + "Find change log file in other window and add entry and item. +This differs from `add-change-log-entry-other-window' (which see) +in that it acts on the current hunk in a Magit buffer instead of +on a position in a file-visiting buffer." + (interactive (and current-prefix-arg + (list current-prefix-arg + (prompt-for-change-log-name)))) + (magit-add-change-log-entry whoami file-name t)) + +;;; Edit Line Commit + +;;;###autoload +(defun magit-edit-line-commit (&optional type) + "Edit the commit that added the current line. + +With a prefix argument edit the commit that removes the line, +if any. The commit is determined using `git blame' and made +editable using `git rebase --interactive' if it is reachable +from `HEAD', or by checking out the commit (or a branch that +points at it) otherwise." + (interactive (list (and current-prefix-arg 'removal))) + (let* ((chunk (magit-current-blame-chunk (or type 'addition))) + (rev (oref chunk orig-rev))) + (if (equal rev "0000000000000000000000000000000000000000") + (message "This line has not been committed yet") + (let ((rebase (magit-rev-ancestor-p rev "HEAD")) + (file (expand-file-name (oref chunk orig-file) + (magit-toplevel)))) + (if rebase + (let ((magit--rebase-published-symbol 'edit-published)) + (magit-rebase-edit-commit rev (magit-rebase-arguments))) + (magit-checkout (or (magit-rev-branch rev) rev))) + (unless (and buffer-file-name + (file-equal-p file buffer-file-name)) + (let ((blame-type (and magit-blame-mode magit-blame-type))) + (if rebase + (set-process-sentinel + magit-this-process + (lambda (process event) + (magit-sequencer-process-sentinel process event) + (when (eq (process-status process) 'exit) + (find-file file) + (when blame-type + (magit-blame--pre-blame-setup blame-type) + (magit-blame--run (magit-blame-arguments)))))) + (find-file file) + (when blame-type + (magit-blame--pre-blame-setup blame-type) + (magit-blame--run (magit-blame-arguments)))))))))) + +(put 'magit-edit-line-commit 'disabled t) + +;;;###autoload +(defun magit-diff-edit-hunk-commit (file) + "From a hunk, edit the respective commit and visit the file. + +First visit the file being modified by the hunk at the correct +location using `magit-diff-visit-file'. This actually visits a +blob. When point is on a diff header, not within an individual +hunk, then this visits the blob the first hunk is about. + +Then invoke `magit-edit-line-commit', which uses an interactive +rebase to make the commit editable, or if that is not possible +because the commit is not reachable from `HEAD' by checking out +that commit directly. This also causes the actual worktree file +to be visited. + +Neither the blob nor the file buffer are killed when finishing +the rebase. If that is undesirable, then it might be better to +use `magit-rebase-edit-command' instead of this command." + (interactive (list (magit-file-at-point t t))) + (let ((magit-diff-visit-previous-blob nil)) + (with-current-buffer + (magit-diff-visit-file--internal file nil #'pop-to-buffer-same-window) + (magit-edit-line-commit)))) + +(put 'magit-diff-edit-hunk-commit 'disabled t) + +;;; Reshelve + +;;;###autoload +(defun magit-reshelve-since (rev) + "Change the author and committer dates of the commits since REV. + +Ask the user for the first reachable commit whose dates should +be changed. Then read the new date for that commit. The initial +minibuffer input and the previous history element offer good +values. The next commit will be created one minute later and so +on. + +This command is only intended for interactive use and should only +be used on highly rearranged and unpublished history." + (interactive (list nil)) + (cond + ((not rev) + (let ((backup (concat "refs/original/refs/heads/" + (magit-get-current-branch)))) + (when (and (magit-ref-p backup) + (not (magit-y-or-n-p + "Backup ref %s already exists. Override? " backup))) + (user-error "Abort"))) + (magit-log-select 'magit-reshelve-since + "Type %p on a commit to reshelve it and the commits above it,")) + (t + (cl-flet ((adjust (time offset) + (format-time-string + "%F %T %z" + (+ (floor time) + (* offset 60) + (- (car (decode-time time))))))) + (let* ((start (concat rev "^")) + (range (concat start ".." (magit-get-current-branch))) + (time-rev (adjust (float-time (string-to-number + (magit-rev-format "%at" start))) + 1)) + (time-now (adjust (float-time) + (- (string-to-number + (magit-git-string "rev-list" "--count" + range)))))) + (push time-rev magit--reshelve-history) + (let ((date (floor + (float-time + (date-to-time + (read-string "Date for first commit: " + time-now 'magit--reshelve-history)))))) + (magit-with-toplevel + (magit-run-git-async + "filter-branch" "--force" "--env-filter" + (format "case $GIT_COMMIT in %s\nesac" + (mapconcat (lambda (rev) + (prog1 (format "%s) \ +export GIT_AUTHOR_DATE=\"%s\"; \ +export GIT_COMMITTER_DATE=\"%s\";;" rev date date) + (cl-incf date 60))) + (magit-git-lines "rev-list" "--reverse" + range) + " ")) + range "--") + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-run-git "update-ref" "-d" + (concat "refs/original/refs/heads/" + (magit-get-current-branch)))))))))))))) + +;;; Revision Stack + +(defvar magit-revision-stack nil) + +(defcustom magit-pop-revision-stack-format + '("[%N: %h] " "%N: %H\n %s\n" "\\[\\([0-9]+\\)[]:]") + "Control how `magit-pop-revision-stack' inserts a revision. + +The command `magit-pop-revision-stack' inserts a representation +of the revision last pushed to the `magit-revision-stack' into +the current buffer. It inserts text at point and/or near the end +of the buffer, and removes the consumed revision from the stack. + +The entries on the stack have the format (HASH TOPLEVEL) and this +option has the format (POINT-FORMAT EOB-FORMAT INDEX-REGEXP), all +of which may be nil or a string (though either one of EOB-FORMAT +or POINT-FORMAT should be a string, and if INDEX-REGEXP is +non-nil, then the two formats should be too). + +First INDEX-REGEXP is used to find the previously inserted entry, +by searching backward from point. The first submatch must match +the index number. That number is incremented by one, and becomes +the index number of the entry to be inserted. If you don't want +to number the inserted revisions, then use nil for INDEX-REGEXP. + +If INDEX-REGEXP is non-nil, then both POINT-FORMAT and EOB-FORMAT +should contain \"%N\", which is replaced with the number that was +determined in the previous step. + +Both formats, if non-nil and after removing %N, are then expanded +using `git show --format=FORMAT ...' inside TOPLEVEL. + +The expansion of POINT-FORMAT is inserted at point, and the +expansion of EOB-FORMAT is inserted at the end of the buffer (if +the buffer ends with a comment, then it is inserted right before +that)." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type '(list (choice (string :tag "Insert at point format") + (cons (string :tag "Insert at point format") + (repeat (string :tag "Argument to git show"))) + (const :tag "Don't insert at point" nil)) + (choice (string :tag "Insert at eob format") + (cons (string :tag "Insert at eob format") + (repeat (string :tag "Argument to git show"))) + (const :tag "Don't insert at eob" nil)) + (choice (regexp :tag "Find index regexp") + (const :tag "Don't number entries" nil)))) + +(defcustom magit-copy-revision-abbreviated nil + "Whether to save abbreviated revision to `kill-ring' and `magit-revision-stack'." + :package-version '(magit . "3.0.0") + :group 'magit-miscellaneous + :type 'boolean) + +;;;###autoload +(defun magit-pop-revision-stack (rev toplevel) + "Insert a representation of a revision into the current buffer. + +Pop a revision from the `magit-revision-stack' and insert it into +the current buffer according to `magit-pop-revision-stack-format'. +Revisions can be put on the stack using `magit-copy-section-value' +and `magit-copy-buffer-revision'. + +If the stack is empty or with a prefix argument, instead read a +revision in the minibuffer. By using the minibuffer history this +allows selecting an item which was popped earlier or to insert an +arbitrary reference or revision without first pushing it onto the +stack. + +When reading the revision from the minibuffer, then it might not +be possible to guess the correct repository. When this command +is called inside a repository (e.g. while composing a commit +message), then that repository is used. Otherwise (e.g. while +composing an email) then the repository recorded for the top +element of the stack is used (even though we insert another +revision). If not called inside a repository and with an empty +stack, or with two prefix arguments, then read the repository in +the minibuffer too." + (interactive + (if (or current-prefix-arg (not magit-revision-stack)) + (let ((default-directory + (or (and (not (= (prefix-numeric-value current-prefix-arg) 16)) + (or (magit-toplevel) + (cadr (car magit-revision-stack)))) + (magit-read-repository)))) + (list (magit-read-branch-or-commit "Insert revision") + default-directory)) + (push (caar magit-revision-stack) magit-revision-history) + (pop magit-revision-stack))) + (if rev + (pcase-let ((`(,pnt-format ,eob-format ,idx-format) + magit-pop-revision-stack-format)) + (let ((default-directory toplevel) + (idx (and idx-format + (save-excursion + (if (re-search-backward idx-format nil t) + (number-to-string + (1+ (string-to-number (match-string 1)))) + "1")))) + pnt-args eob-args) + (when (listp pnt-format) + (setq pnt-args (cdr pnt-format)) + (setq pnt-format (car pnt-format))) + (when (listp eob-format) + (setq eob-args (cdr eob-format)) + (setq eob-format (car eob-format))) + (when pnt-format + (when idx-format + (setq pnt-format + (replace-regexp-in-string "%N" idx pnt-format t t))) + (magit-rev-insert-format pnt-format rev pnt-args) + (backward-delete-char 1)) + (when eob-format + (when idx-format + (setq eob-format + (replace-regexp-in-string "%N" idx eob-format t t))) + (save-excursion + (goto-char (point-max)) + (skip-syntax-backward ">s-") + (beginning-of-line) + (if (and comment-start (looking-at comment-start)) + (while (looking-at comment-start) + (forward-line -1)) + (forward-line) + (unless (= (current-column) 0) + (insert ?\n))) + (insert ?\n) + (magit-rev-insert-format eob-format rev eob-args) + (backward-delete-char 1))))) + (user-error "Revision stack is empty"))) + +(define-key git-commit-mode-map + (kbd "C-c C-w") 'magit-pop-revision-stack) + +;;;###autoload +(defun magit-copy-section-value () + "Save the value of the current section for later use. + +Save the section value to the `kill-ring', and, provided that +the current section is a commit, branch, or tag section, push +the (referenced) revision to the `magit-revision-stack' for use +with `magit-pop-revision-stack'. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'. + +When the current section is a branch or a tag, and a prefix +argument is used, then save the revision at its tip to the +`kill-ring' instead of the reference name. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. If a prefix argument is used and the region is within a +hunk, strip the outer diff marker column." + (interactive) + (cond + ((and current-prefix-arg + (magit-section-internal-region-p) + (magit-section-match 'hunk)) + (deactivate-mark) + (kill-new (replace-regexp-in-string + "^[ \\+\\-]" "" + (buffer-substring-no-properties + (region-beginning) (region-end))))) + ((use-region-p) + (call-interactively #'copy-region-as-kill)) + (t + (when-let ((section (magit-current-section)) + (value (oref section value))) + (magit-section-case + ((branch commit module-commit tag) + (let ((default-directory default-directory) ref) + (magit-section-case + ((branch tag) + (setq ref value)) + (module-commit + (setq default-directory + (file-name-as-directory + (expand-file-name (magit-section-parent-value section) + (magit-toplevel)))))) + (setq value (magit-rev-parse + (and magit-copy-revision-abbreviated "--short") + value)) + (push (list value default-directory) magit-revision-stack) + (kill-new (message "%s" (or (and current-prefix-arg ref) + value))))) + (t (kill-new (message "%s" value)))))))) + +;;;###autoload +(defun magit-copy-buffer-revision () + "Save the revision of the current buffer for later use. + +Save the revision shown in the current buffer to the `kill-ring' +and push it to the `magit-revision-stack'. + +This command is mainly intended for use in `magit-revision-mode' +buffers, the only buffers where it is always unambiguous exactly +which revision should be saved. + +Most other Magit buffers usually show more than one revision, in +some way or another, so this command has to select one of them, +and that choice might not always be the one you think would have +been the best pick. + +In such buffers it is often more useful to save the value of +the current section instead, using `magit-copy-section-value'. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'." + (interactive) + (if (use-region-p) + (call-interactively #'copy-region-as-kill) + (when-let ((rev (or magit-buffer-revision + (cl-case major-mode + (magit-diff-mode + (if (string-match "\\.\\.\\.?\\(.+\\)" + magit-buffer-range) + (match-string 1 magit-buffer-range) + magit-buffer-range)) + (magit-status-mode "HEAD"))))) + (when (magit-commit-p rev) + (setq rev (magit-rev-parse + (and magit-copy-revision-abbreviated "--short") + rev)) + (push (list rev default-directory) magit-revision-stack) + (kill-new (message "%s" rev)))))) + +;;; Miscellaneous + +;;;###autoload +(defun magit-abort-dwim () + "Abort current operation. +Depending on the context, this will abort a merge, a rebase, a +patch application, a cherry-pick, a revert, or a bisect." + (interactive) + (cond ((magit-merge-in-progress-p) (magit-merge-abort)) + ((magit-rebase-in-progress-p) (magit-rebase-abort)) + ((magit-am-in-progress-p) (magit-am-abort)) + ((magit-sequencer-in-progress-p) (magit-sequencer-abort)) + ((magit-bisect-in-progress-p) (magit-bisect-reset)))) + +;;; _ +(provide 'magit-extras) +;;; magit-extras.el ends here diff --git a/elpa/magit-20200318.1224/magit-extras.elc b/elpa/magit-20200318.1224/magit-extras.elc new file mode 100644 index 00000000..a68e8b07 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-extras.elc differ diff --git a/elpa/magit-20200318.1224/magit-fetch.el b/elpa/magit-20200318.1224/magit-fetch.el new file mode 100644 index 00000000..a3a0cc65 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-fetch.el @@ -0,0 +1,186 @@ +;;; magit-fetch.el --- download objects and refs -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements fetch commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-fetch-modules-jobs 4 + "Number of submodules to fetch in parallel. +Ignored for Git versions before v2.8.0." + :package-version '(magit . "2.12.0") + :group 'magit-commands + :type '(choice (const :tag "one at a time" nil) number)) + +;;; Commands + +;;;###autoload (autoload 'magit-fetch "magit-fetch" nil t) +(define-transient-command magit-fetch () + "Fetch from another repository." + :man-page "git-fetch" + ["Arguments" + ("-p" "Prune deleted branches" ("-p" "--prune")) + ("-t" "Fetch all tags" ("-t" "--tags"))] + ["Fetch from" + ("p" magit-fetch-from-pushremote) + ("u" magit-fetch-from-upstream) + ("e" "elsewhere" magit-fetch-other) + ("a" "all remotes" magit-fetch-all)] + ["Fetch" + ("o" "another branch" magit-fetch-branch) + ("r" "explicit refspec" magit-fetch-refspec) + ("m" "submodules" magit-fetch-modules)] + ["Configure" + ("C" "variables..." magit-branch-configure)]) + +(defun magit-fetch-arguments () + (transient-args 'magit-fetch)) + +(defun magit-git-fetch (remote args) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "fetch" remote args)) + +;;;###autoload (autoload 'magit-fetch-from-pushremote "magit-fetch" nil t) +(define-suffix-command magit-fetch-from-pushremote (args) + "Fetch from the current push-remote. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :description 'magit-fetch--pushremote-description + (interactive (list (magit-fetch-arguments))) + (let ((remote (magit-get-push-remote))) + (when (or current-prefix-arg + (not (member remote (magit-list-remotes)))) + (let ((var (magit--push-remote-variable))) + (setq remote + (magit-read-remote (format "Set %s and fetch from there" var))) + (magit-set remote var))) + (magit-git-fetch remote args))) + +(defun magit-fetch--pushremote-description () + (let* ((branch (magit-get-current-branch)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + ((member remote (magit-list-remotes)) remote) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-fetch-from-upstream "magit-fetch" nil t) +(define-suffix-command magit-fetch-from-upstream (remote args) + "Fetch from the \"current\" remote, usually the upstream. + +If the upstream is configured for the current branch and names +an existing remote, then use that. Otherwise try to use another +remote: If only a single remote is configured, then use that. +Otherwise if a remote named \"origin\" exists, then use that. + +If no remote can be determined, then this command is not available +from the `magit-fetch' transient prefix and invoking it directly +results in an error." + :if (lambda () (magit-get-current-remote t)) + :description (lambda () (magit-get-current-remote t)) + (interactive (list (magit-get-current-remote t) + (magit-fetch-arguments))) + (unless remote + (error "The \"current\" remote could not be determined")) + (magit-git-fetch remote args)) + +;;;###autoload +(defun magit-fetch-other (remote args) + "Fetch from another repository." + (interactive (list (magit-read-remote "Fetch remote") + (magit-fetch-arguments))) + (magit-git-fetch remote args)) + +;;;###autoload +(defun magit-fetch-branch (remote branch args) + "Fetch a BRANCH from a REMOTE." + (interactive + (let ((remote (magit-read-remote-or-url "Fetch from remote or url"))) + (list remote + (magit-read-remote-branch "Fetch branch" remote) + (magit-fetch-arguments)))) + (magit-git-fetch remote (cons branch args))) + +;;;###autoload +(defun magit-fetch-refspec (remote refspec args) + "Fetch a REFSPEC from a REMOTE." + (interactive + (let ((remote (magit-read-remote-or-url "Fetch from remote or url"))) + (list remote + (magit-read-refspec "Fetch using refspec" remote) + (magit-fetch-arguments)))) + (magit-git-fetch remote (cons refspec args))) + +;;;###autoload +(defun magit-fetch-all (args) + "Fetch from all remotes." + (interactive (list (magit-fetch-arguments))) + (magit-git-fetch nil (cons "--all" args))) + +;;;###autoload +(defun magit-fetch-all-prune () + "Fetch from all remotes, and prune. +Prune remote tracking branches for branches that have been +removed on the respective remote." + (interactive) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "remote" "update" "--prune")) + +;;;###autoload +(defun magit-fetch-all-no-prune () + "Fetch from all remotes." + (interactive) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "remote" "update")) + +;;;###autoload +(defun magit-fetch-modules (&optional all) + "Fetch all submodules. + +Option `magit-fetch-modules-jobs' controls how many submodules +are being fetched in parallel. Also fetch the super-repository, +because `git-fetch' does not support not doing that. With a +prefix argument fetch all remotes." + (interactive "P") + (magit-with-toplevel + (magit-run-git-async + "fetch" "--verbose" "--recurse-submodules" + (and magit-fetch-modules-jobs + (version<= "2.8.0" (magit-git-version)) + (list "-j" (number-to-string magit-fetch-modules-jobs))) + (and all "--all")))) + +;;; _ +(provide 'magit-fetch) +;;; magit-fetch.el ends here diff --git a/elpa/magit-20200318.1224/magit-fetch.elc b/elpa/magit-20200318.1224/magit-fetch.elc new file mode 100644 index 00000000..78416596 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-fetch.elc differ diff --git a/elpa/magit-20200318.1224/magit-files.el b/elpa/magit-20200318.1224/magit-files.el new file mode 100644 index 00000000..3f0758d2 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-files.el @@ -0,0 +1,551 @@ +;;; magit-files.el --- finding files -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for finding blobs, staged files, +;; and Git configuration files. It also implements modes useful in +;; buffers visiting files and blobs, and the commands used by those +;; modes. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Find Blob + +(defvar magit-find-file-hook nil) +(add-hook 'magit-find-file-hook #'magit-blob-mode) + +;;;###autoload +(defun magit-find-file (rev file) + "View FILE from REV. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go +to the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file")) + (magit-find-file--internal rev file #'pop-to-buffer-same-window)) + +;;;###autoload +(defun magit-find-file-other-window (rev file) + "View FILE from REV, in another window. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file in other window")) + (magit-find-file--internal rev file #'switch-to-buffer-other-window)) + +;;;###autoload +(defun magit-find-file-other-frame (rev file) + "View FILE from REV, in another frame. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file in other frame")) + (magit-find-file--internal rev file #'switch-to-buffer-other-frame)) + +(defun magit-find-file-read-args (prompt) + (let ((pseudo-revs '("{worktree}" "{index}"))) + (if-let ((rev (magit-completing-read "Find file from revision" + (append pseudo-revs + (magit-list-refnames nil t)) + nil nil nil 'magit-revision-history + (or (magit-branch-or-commit-at-point) + (magit-get-current-branch))))) + (list rev (magit-read-file-from-rev (if (member rev pseudo-revs) + "HEAD" + rev) + prompt)) + (user-error "Nothing selected")))) + +(defun magit-find-file--internal (rev file fn) + (let ((buf (magit-find-file-noselect rev file)) + line col) + (when-let ((visited-file (magit-file-relative-name))) + (setq line (line-number-at-pos)) + (setq col (current-column)) + (cond + ((not (equal visited-file file))) + ((equal magit-buffer-revision rev)) + ((equal rev "{worktree}") + (setq line (magit-diff-visit--offset file magit-buffer-revision line))) + ((equal rev "{index}") + (setq line (magit-diff-visit--offset file nil line))) + (magit-buffer-revision + (setq line (magit-diff-visit--offset + file (concat magit-buffer-revision ".." rev) line))) + (t + (setq line (magit-diff-visit--offset file (list "-R" rev) line))))) + (funcall fn buf) + (when line + (with-current-buffer buf + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column col))) + buf)) + +(defun magit-find-file-noselect (rev file) + "Read FILE from REV into a buffer and return the buffer. +REV is a revision or one of \"{worktree}\" or \"{index}\". +FILE must be relative to the top directory of the repository." + (magit-find-file-noselect-1 rev file)) + +(defun magit-find-file-noselect-1 (rev file &optional revert) + "Read FILE from REV into a buffer and return the buffer. +REV is a revision or one of \"{worktree}\" or \"{index}\". +FILE must be relative to the top directory of the repository. +Non-nil REVERT means to revert the buffer. If `ask-revert', +then only after asking. A non-nil value for REVERT is ignored if REV is +\"{worktree}\"." + (if (equal rev "{worktree}") + (find-file-noselect (expand-file-name file (magit-toplevel))) + (let ((topdir (magit-toplevel))) + (when (file-name-absolute-p file) + (setq file (file-relative-name file topdir))) + (with-current-buffer (magit-get-revision-buffer-create rev file) + (when (or (not magit-buffer-file-name) + (if (eq revert 'ask-revert) + (y-or-n-p (format "%s already exists; revert it? " + (buffer-name)))) + revert) + (setq magit-buffer-revision + (if (equal rev "{index}") + "{index}" + (magit-rev-format "%H" rev))) + (setq magit-buffer-refname rev) + (setq magit-buffer-file-name (expand-file-name file topdir)) + (setq default-directory + (let ((dir (file-name-directory magit-buffer-file-name))) + (if (file-exists-p dir) dir topdir))) + (setq-local revert-buffer-function #'magit-revert-rev-file-buffer) + (revert-buffer t t) + (run-hooks (if (equal rev "{index}") + 'magit-find-index-hook + 'magit-find-file-hook))) + (current-buffer))))) + +(defun magit-get-revision-buffer-create (rev file) + (magit-get-revision-buffer rev file t)) + +(defun magit-get-revision-buffer (rev file &optional create) + (funcall (if create 'get-buffer-create 'get-buffer) + (format "%s.~%s~" file (subst-char-in-string ?/ ?_ rev)))) + +(defun magit-revert-rev-file-buffer (_ignore-auto noconfirm) + (when (or noconfirm + (and (not (buffer-modified-p)) + (catch 'found + (dolist (regexp revert-without-query) + (when (string-match regexp magit-buffer-file-name) + (throw 'found t))))) + (yes-or-no-p (format "Revert buffer from Git %s? " + (if (equal magit-buffer-refname "{index}") + "index" + (concat "revision " magit-buffer-refname))))) + (let* ((inhibit-read-only t) + (default-directory (magit-toplevel)) + (file (file-relative-name magit-buffer-file-name)) + (coding-system-for-read (or coding-system-for-read 'undecided))) + (erase-buffer) + (magit-git-insert "cat-file" "-p" + (if (equal magit-buffer-refname "{index}") + (concat ":" file) + (concat magit-buffer-refname ":" file))) + (setq buffer-file-coding-system last-coding-system-used)) + (let ((buffer-file-name magit-buffer-file-name) + (after-change-major-mode-hook + (remq 'global-diff-hl-mode-enable-in-buffers + after-change-major-mode-hook))) + (normal-mode t)) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (goto-char (point-min)))) + +;;; Find Index + +(defvar magit-find-index-hook nil) + +(defun magit-find-file-index-noselect (file &optional revert) + "Read FILE from the index into a buffer and return the buffer. +FILE must to be relative to the top directory of the repository." + (magit-find-file-noselect-1 "{index}" file (or revert 'ask-revert))) + +(defun magit-update-index () + "Update the index with the contents of the current buffer. +The current buffer has to be visiting a file in the index, which +is done using `magit-find-index-noselect'." + (interactive) + (let ((file (magit-file-relative-name))) + (unless (equal magit-buffer-refname "{index}") + (user-error "%s isn't visiting the index" file)) + (if (y-or-n-p (format "Update index with contents of %s" (buffer-name))) + (let ((index (make-temp-file "index")) + (buffer (current-buffer))) + (when magit-wip-before-change-mode + (magit-wip-commit-before-change (list file) " before un-/stage")) + (let ((coding-system-for-write buffer-file-coding-system)) + (with-temp-file index + (insert-buffer-substring buffer))) + (magit-with-toplevel + (magit-call-git "update-index" "--cacheinfo" + (substring (magit-git-string "ls-files" "-s" file) + 0 6) + (magit-git-string "hash-object" "-t" "blob" "-w" + (concat "--path=" file) + "--" index) + file)) + (set-buffer-modified-p nil) + (when magit-wip-after-apply-mode + (magit-wip-commit-after-apply (list file) " after un-/stage"))) + (message "Abort"))) + (--when-let (magit-get-mode-buffer 'magit-status-mode) + (with-current-buffer it (magit-refresh))) + t) + +;;; Find Config File + +(defun magit-find-git-config-file (filename &optional wildcards) + "Edit a file located in the current repository's git directory. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file', except that it temporarily +binds `default-directory' to the actual git directory, while +reading the FILENAME." + (interactive + (let ((default-directory (magit-git-dir))) + (find-file-read-args "Find file: " + (confirm-nonexistent-file-or-buffer)))) + (find-file filename wildcards)) + +(defun magit-find-git-config-file-other-window (filename &optional wildcards) + "Edit a file located in the current repository's git directory, in another window. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file-other-window', except that it +temporarily binds `default-directory' to the actual git +directory, while reading the FILENAME." + (interactive + (let ((default-directory (magit-git-dir))) + (find-file-read-args "Find file in other window: " + (confirm-nonexistent-file-or-buffer)))) + (find-file-other-window filename wildcards)) + +(defun magit-find-git-config-file-other-frame (filename &optional wildcards) + "Edit a file located in the current repository's git directory, in another frame. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file-other-frame', except that it +temporarily binds `default-directory' to the actual git +directory, while reading the FILENAME." + (interactive + (let ((default-directory (magit-git-dir))) + (find-file-read-args "Find file in other frame: " + (confirm-nonexistent-file-or-buffer)))) + (find-file-other-frame filename wildcards)) + +;;; File Mode + +(defvar magit-file-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-xg" 'magit-status) + (define-key map "\C-x\M-g" 'magit-dispatch) + (define-key map "\C-c\M-g" 'magit-file-dispatch) + map) + "Keymap for `magit-file-mode'.") + +;;;###autoload (autoload 'magit-file-dispatch "magit" nil t) +(define-transient-command magit-file-dispatch () + "Invoke a Magit command that acts on the visited file." + :info-manual "(magit) Minor Mode for Buffers Visiting Files" + ["Actions" + [("s" "Stage" magit-stage-file) + ("u" "Unstage" magit-unstage-file) + ("c" "Commit" magit-commit) + ("e" "Edit line" magit-edit-line-commit)] + [("D" "Diff..." magit-diff) + ("d" "Diff" magit-diff-buffer-file) + ("g" "Status" magit-status-here)] + [("L" "Log..." magit-log) + ("l" "Log" magit-log-buffer-file) + ("t" "Trace" magit-log-trace-definition)] + [("B" "Blame..." magit-blame) + ("b" "Blame" magit-blame-addition) + ("r" "...removal" magit-blame-removal) + ("f" "...reverse" magit-blame-reverse) + ("m" "Blame echo" magit-blame-echo) + ("q" "Quit blame" magit-blame-quit)] + [("p" "Prev blob" magit-blob-previous) + ("n" "Next blob" magit-blob-next) + ("v" "Goto blob" magit-find-file) + ("V" "Goto file" magit-blob-visit-file)] + [(5 "C-c r" "Rename file" magit-file-rename) + (5 "C-c d" "Delete file" magit-file-delete) + (5 "C-c u" "Untrack file" magit-file-untrack) + (5 "C-c c" "Checkout file" magit-file-checkout)]]) + +(defvar magit-file-mode-lighter "") + +(define-minor-mode magit-file-mode + "Enable some Magit features in a file-visiting buffer. + +Currently this only adds the following key bindings. +\n\\{magit-file-mode-map}" + :package-version '(magit . "2.2.0") + :lighter magit-file-mode-lighter + :keymap magit-file-mode-map) + +(defun magit-file-mode-turn-on () + (and buffer-file-name + (magit-inside-worktree-p t) + (magit-file-mode))) + +;;;###autoload +(define-globalized-minor-mode global-magit-file-mode + magit-file-mode magit-file-mode-turn-on + :package-version '(magit . "2.13.0") + :link '(info-link "(magit)Minor Mode for Buffers Visiting Files") + :group 'magit-essentials + :group 'magit-modes + :init-value t) +;; Unfortunately `:init-value t' only sets the value of the mode +;; variable but does not cause the mode function to be called, and we +;; cannot use `:initialize' to call that explicitly because the option +;; is defined before the functions, so we have to do it here. +(cl-eval-when (load eval) + (when global-magit-file-mode + (global-magit-file-mode 1))) + +;;; Blob Mode + +(defvar magit-blob-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "p" 'magit-blob-previous) + (define-key map "n" 'magit-blob-next) + (define-key map "b" 'magit-blame-addition) + (define-key map "r" 'magit-blame-removal) + (define-key map "f" 'magit-blame-reverse) + (define-key map "q" 'magit-kill-this-buffer) + map) + "Keymap for `magit-blob-mode'.") + +(define-minor-mode magit-blob-mode + "Enable some Magit features in blob-visiting buffers. + +Currently this only adds the following key bindings. +\n\\{magit-blob-mode-map}" + :package-version '(magit . "2.3.0")) + +(defun magit-blob-next () + "Visit the next blob which modified the current file." + (interactive) + (if magit-buffer-file-name + (magit-blob-visit (or (magit-blob-successor magit-buffer-revision + magit-buffer-file-name) + magit-buffer-file-name)) + (if (buffer-file-name (buffer-base-buffer)) + (user-error "You have reached the end of time") + (user-error "Buffer isn't visiting a file or blob")))) + +(defun magit-blob-previous () + "Visit the previous blob which modified the current file." + (interactive) + (if-let ((file (or magit-buffer-file-name + (buffer-file-name (buffer-base-buffer))))) + (--if-let (magit-blob-ancestor magit-buffer-revision file) + (magit-blob-visit it) + (user-error "You have reached the beginning of time")) + (user-error "Buffer isn't visiting a file or blob"))) + +;;;###autoload +(defun magit-blob-visit-file () + "View the file from the worktree corresponding to the current blob. +When visiting a blob or the version from the index, then go to +the same location in the respective file in the working tree." + (interactive) + (if-let ((file (magit-file-relative-name))) + (magit-find-file--internal "{worktree}" file #'pop-to-buffer-same-window) + (user-error "Not visiting a blob"))) + +(defun magit-blob-visit (blob-or-file) + (if (stringp blob-or-file) + (find-file blob-or-file) + (pcase-let ((`(,rev ,file) blob-or-file)) + (magit-find-file rev file) + (apply #'message "%s (%s %s ago)" + (magit-rev-format "%s" rev) + (magit--age (magit-rev-format "%ct" rev)))))) + +(defun magit-blob-ancestor (rev file) + (let ((lines (magit-with-toplevel + (magit-git-lines "log" "-2" "--format=%H" "--name-only" + "--follow" (or rev "HEAD") "--" file)))) + (if rev (cddr lines) (butlast lines 2)))) + +(defun magit-blob-successor (rev file) + (let ((lines (magit-with-toplevel + (magit-git-lines "log" "--format=%H" "--name-only" "--follow" + "HEAD" "--" file)))) + (catch 'found + (while lines + (if (equal (nth 2 lines) rev) + (throw 'found (list (nth 0 lines) (nth 1 lines))) + (setq lines (nthcdr 2 lines))))))) + +;;; File Commands + +(defun magit-file-rename (file newname) + "Rename the FILE to NEWNAME. +If FILE isn't tracked in Git, fallback to using `rename-file'." + (interactive + (let* ((file (magit-read-file "Rename file")) + (dir (file-name-directory file)) + (newname (read-file-name (format "Rename %s to file: " file) + (and dir (expand-file-name dir))))) + (list (expand-file-name file (magit-toplevel)) + (expand-file-name newname)))) + (let ((oldbuf (get-file-buffer file))) + (when (and oldbuf (buffer-modified-p oldbuf)) + (user-error "Save %s before moving it" file)) + (when (file-exists-p newname) + (user-error "%s already exists" newname)) + (if (magit-file-tracked-p (magit-convert-filename-for-git file)) + (magit-call-git "mv" + (magit-convert-filename-for-git file) + (magit-convert-filename-for-git newname)) + (rename-file file newname current-prefix-arg)) + (when oldbuf + (with-current-buffer oldbuf + (let ((buffer-read-only buffer-read-only)) + (set-visited-file-name newname nil t)) + (if (fboundp 'vc-refresh-state) + (vc-refresh-state) + (with-no-warnings + (vc-find-file-hook)))))) + (magit-refresh)) + +(defun magit-file-untrack (files &optional force) + "Untrack the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +staged as well as unstaged changes." + (interactive (list (or (--if-let (magit-region-values 'file t) + (progn + (unless (magit-file-tracked-p (car it)) + (user-error "Already untracked")) + (magit-confirm-files 'untrack it "Untrack")) + (list (magit-read-tracked-file "Untrack file")))) + current-prefix-arg)) + (magit-with-toplevel + (magit-run-git "rm" "--cached" (and force "--force") "--" files))) + +(defun magit-file-delete (files &optional force) + "Delete the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +uncommitted changes. When the files aren't being tracked in +Git, then fallback to using `delete-file'." + (interactive (list (--if-let (magit-region-values 'file t) + (magit-confirm-files 'delete it "Delete") + (list (magit-read-file "Delete file"))) + current-prefix-arg)) + (if (magit-file-tracked-p (car files)) + (magit-call-git "rm" (and force "--force") "--" files) + (let ((topdir (magit-toplevel))) + (dolist (file files) + (delete-file (expand-file-name file topdir) t)))) + (magit-refresh)) + +;;;###autoload +(defun magit-file-checkout (rev file) + "Checkout FILE from REV." + (interactive + (let ((rev (magit-read-branch-or-commit + "Checkout from revision" magit-buffer-revision))) + (list rev (magit-read-file-from-rev rev "Checkout file")))) + (magit-with-toplevel + (magit-run-git "checkout" rev "--" file))) + +;;; Read File + +(defvar magit-read-file-hist nil) + +(defun magit-read-file-from-rev (rev prompt &optional default) + (let ((files (magit-revision-files rev))) + (magit-completing-read + prompt files nil t nil 'magit-read-file-hist + (car (member (or default (magit-current-file)) files))))) + +(defun magit-read-file (prompt &optional tracked-only) + (let ((choices (nconc (magit-list-files) + (unless tracked-only (magit-untracked-files))))) + (magit-completing-read + prompt choices nil t nil nil + (car (member (or (magit-section-value-if '(file submodule)) + (magit-file-relative-name nil tracked-only)) + choices))))) + +(defun magit-read-tracked-file (prompt) + (magit-read-file prompt t)) + +(defun magit-read-file-choice (prompt files &optional error default) + "Read file from FILES. + +If FILES has only one member, return that instead of prompting. +If FILES has no members, give a user error. ERROR can be given +to provide a more informative error. + +If DEFAULT is non-nil, use this as the default value instead of +`magit-current-file'." + (pcase (length files) + (0 (user-error (or error "No file choices"))) + (1 (car files)) + (_ (magit-completing-read + prompt files nil t nil 'magit-read-file-hist + (car (member (or default (magit-current-file)) files)))))) + +(defun magit-read-changed-file (rev-or-range prompt &optional default) + (magit-read-file-choice + prompt + (magit-changed-files rev-or-range) + default + (concat "No file changed in " rev-or-range))) + +;;; _ +(provide 'magit-files) +;;; magit-files.el ends here diff --git a/elpa/magit-20200318.1224/magit-files.elc b/elpa/magit-20200318.1224/magit-files.elc new file mode 100644 index 00000000..0717d0ed Binary files /dev/null and b/elpa/magit-20200318.1224/magit-files.elc differ diff --git a/elpa/magit-20200318.1224/magit-git.el b/elpa/magit-20200318.1224/magit-git.el new file mode 100644 index 00000000..e1970ba9 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-git.el @@ -0,0 +1,2309 @@ +;;; magit-git.el --- Git functionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements wrappers for various Git plumbing commands. + +;;; Code: + +(require 'cl-lib) +(require 'dash) + +(eval-when-compile + (require 'subr-x)) + +(require 'magit-utils) +(require 'magit-section) + +;; From `magit-branch'. +(defvar magit-branch-prefer-remote-upstream) +(defvar magit-published-branches) + +;; From `magit-margin'. +(declare-function magit-maybe-make-margin-overlay "magit-margin" ()) + +;; From `magit-mode'. +(declare-function magit-get-mode-buffer "magit-mode" + (mode &optional value frame)) +(declare-function magit-refresh "magit-mode" ()) +(defvar magit-buffer-diff-args) +(defvar magit-buffer-file-name) +(defvar magit-buffer-log-args) +(defvar magit-buffer-log-files) +(defvar magit-buffer-refname) +(defvar magit-buffer-revision) + +;; From `magit-process'. +(declare-function magit-call-git "magit-process" (&rest args)) +(declare-function magit-process-buffer "magit-process" (&optional nodisplay)) +(declare-function magit-process-file "magit-process" (&rest args)) +(declare-function magit-process-insert-section "magit-process" + (pwd program args &optional errcode errlog)) +(defvar magit-this-error) +(defvar magit-process-error-message-regexps) + +;; From later in `magit-git'. +(defvar magit-tramp-process-environment nil) + +(eval-when-compile + (cl-pushnew 'number eieio--known-slot-names)) + +;;; Git implementations + +(defvar magit-inhibit-libgit nil + "Whether to inhibit the use of libgit.") + +(defvar magit--libgit-available-p eieio-unbound + "Whether libgit is available. +Use the function by the same name instead of this variable.") + +(defun magit--libgit-available-p () + (if (eq magit--libgit-available-p eieio-unbound) + (setq magit--libgit-available-p + (and module-file-suffix + (let ((libgit (locate-library "libgit"))) + (and libgit + (or (locate-library "libegit2") + (let ((load-path + (cons (expand-file-name + (convert-standard-filename "build") + (file-name-directory libgit)) + load-path))) + (locate-library "libegit2"))))))) + magit--libgit-available-p)) + +(defun magit-gitimpl () + "Return the Git implementation used in this repository." + (if (and (not magit-inhibit-libgit) + (not (file-remote-p default-directory)) + (magit--libgit-available-p)) + 'libgit + 'git)) + +;;; Options + +;; For now this is shared between `magit-process' and `magit-git'. +(defgroup magit-process nil + "Git and other external processes used by Magit." + :group 'magit) + +(defvar magit-git-environment + (list (format "INSIDE_EMACS=%s,magit" emacs-version)) + "Prepended to `process-environment' while running git.") + +(defcustom magit-git-output-coding-system + (and (eq system-type 'windows-nt) 'utf-8) + "Coding system for receiving output from Git. + +If non-nil, the Git config value `i18n.logOutputEncoding' should +be set via `magit-git-global-arguments' to value consistent with +this." + :package-version '(magit . "2.9.0") + :group 'magit-process + :type '(choice (coding-system :tag "Coding system to decode Git output") + (const :tag "Use system default" nil))) + +(defvar magit-git-w32-path-hack nil + "Alist of (EXE . (PATHENTRY)). +This specifies what additional PATH setting needs to be added to +the environment in order to run the non-wrapper git executables +successfully.") + +(defcustom magit-git-executable + ;; Git might be installed in a different location on a remote, so + ;; it is better not to use the full path to the executable, except + ;; on Window were we would otherwise end up using one one of the + ;; wrappers "cmd/git.exe" or "cmd/git.cmd", which are much slower + ;; than using "bin/git.exe" directly. + (or (and (eq system-type 'windows-nt) + (--when-let (executable-find "git") + (ignore-errors + ;; Git for Windows 2.x provides cygpath so we can + ;; ask it for native paths. + (let* ((core-exe + (car + (process-lines + it "-c" + "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" + "X" "git"))) + (hack-entry (assoc core-exe magit-git-w32-path-hack)) + ;; Running the libexec/git-core executable + ;; requires some extra PATH entries. + (path-hack + (list (concat "PATH=" + (car (process-lines + it "-c" + "alias.P=!cygpath -wp \"$PATH\"" + "P")))))) + ;; The defcustom STANDARD expression can be + ;; evaluated many times, so make sure it is + ;; idempotent. + (if hack-entry + (setcdr hack-entry path-hack) + (push (cons core-exe path-hack) magit-git-w32-path-hack)) + core-exe)))) + "git") + "The Git executable used by Magit." + :group 'magit-process + :type 'string) + +(defcustom magit-git-global-arguments + `("--no-pager" "--literal-pathspecs" + "-c" "core.preloadindex=true" + "-c" "log.showSignature=false" + "-c" "color.ui=false" + "-c" "color.diff=false" + ,@(and (eq system-type 'windows-nt) + (list "-c" "i18n.logOutputEncoding=UTF-8"))) + "Global Git arguments. + +The arguments set here are used every time the git executable is +run as a subprocess. They are placed right after the executable +itself and before the git command - as in `git HERE... COMMAND +REST'. See the manpage `git(1)' for valid arguments. + +Be careful what you add here, especially if you are using Tramp +to connect to servers with ancient Git versions. Never remove +anything that is part of the default value, unless you really +know what you are doing. And think very hard before adding +something; it will be used every time Magit runs Git for any +purpose." + :package-version '(magit . "2.9.0") + :group 'magit-commands + :group 'magit-process + :type '(repeat string)) + +(defvar magit-git-debug nil + "Whether to enable additional reporting of git errors. + +Magit basically calls git for one of these two reasons: for +side-effects or to do something with its standard output. + +When git is run for side-effects then its output, including error +messages, go into the process buffer which is shown when using \ +\\\\[magit-process]. + +When git's output is consumed in some way, then it would be too +expensive to also insert it into this buffer, but when this +option is non-nil and git returns with a non-zero exit status, +then at least its standard error is inserted into this buffer. + +This is only intended for debugging purposes. Do not enable this +permanently, that would negatively affect performance.") + + +(defcustom magit-prefer-remote-upstream nil + "Whether to favor remote branches when reading the upstream branch. + +This controls whether commands that read a branch from the user +and then set it as the upstream branch, offer a local or a remote +branch as default completion candidate, when they have the choice. + +This affects all commands that use `magit-read-upstream-branch' +or `magit-read-starting-point', which includes most commands +that change the upstream and many that create new branches." + :package-version '(magit . "2.4.2") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-list-refs-sortby nil + "How to sort the ref collection in the prompt. + +This affects commands that read a ref. More specifically, it +controls the order of refs returned by `magit-list-refs', which +is called by functions like `magit-list-branch-names' to generate +the collection of refs. By default, refs are sorted according to +their full refname (i.e., 'refs/...'). + +Any value accepted by the `--sort' flag of `git for-each-ref' can +be used. For example, \"-creatordate\" places refs with more +recent committer or tagger dates earlier in the list. A list of +strings can also be given in order to pass multiple sort keys to +`git for-each-ref'. + +Note that, depending on the completion framework you use, this +may not be sufficient to change the order in which the refs are +displayed. It only controls the order of the collection passed +to `magit-completing-read' or, for commands that support reading +multiple strings, `read-from-minibuffer'. The completion +framework ultimately determines how the collection is displayed." + :package-version '(magit . "2.11.0") + :group 'magit-miscellaneous + :type '(choice string (repeat string))) + +;;; Git + +(defvar magit--refresh-cache nil) + +(defmacro magit--with-refresh-cache (key &rest body) + (declare (indent 1) (debug (form body))) + (let ((k (cl-gensym))) + `(if magit--refresh-cache + (let ((,k ,key)) + (--if-let (assoc ,k (cdr magit--refresh-cache)) + (progn (cl-incf (caar magit--refresh-cache)) + (cdr it)) + (cl-incf (cdar magit--refresh-cache)) + (let ((value ,(macroexp-progn body))) + (push (cons ,k value) + (cdr magit--refresh-cache)) + value))) + ,@body))) + +(defvar magit-with-editor-envvar "GIT_EDITOR" + "The environment variable exported by `magit-with-editor'. +Set this to \"GIT_SEQUENCE_EDITOR\" if you do not want to use +Emacs to edit commit messages but would like to do so to edit +rebase sequences.") + +(defmacro magit-with-editor (&rest body) + "Like `with-editor' but let-bind some more variables. +Also respect the value of `magit-with-editor-envvar'." + (declare (indent 0) (debug (body))) + `(let ((magit-process-popup-time -1) + ;; The user may have customized `shell-file-name' to + ;; something which results in `w32-shell-dos-semantics' nil + ;; (which changes the quoting style used by + ;; `shell-quote-argument'), but Git for Windows expects shell + ;; quoting in the dos style. + (shell-file-name (if (and (eq system-type 'windows-nt) + ;; If we have Cygwin mount points, + ;; the git flavor is cygwin, so dos + ;; shell quoting is probably wrong. + (not magit-cygwin-mount-points)) + "cmdproxy" + shell-file-name))) + (with-editor* magit-with-editor-envvar + ,@body))) + +(defun magit-process-git-arguments (args) + "Prepare ARGS for a function that invokes Git. + +Magit has many specialized functions for running Git; they all +pass arguments through this function before handing them to Git, +to do the following. + +* Flatten ARGS, removing nil arguments. +* Prepend `magit-git-global-arguments' to ARGS. +* On w32 systems, encode to `w32-ansi-code-page'." + (setq args (append magit-git-global-arguments (-flatten args))) + (if (and (eq system-type 'windows-nt) (boundp 'w32-ansi-code-page)) + ;; On w32, the process arguments *must* be encoded in the + ;; current code-page (see #3250). + (mapcar (lambda (arg) + (encode-coding-string + arg (intern (format "cp%d" w32-ansi-code-page)))) + args) + args)) + +(defun magit-git-exit-code (&rest args) + "Execute Git with ARGS, returning its exit code." + (apply #'magit-process-file magit-git-executable nil nil nil + (magit-process-git-arguments args))) + +(defun magit-git-success (&rest args) + "Execute Git with ARGS, returning t if its exit code is 0." + (= (magit-git-exit-code args) 0)) + +(defun magit-git-failure (&rest args) + "Execute Git with ARGS, returning t if its exit code is 1." + (= (magit-git-exit-code args) 1)) + +(defun magit-git-string-p (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then return +nil. Neither of these results is considered an error; if that is +what you want, then use `magit-git-string-ng' instead. + +This is an experimental replacement for `magit-git-string', and +still subject to major changes." + (magit--with-refresh-cache (cons default-directory args) + (with-temp-buffer + (and (zerop (apply #'magit-process-file magit-git-executable nil t nil + (magit-process-git-arguments args))) + (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position))))))) + +(defun magit-git-string-ng (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then that +is considered an error, but instead of actually signaling an +error, return nil. Additionally the output is put in the process +buffer (creating it if necessary) and the error message is shown +in the status buffer (provided it exists). + +This is an experimental replacement for `magit-git-string', and +still subject to major changes. Also see `magit-git-string-p'." + (magit--with-refresh-cache + (list default-directory 'magit-git-string-ng args) + (with-temp-buffer + (let* ((args (magit-process-git-arguments args)) + (status (apply #'magit-process-file magit-git-executable + nil t nil args))) + (if (zerop status) + (and (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties + (point) (line-end-position)))) + (let ((buf (current-buffer))) + (with-current-buffer (magit-process-buffer t) + (magit-process-insert-section default-directory + magit-git-executable args + status buf))) + (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) + (let ((msg (magit--locate-error-message))) + (with-current-buffer status-buf + (setq magit-this-error msg)))) + nil))))) + +(defun magit-git-str (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string. Like `magit-git-string' but +ignore `magit-git-debug'." + (setq args (-flatten args)) + (magit--with-refresh-cache (cons default-directory args) + (with-temp-buffer + (apply #'magit-process-file magit-git-executable nil (list t nil) nil + (magit-process-git-arguments args)) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-output (&rest args) + "Execute Git with ARGS, returning its output." + (setq args (-flatten args)) + (magit--with-refresh-cache (cons default-directory args) + (with-temp-buffer + (apply #'magit-process-file magit-git-executable nil (list t nil) nil + (magit-process-git-arguments args)) + (buffer-substring-no-properties (point-min) (point-max))))) + +(define-error 'magit-invalid-git-boolean "Not a Git boolean") + +(defun magit-git-true (&rest args) + "Execute Git with ARGS, returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") t) + ((or "false" "false\n") nil) + (output (signal 'magit-invalid-git-boolean output)))) + +(defun magit-git-false (&rest args) + "Execute Git with ARGS, returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") nil) + ((or "false" "false\n") t) + (output (signal 'magit-invalid-git-boolean output)))) + +(defun magit-git-insert (&rest args) + "Execute Git with ARGS, inserting its output at point. +If Git exits with a non-zero exit status, then show a message and +add a section in the respective process buffer." + (setq args (magit-process-git-arguments args)) + (if magit-git-debug + (let (log) + (unwind-protect + (progn + (setq log (make-temp-file "magit-stderr")) + (delete-file log) + (let ((exit (apply #'magit-process-file magit-git-executable + nil (list t log) nil args))) + (when (> exit 0) + (let ((msg "Git failed")) + (when (file-exists-p log) + (setq msg (with-temp-buffer + (insert-file-contents log) + (goto-char (point-max)) + (if (functionp magit-git-debug) + (funcall magit-git-debug (buffer-string)) + (magit--locate-error-message)))) + (let ((magit-git-debug nil)) + (with-current-buffer (magit-process-buffer t) + (magit-process-insert-section default-directory + magit-git-executable + args exit log)))) + (message "%s" msg))) + exit)) + (ignore-errors (delete-file log)))) + (apply #'magit-process-file magit-git-executable + nil (list t nil) nil args))) + +(defun magit--locate-error-message () + (goto-char (point-max)) + (and (run-hook-wrapped 'magit-process-error-message-regexps + (lambda (re) (re-search-backward re nil t))) + (match-string-no-properties 1))) + +(defun magit-git-string (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string." + (setq args (-flatten args)) + (magit--with-refresh-cache (cons default-directory args) + (with-temp-buffer + (apply #'magit-git-insert args) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-lines (&rest args) + "Execute Git with ARGS, returning its output as a list of lines. +Empty lines anywhere in the output are omitted. + +If Git exits with a non-zero exit status, then report show a +message and add a section in the respective process buffer." + (with-temp-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\n" t))) + +(defun magit-git-items (&rest args) + "Execute Git with ARGS, returning its null-separated output as a list. +Empty items anywhere in the output are omitted. + +If Git exits with a non-zero exit status, then report show a +message and add a section in the respective process buffer." + (with-temp-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\0" t))) + +(defun magit-git-wash (washer &rest args) + "Execute Git with ARGS, inserting washed output at point. +Actually first insert the raw output at point. If there is no +output, call `magit-cancel-section'. Otherwise temporarily narrow +the buffer to the inserted text, move to its beginning, and then +call function WASHER with ARGS as its sole argument." + (declare (indent 1)) + (let ((beg (point))) + (setq args (-flatten args)) + (magit-git-insert args) + (if (= (point) beg) + (magit-cancel-section) + (unless (bolp) + (insert "\n")) + (save-restriction + (narrow-to-region beg (point)) + (goto-char beg) + (funcall washer args)) + (when (or (= (point) beg) + (= (point) (1+ beg))) + (magit-cancel-section)) + (magit-maybe-make-margin-overlay)))) + +(defun magit-git-version (&optional raw) + (--when-let (let (magit-git-global-arguments) + (ignore-errors (substring (magit-git-string "version") 12))) + (if raw it (and (string-match "\\`\\([0-9]+\\(\\.[0-9]+\\)\\{1,2\\}\\)" it) + (match-string 1 it))))) + +;;; Variables + +(defun magit-config-get-from-cached-list (key) + (gethash + ;; `git config --list' downcases first and last components of the key. + (--> key + (replace-regexp-in-string "\\`[^.]+" #'downcase it t t) + (replace-regexp-in-string "[^.]+\\'" #'downcase it t t)) + (magit--with-refresh-cache (cons (magit-toplevel) 'config) + (let ((configs (make-hash-table :test 'equal))) + (dolist (conf (magit-git-items "config" "--list" "-z")) + (let* ((nl-pos (cl-position ?\n conf)) + (key (substring conf 0 nl-pos)) + (val (if nl-pos (substring conf (1+ nl-pos)) ""))) + (puthash key (nconc (gethash key configs) (list val)) configs))) + configs)))) + +(defun magit-get (&rest keys) + "Return the value of the Git variable specified by KEYS." + (car (last (apply 'magit-get-all keys)))) + +(defun magit-get-all (&rest keys) + "Return all values of the Git variable specified by KEYS." + (let ((magit-git-debug nil) + (arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (mapconcat 'identity keys "."))) + (if (and magit--refresh-cache (not arg)) + (magit-config-get-from-cached-list key) + (magit-git-items "config" arg "-z" "--get-all" key)))) + +(defun magit-get-boolean (&rest keys) + "Return the boolean value of the Git variable specified by KEYS." + (let ((key (mapconcat 'identity keys "."))) + (if magit--refresh-cache + (equal "true" (car (last (magit-config-get-from-cached-list key)))) + (equal (magit-git-str "config" "--bool" key) "true")))) + +(defun magit-set (value &rest keys) + "Set the value of the Git variable specified by KEYS to VALUE." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (mapconcat 'identity keys "."))) + (if value + (magit-git-success "config" arg key value) + (magit-git-success "config" arg "--unset" key)) + value)) + +(gv-define-setter magit-get (val &rest keys) + `(magit-set ,val ,@keys)) + +(defun magit-set-all (values &rest keys) + "Set all values of the Git variable specified by KEYS to VALUES." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (var (mapconcat 'identity keys "."))) + (when (magit-get var) + (magit-call-git "config" arg "--unset-all" var)) + (dolist (v values) + (magit-call-git "config" arg "--add" var v)))) + +;;; Files + +(defun magit--safe-default-directory (&optional file) + (catch 'unsafe-default-dir + (let ((dir (file-name-as-directory + (expand-file-name (or file default-directory)))) + (previous nil)) + (while (not (magit-file-accessible-directory-p dir)) + (setq dir (file-name-directory (directory-file-name dir))) + (when (equal dir previous) + (throw 'unsafe-default-dir nil)) + (setq previous dir)) + dir))) + +(defmacro magit--with-safe-default-directory (file &rest body) + (declare (indent 1) (debug (form body))) + `(when-let ((default-directory (magit--safe-default-directory ,file))) + ,@body)) + +(defun magit-gitdir (&optional directory) + "Return the absolute and resolved path of the .git directory. + +If the `GIT_DIR' environment variable is define then return that. +Otherwise return the .git directory for DIRECTORY, or if that is +nil, then for `default-directory' instead. If the directory is +not located inside a Git repository, then return nil." + (let ((default-directory (or directory default-directory))) + (magit-git-dir))) + +(defun magit-git-dir (&optional path) + "Return the absolute and resolved path of the .git directory. + +If the `GIT_DIR' environment variable is define then return that. +Otherwise return the .git directory for `default-directory'. If +the directory is not located inside a Git repository, then return +nil." + (magit--with-refresh-cache (list default-directory 'magit-git-dir path) + (magit--with-safe-default-directory nil + (when-let ((dir (magit-rev-parse-safe "--git-dir"))) + (setq dir (file-name-as-directory (magit-expand-git-file-name dir))) + (unless (file-remote-p dir) + (setq dir (concat (file-remote-p default-directory) dir))) + (if path (expand-file-name (convert-standard-filename path) dir) dir))))) + +(defvar magit--separated-gitdirs nil) + +(defun magit--record-separated-gitdir () + (let ((topdir (magit-toplevel)) + (gitdir (magit-git-dir))) + ;; Kludge: git-annex converts submodule gitdirs to symlinks. See #3599. + (when (file-symlink-p (directory-file-name gitdir)) + (setq gitdir (file-truename gitdir))) + ;; We want to delete the entry for `topdir' here, rather than within + ;; (unless ...), in case a `--separate-git-dir' repository was switched to + ;; the standard structure (i.e., "topdir/.git/"). + (setq magit--separated-gitdirs (cl-delete topdir + magit--separated-gitdirs + :key #'car :test #'equal)) + (unless (equal (file-name-as-directory (expand-file-name ".git" topdir)) + gitdir) + (push (cons topdir gitdir) magit--separated-gitdirs)))) + +(defun magit-toplevel (&optional directory) + "Return the absolute path to the toplevel of the current repository. + +From within the working tree or control directory of a repository +return the absolute path to the toplevel directory of the working +tree. As a special case, from within a bare repository return +the control directory instead. When called outside a repository +then return nil. + +When optional DIRECTORY is non-nil then return the toplevel for +that directory instead of the one for `default-directory'. + +Try to respect the option `find-file-visit-truename', i.e. when +the value of that option is nil, then avoid needlessly returning +the truename. When a symlink to a sub-directory of the working +tree is involved, or when called from within a sub-directory of +the gitdir or from the toplevel of a gitdir, which itself is not +located within the working tree, then it is not possible to avoid +returning the truename." + (magit--with-refresh-cache + (cons (or directory default-directory) 'magit-toplevel) + (magit--with-safe-default-directory directory + (if-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (let (updir) + (setq topdir (magit-expand-git-file-name topdir)) + (if (and + ;; Always honor these settings. + (not find-file-visit-truename) + (not (getenv "GIT_WORK_TREE")) + ;; `--show-cdup' is the relative path to the toplevel + ;; from `(file-truename default-directory)'. Here we + ;; pretend it is relative to `default-directory', and + ;; go to that directory. Then we check whether + ;; `--show-toplevel' still returns the same value and + ;; whether `--show-cdup' now is the empty string. If + ;; both is the case, then we are at the toplevel of + ;; the same working tree, but also avoided needlessly + ;; following any symlinks. + (progn + (setq updir (file-name-as-directory + (magit-rev-parse-safe "--show-cdup"))) + (setq updir (if (file-name-absolute-p updir) + (concat (file-remote-p default-directory) updir) + (expand-file-name updir))) + (let ((default-directory updir)) + (and (string-equal (magit-rev-parse-safe "--show-cdup") "") + (--when-let (magit-rev-parse-safe "--show-toplevel") + (string-equal (magit-expand-git-file-name it) + topdir)))))) + updir + (concat (file-remote-p default-directory) + (file-name-as-directory topdir)))) + (when-let ((gitdir (magit-rev-parse-safe "--git-dir"))) + (setq gitdir (file-name-as-directory + (if (file-name-absolute-p gitdir) + ;; We might have followed a symlink. + (concat (file-remote-p default-directory) + (magit-expand-git-file-name gitdir)) + (expand-file-name gitdir)))) + (if (magit-bare-repo-p) + gitdir + (let* ((link (expand-file-name "gitdir" gitdir)) + (wtree (and (file-exists-p link) + (magit-file-line link)))) + (cond + ((and wtree + ;; Ignore .git/gitdir files that result from a + ;; Git bug. See #2364. + (not (equal wtree ".git"))) + ;; Return the linked working tree. + (file-name-directory wtree)) + ;; The working directory may not be the parent directory of + ;; .git if it was set up with `git init --separate-git-dir'. + ;; See #2955. + ((car (rassoc gitdir magit--separated-gitdirs))) + (t + ;; Step outside the control directory to enter the working tree. + (file-name-directory (directory-file-name gitdir))))))))))) + +(defmacro magit-with-toplevel (&rest body) + (declare (indent defun) (debug (body))) + (let ((toplevel (cl-gensym "toplevel"))) + `(let ((,toplevel (magit-toplevel))) + (if ,toplevel + (let ((default-directory ,toplevel)) + ,@body) + (magit--not-inside-repository-error))))) + +(define-error 'magit-outside-git-repo "Not inside Git repository") +(define-error 'magit-git-executable-not-found + "Git executable cannot be found (see https://magit.vc/goto/e6a78ed2)") + +(defun magit--not-inside-repository-error () + (if (executable-find magit-git-executable) + (signal 'magit-outside-git-repo default-directory) + (signal 'magit-git-executable-not-found magit-git-executable))) + +(defun magit-inside-gitdir-p (&optioal noerror) + "Return t if `default-directory' is below the repository directory. +If it is below the working directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + ;; Below a repository directory that is not located below the + ;; working directory "git rev-parse --is-inside-git-dir" prints + ;; "false", which is wrong. + (let ((gitdir (magit-git-dir))) + (cond (gitdir (file-in-directory-p default-directory gitdir)) + (noerror nil) + (t (signal 'magit-outside-git-repo default-directory)))))) + +(defun magit-inside-worktree-p (&optional noerror) + "Return t if `default-directory' is below the working directory. +If it is below the repository directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-inside-work-tree") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(cl-defgeneric magit-bare-repo-p (&optional noerror) + "Return t if the current repository is bare. +If it is non-bare, then return nil. If `default-directory' +isn't below a Git repository, then signal an error unless +NOERROR is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-bare-repository") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(defun magit--assert-default-directory (&optional noerror) + (or (file-directory-p default-directory) + (and (not noerror) + (let ((exists (file-exists-p default-directory))) + (signal (if exists 'file-error 'file-missing) + (list "Running git in directory" + (if exists + "Not a directory" + "No such file or directory") + default-directory)))))) + +(defun magit-git-repo-p (directory &optional non-bare) + "Return t if DIRECTORY is a Git repository. +When optional NON-BARE is non-nil also return nil if DIRECTORY is +a bare repository." + (and (file-directory-p directory) ; Avoid archives, see #3397. + (or (file-regular-p (expand-file-name ".git" directory)) + (file-directory-p (expand-file-name ".git" directory)) + (and (not non-bare) + (file-regular-p (expand-file-name "HEAD" directory)) + (file-directory-p (expand-file-name "refs" directory)) + (file-directory-p (expand-file-name "objects" directory)))))) + +(defun magit-file-relative-name (&optional file tracked) + "Return the path of FILE relative to the repository root. + +If optional FILE is nil or omitted, return the relative path of +the file being visited in the current buffer, if any, else nil. +If the file is not inside a Git repository, then return nil. + +If TRACKED is non-nil, return the path only if it matches a +tracked file." + (unless file + (with-current-buffer (or (buffer-base-buffer) + (current-buffer)) + (setq file (or magit-buffer-file-name buffer-file-name + (and (derived-mode-p 'dired-mode) default-directory))))) + (when (and file (or (not tracked) + (magit-file-tracked-p (file-relative-name file)))) + (--when-let (magit-toplevel + (magit--safe-default-directory + (directory-file-name (file-name-directory file)))) + (file-relative-name file it)))) + +(defun magit-file-tracked-p (file) + (magit-git-success "ls-files" "--error-unmatch" file)) + +(defun magit-list-files (&rest args) + (apply #'magit-git-items "ls-files" "-z" "--full-name" args)) + +(defun magit-tracked-files () + (magit-list-files "--cached")) + +(defun magit-untracked-files (&optional all files) + (magit-list-files "--other" (unless all "--exclude-standard") "--" files)) + +(defun magit-unstaged-files (&optional nomodules files) + (magit-git-items "diff-files" "-z" "--name-only" + (and nomodules "--ignore-submodules") + "--" files)) + +(defun magit-staged-files (&optional nomodules files) + (magit-git-items "diff-index" "-z" "--name-only" "--cached" + (and nomodules "--ignore-submodules") + (magit-headish) "--" files)) + +(defun magit-binary-files (&rest args) + (--mapcat (and (string-match "^-\t-\t\\(.+\\)" it) + (list (match-string 1 it))) + (apply #'magit-git-items + "diff" "-z" "--numstat" "--ignore-submodules" + args))) + +(defun magit-unmerged-files () + (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=U")) + +(defun magit-ignored-files () + (magit-git-items "ls-files" "-z" "--others" "--ignored" + "--exclude-standard" "--directory")) + +(defun magit-skip-worktree-files () + (--keep (and (and (= (aref it 0) ?S) + (substring it 2))) + (magit-list-files "-t"))) + +(defun magit-assume-unchanged-files () + (--keep (and (and (memq (aref it 0) '(?h ?s ?m ?r ?c ?k)) + (substring it 2))) + (magit-list-files "-v"))) + +(defun magit-revision-files (rev) + (magit-with-toplevel + (magit-git-items "ls-tree" "-z" "-r" "--name-only" rev))) + +(defun magit-changed-files (rev-or-range &optional other-rev) + "Return list of files the have changed between two revisions. +If OTHER-REV is non-nil, REV-OR-RANGE should be a revision, not a +range. Otherwise, it can be any revision or range accepted by +\"git diff\" (i.e., , .., or ...)." + (magit-with-toplevel + (magit-git-items "diff" "-z" "--name-only" rev-or-range other-rev))) + +(defun magit-renamed-files (revA revB) + (--map (cons (nth 1 it) (nth 2 it)) + (-partition 3 (magit-git-items + "diff-tree" "-r" "--diff-filter=R" "-z" "-M" + revA revB)))) + +(defun magit-file-status (&rest args) + (with-temp-buffer + (save-excursion (magit-git-insert "status" "-z" args)) + (let ((pos (point)) status) + (while (> (skip-chars-forward "[:print:]") 0) + (let ((x (char-after pos)) + (y (char-after (1+ pos))) + (file (buffer-substring (+ pos 3) (point)))) + (forward-char) + (if (memq x '(?R ?C)) + (progn + (setq pos (point)) + (skip-chars-forward "[:print:]") + (push (list file (buffer-substring pos (point)) x y) status) + (forward-char)) + (push (list file nil x y) status))) + (setq pos (point))) + status))) + +(defcustom magit-cygwin-mount-points + (when (eq system-type 'windows-nt) + (cl-sort (--map (if (string-match "^\\(.*\\) on \\(.*\\) type" it) + (cons (file-name-as-directory (match-string 2 it)) + (file-name-as-directory (match-string 1 it))) + (lwarn '(magit) :error + "Failed to parse Cygwin mount: %S" it)) + ;; If --exec-path is not a native Windows path, + ;; then we probably have a cygwin git. + (let ((process-environment + (append magit-git-environment process-environment))) + (and (not (string-match-p + "\\`[a-zA-Z]:" + (car (process-lines + magit-git-executable "--exec-path")))) + (ignore-errors (process-lines "mount"))))) + #'> :key (pcase-lambda (`(,cyg . ,_win)) (length cyg)))) + "Alist of (CYGWIN . WIN32) directory names. +Sorted from longest to shortest CYGWIN name." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(alist :key-type string :value-type directory)) + +(defun magit-expand-git-file-name (filename) + (unless (file-name-absolute-p filename) + (setq filename (expand-file-name filename))) + (-if-let ((cyg . win) + (cl-assoc filename magit-cygwin-mount-points + :test (lambda (f cyg) (string-prefix-p cyg f)))) + (concat win (substring filename (length cyg))) + filename)) + +(defun magit-convert-filename-for-git (filename) + "Convert FILENAME so that it can be passed to git. +1. If it's a remote filename, then remove the remote part. +2. Deal with an `windows-nt' Emacs vs. Cygwin Git incompatibility." + (if (file-name-absolute-p filename) + (-if-let ((cyg . win) + (cl-rassoc filename magit-cygwin-mount-points + :test (lambda (f win) (string-prefix-p win f)))) + (concat cyg (substring filename (length win))) + (or (file-remote-p filename 'localname) + filename)) + filename)) + +(defun magit-decode-git-path (path) + (if (eq (aref path 0) ?\") + (decode-coding-string (read path) + (or magit-git-output-coding-system + (car default-process-coding-system)) + t) + path)) + +(defun magit-file-at-point (&optional expand assert) + (if-let ((file (magit-section-case + (file (oref it value)) + (hunk (magit-section-parent-value it))))) + (if expand + (expand-file-name file (magit-toplevel)) + file) + (when assert + (user-error "No file at point")))) + +(defun magit-current-file () + (or (magit-file-relative-name) + (magit-file-at-point) + (and (derived-mode-p 'magit-log-mode) + (car magit-buffer-log-files)))) + +;;; Predicates + +(defun magit-no-commit-p () + "Return t if there is no commit in the current Git repository." + (not (magit-rev-verify "HEAD"))) + +(defun magit-merge-commit-p (commit) + "Return t if COMMIT is a merge commit." + (> (length (magit-commit-parents commit)) 1)) + +(defun magit-anything-staged-p (&optional ignore-submodules &rest files) + "Return t if there are any staged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (magit-git-failure "diff" "--quiet" "--cached" + (and ignore-submodules "--ignore-submodules") + "--" files)) + +(defun magit-anything-unstaged-p (&optional ignore-submodules &rest files) + "Return t if there are any unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (magit-git-failure "diff" "--quiet" + (and ignore-submodules "--ignore-submodules") + "--" files)) + +(defun magit-anything-modified-p (&optional ignore-submodules &rest files) + "Return t if there are any staged or unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (or (apply 'magit-anything-staged-p ignore-submodules files) + (apply 'magit-anything-unstaged-p ignore-submodules files))) + +(defun magit-anything-unmerged-p (&rest files) + "Return t if there are any merge conflicts. +If optional FILES is non-nil, then only conflicts in those files +are considered." + (and (magit-git-string "ls-files" "--unmerged" files) t)) + +(defun magit-module-worktree-p (module) + (magit-with-toplevel + (file-exists-p (expand-file-name (expand-file-name ".git" module))))) + +(defun magit-module-no-worktree-p (module) + (not (magit-module-worktree-p module))) + +(defun magit-ignore-submodules-p (&optional return-argument) + (or (cl-find-if (lambda (arg) + (string-prefix-p "--ignore-submodules" arg)) + magit-buffer-diff-args) + (when-let ((value (magit-get "diff.ignoreSubmodules"))) + (if return-argument + (concat "--ignore-submodules=" value) + (concat "diff.ignoreSubmodules=" value))))) + +;;; Revisions and References + +(defun magit-rev-parse (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil." + (apply #'magit-git-string "rev-parse" args)) + +(defun magit-rev-parse-safe (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil. Like `magit-rev-parse' but +ignore `magit-git-debug'." + (apply #'magit-git-str "rev-parse" args)) + +(defun magit-rev-parse-true (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal an error." + (magit-git-true "rev-parse" args)) + +(defun magit-rev-parse-false (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal an error." + (magit-git-false "rev-parse" args)) + +(defun magit-rev-parse-p (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +Return t if the first (and usually only) output line is the +string \"true\", otherwise return nil." + (equal (magit-git-str "rev-parse" args) "true")) + +(defun magit-rev-verify (rev) + (magit-git-string-p "rev-parse" "--verify" rev)) + +(defun magit-commit-p (rev) + "Return full hash for REV if it names an existing commit." + (magit-rev-verify (concat rev "^{commit}"))) + +(defalias 'magit-rev-verify-commit 'magit-commit-p) + +(defalias 'magit-rev-hash 'magit-commit-p) + +(defun magit-rev-equal (a b) + "Return t if there are no differences between the commits A and B." + (magit-git-success "diff" "--quiet" a b)) + +(defun magit-rev-eq (a b) + "Return t if A and B refer to the same commit." + (let ((a (magit-commit-p a)) + (b (magit-commit-p b))) + (and a b (equal a b)))) + +(defun magit-rev-ancestor-p (a b) + "Return non-nil if commit A is an ancestor of commit B." + (magit-git-success "merge-base" "--is-ancestor" a b)) + +(defun magit-rev-head-p (rev) + (or (equal rev "HEAD") + (and rev + (not (string-match-p "\\.\\." rev)) + (equal (magit-rev-parse rev) + (magit-rev-parse "HEAD"))))) + +(defun magit-rev-author-p (rev) + "Return t if the user is the author of REV. +More precisely return t if `user.name' is equal to the author +name of REV and/or `user.email' is equal to the author email +of REV." + (or (equal (magit-get "user.name") (magit-rev-format "%an" rev)) + (equal (magit-get "user.email") (magit-rev-format "%ae" rev)))) + +(defun magit-rev-name (rev &optional pattern not-anchored) + "Return a symbolic name for REV using `git-name-rev'. + +PATTERN can be used to limit the result to a matching ref. +Unless NOT-ANCHORED is non-nil, the beginning of the ref must +match PATTERN. + +An anchored lookup is done using the arguments +\"--exclude=*/ --exclude=*/HEAD\" in addition to +\"--refs=\", provided at least version v2.13 of Git is +used. Older versions did not support the \"--exclude\" argument. +When \"--exclude\" cannot be used and `git-name-rev' returns a +ref that should have been excluded, then that is discarded and +this function returns nil instead. This is unfortunate because +there might be other refs that do match. To fix that, update +Git." + (if (version< (magit-git-version) "2.13") + (when-let + ((ref (magit-git-string "name-rev" "--name-only" "--no-undefined" + (and pattern (concat "--refs=" pattern)) + rev))) + (if (and pattern + (string-match-p "\\`refs/[^/]+/\\*\\'" pattern)) + (let ((namespace (substring pattern 0 -1))) + (and (not (or (string-suffix-p "HEAD" ref) + (and (string-match-p namespace ref) + (not (magit-rev-verify + (concat namespace ref)))))) + ref)) + ref)) + (magit-git-string "name-rev" "--name-only" "--no-undefined" + (and pattern (concat "--refs=" pattern)) + (and pattern + (not not-anchored) + (list "--exclude=*/HEAD" + (concat "--exclude=*/" pattern))) + rev))) + +(defun magit-rev-branch (rev) + (--when-let (magit-rev-name rev "refs/heads/*") + (unless (string-match-p "[~^]" it) it))) + +(defun magit-get-shortname (rev) + (let* ((fn (apply-partially 'magit-rev-name rev)) + (name (or (funcall fn "refs/tags/*") + (funcall fn "refs/heads/*") + (funcall fn "refs/remotes/*")))) + (cond ((not name) + (magit-rev-parse "--short" rev)) + ((string-match "^\\(?:tags\\|remotes\\)/\\(.+\\)" name) + (if (magit-ref-ambiguous-p (match-string 1 name)) + name + (match-string 1 name))) + (t (magit-ref-maybe-qualify name))))) + +(defun magit-name-branch (rev &optional lax) + (or (magit-name-local-branch rev) + (magit-name-remote-branch rev) + (and lax (or (magit-name-local-branch rev t) + (magit-name-remote-branch rev t))))) + +(defun magit-name-local-branch (rev &optional lax) + (--when-let (magit-rev-name rev "refs/heads/*") + (and (or lax (not (string-match-p "[~^]" it))) it))) + +(defun magit-name-remote-branch (rev &optional lax) + (--when-let (magit-rev-name rev "refs/remotes/*") + (and (or lax (not (string-match-p "[~^]" it))) + (substring it 8)))) + +(defun magit-name-tag (rev &optional lax) + (--when-let (magit-rev-name rev "refs/tags/*") + (and (or lax (not (string-match-p "[~^]" it))) + (substring it 5)))) + +(defun magit-ref-abbrev (refname) + "Return an unambiguous abbreviation of REFNAME." + (magit-rev-parse "--verify" "--abbrev-ref" refname)) + +(defun magit-ref-fullname (refname) + "Return fully qualified refname for REFNAME. +If REFNAME is ambiguous, return nil." + (magit-rev-parse "--verify" "--symbolic-full-name" refname)) + +(defun magit-ref-ambiguous-p (refname) + (save-match-data + (if (string-match "\\`\\([^^~]+\\)\\(.*\\)" refname) + (not (magit-ref-fullname (match-string 1 refname))) + (error "%S has an unrecognized format" refname)))) + +(defun magit-ref-maybe-qualify (refname &optional prefix) + "If REFNAME is ambiguous, try to disambiguate it by prepend PREFIX to it. +Return an unambiguous refname, either REFNAME or that prefixed +with PREFIX, nil otherwise. If REFNAME has an offset suffix +such as \"~1\", then that is preserved. If optional PREFIX is +nil, then use \"heads/\". " + (if (magit-ref-ambiguous-p refname) + (let ((refname (concat (or prefix "heads/") refname))) + (and (not (magit-ref-ambiguous-p refname)) refname)) + refname)) + +(defun magit-ref-exists-p (ref) + (magit-git-success "show-ref" "--verify" ref)) + +(defun magit-ref-equal (a b) + "Return t if the refnames A and B are `equal'. +A symbolic-ref pointing to some ref, is `equal' to that ref, +as are two symbolic-refs pointing to the same ref. Refnames +may be abbreviated." + (let ((a (magit-ref-fullname a)) + (b (magit-ref-fullname b))) + (and a b (equal a b)))) + +(defun magit-ref-eq (a b) + "Return t if the refnames A and B are `eq'. +A symbolic-ref is `eq' to itself, but not to the ref it points +to, or to some other symbolic-ref that points to the same ref." + (let ((symbolic-a (magit-symbolic-ref-p a)) + (symbolic-b (magit-symbolic-ref-p b))) + (or (and symbolic-a + symbolic-b + (equal a b)) + (and (not symbolic-a) + (not symbolic-b) + (magit-ref-equal a b))))) + +(defun magit-headish () + "Return \"HEAD\" or if that doesn't exist the hash of the empty tree." + (if (magit-no-commit-p) + (magit-git-string "mktree") + "HEAD")) + +(defun magit-branch-at-point () + (magit-section-case + (branch (oref it value)) + (commit (or (magit--painted-branch-at-point) + (magit-name-branch (oref it value)))))) + +(defun magit--painted-branch-at-point (&optional type) + (or (and (not (eq type 'remote)) + (memq (get-text-property (point) 'font-lock-face) + (list 'magit-branch-local + 'magit-branch-current)) + (when-let ((branch (thing-at-point 'git-revision t))) + (cdr (magit-split-branch-name branch)))) + (and (not (eq type 'local)) + (memq (get-text-property (point) 'font-lock-face) + (list 'magit-branch-remote + 'magit-branch-remote-head)) + (thing-at-point 'git-revision t)))) + +(defun magit-local-branch-at-point () + (magit-section-case + (branch (let ((branch (magit-ref-maybe-qualify (oref it value)))) + (when (member branch (magit-list-local-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'local) + (magit-name-local-branch (oref it value)))))) + +(defun magit-remote-branch-at-point () + (magit-section-case + (branch (let ((branch (oref it value))) + (when (member branch (magit-list-remote-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'remote) + (magit-name-remote-branch (oref it value)))))) + +(defun magit-commit-at-point () + (or (magit-section-value-if 'commit) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-branch-or-commit-at-point () + (or (and magit-buffer-file-name + magit-buffer-refname) + (magit-section-case + (branch (magit-ref-maybe-qualify (oref it value))) + (commit (or (magit--painted-branch-at-point) + (let ((rev (oref it value))) + (or (magit-name-branch rev) rev)))) + (tag (magit-ref-maybe-qualify (oref it value) "tags/")) + (pullreq (or (and (fboundp 'forge--pullreq-branch) + (magit-branch-p + (forge--pullreq-branch (oref it value)))) + (magit-ref-p (format "refs/pullreqs/%s" + (oref (oref it value) number)))))) + (thing-at-point 'git-revision t) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-tag-at-point () + (magit-section-case + (tag (oref it value)) + (commit (magit-name-tag (oref it value))))) + +(defun magit-stash-at-point () + (magit-section-value-if 'stash)) + +(defun magit-remote-at-point () + (magit-section-case + (remote (oref it value)) + (branch (magit-section-parent-value it)))) + +(defun magit-module-at-point (&optional predicate) + (when (magit-section-match 'magit-module-section) + (let ((module (oref (magit-current-section) value))) + (and (or (not predicate) + (funcall predicate module)) + module)))) + +(defun magit-get-current-branch () + "Return the refname of the currently checked out branch. +Return nil if no branch is currently checked out." + (magit-git-string "symbolic-ref" "--short" "HEAD")) + +(defvar magit-get-previous-branch-timeout 0.5 + "Maximum time to spend in `magit-get-previous-branch'. +Given as a number of seconds.") + +(defun magit-get-previous-branch () + "Return the refname of the previously checked out branch. +Return nil if no branch can be found in the `HEAD' reflog +which is different from the current branch and still exists. +The amount of time spent searching is limited by +`magit-get-previous-branch-timeout'." + (let ((t0 (float-time)) + (current (magit-get-current-branch)) + (i 1) prev) + (while (if (> (- (float-time) t0) magit-get-previous-branch-timeout) + (setq prev nil) ;; Timed out. + (and (setq prev (magit-rev-verify (format "@{-%i}" i))) + (or (not (setq prev (magit-rev-branch prev))) + (equal prev current)))) + (cl-incf i)) + prev)) + +(defun magit-set-upstream-branch (branch upstream) + "Set UPSTREAM as the upstream of BRANCH. +If UPSTREAM is nil, then unset BRANCH's upstream. +Otherwise UPSTREAM has to be an existing branch." + (if upstream + (magit-call-git "branch" "--set-upstream-to" upstream branch) + (magit-call-git "branch" "--unset-upstream" branch))) + +(defun magit-get-upstream-ref (&optional branch) + "Return the upstream branch of BRANCH as a fully qualified ref. +It BRANCH is nil, then return the upstream of the current branch, +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e. return an existing local or +remote-tracking branch ref." + (when-let ((branch (or branch (magit-get-current-branch)))) + (magit-ref-fullname (concat branch "@{upstream}")))) + +(defun magit-get-upstream-branch (&optional branch) + "Return the name of the upstream branch of BRANCH. +It BRANCH is nil, then return the upstream of the current branch +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e. return the name of an existing local or +remote-tracking branch. The returned string is colorized +according to the branch type." + (when-let ((branch (or branch (magit-get-current-branch))) + (upstream (magit-ref-abbrev (concat branch "@{upstream}")))) + (magit--propertize-face + upstream (if (equal (magit-get "branch" branch "remote") ".") + 'magit-branch-local + 'magit-branch-remote)))) + +(defun magit-get-indirect-upstream-branch (branch &optional force) + (let ((remote (magit-get "branch" branch "remote"))) + (and remote (not (equal remote ".")) + ;; The user has opted in... + (or force + (--some (if (magit-git-success "check-ref-format" "--branch" it) + (equal it branch) + (string-match-p it branch)) + magit-branch-prefer-remote-upstream)) + ;; and local BRANCH tracks a remote branch... + (let ((upstream (magit-get-upstream-branch branch))) + ;; whose upstream... + (and upstream + ;; has the same name as BRANCH... + (equal (substring upstream (1+ (length remote))) branch) + ;; and can be fast-forwarded to BRANCH. + (magit-rev-ancestor-p upstream branch) + upstream))))) + +(defun magit-get-upstream-remote (&optional branch allow-unnamed) + (when-let ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote"))) + (and (not (equal remote ".")) + (cond ((member remote (magit-list-remotes)) + (magit--propertize-face remote 'magit-branch-remote)) + ((and allow-unnamed + (string-match-p "\\(\\`.\\{0,2\\}/\\|[:@]\\)" remote)) + (magit--propertize-face remote 'bold)))))) + +(defun magit-get-unnamed-upstream (&optional branch) + (when-let ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (and (magit--unnamed-upstream-p remote merge) + (list (magit--propertize-face remote 'bold) + (magit--propertize-face merge 'magit-branch-remote))))) + +(defun magit--unnamed-upstream-p (remote merge) + (and remote (string-match-p "\\(\\`\\.\\{0,2\\}/\\|[:@]\\)" remote) + merge (string-prefix-p "refs/" merge))) + +(defun magit--valid-upstream-p (remote merge) + (and (or (equal remote ".") + (member remote (magit-list-remotes))) + (string-prefix-p "refs/" merge))) + +(defun magit-get-current-remote (&optional allow-unnamed) + (or (magit-get-upstream-remote nil allow-unnamed) + (when-let ((remotes (magit-list-remotes)) + (remote (if (= (length remotes) 1) + (car remotes) + (car (member "origin" remotes))))) + (magit--propertize-face remote 'magit-branch-remote)))) + +(defun magit-get-push-remote (&optional branch) + (when-let ((remote + (or (and (or branch (setq branch (magit-get-current-branch))) + (magit-get "branch" branch "pushRemote")) + (magit-get "remote.pushDefault")))) + (magit--propertize-face remote 'magit-branch-remote))) + +(defun magit-get-push-branch (&optional branch verify) + (when-let ((branch (or branch (setq branch (magit-get-current-branch)))) + (remote (magit-get-push-remote branch)) + (target (concat remote "/" branch))) + (and (or (not verify) + (magit-rev-verify target)) + (magit--propertize-face target 'magit-branch-remote)))) + +(defun magit-get-@{push}-branch (&optional branch) + (let ((ref (magit-rev-parse "--symbolic-full-name" + (concat branch "@{push}")))) + (when (and ref (string-prefix-p "refs/remotes/" ref)) + (substring ref 13)))) + +(defun magit-get-remote (&optional branch) + (when (or branch (setq branch (magit-get-current-branch))) + (let ((remote (magit-get "branch" branch "remote"))) + (unless (equal remote ".") + remote)))) + +(defun magit-get-some-remote (&optional branch) + (or (magit-get-remote branch) + (and (magit-branch-p "master") + (magit-get-remote "master")) + (let ((remotes (magit-list-remotes))) + (or (car (member "origin" remotes)) + (car remotes))))) + +(defun magit-branch-merged-p (branch &optional target) + "Return non-nil if BRANCH is merged into its upstream and TARGET. + +TARGET defaults to the current branch. If `HEAD' is detached and +TARGET is nil, then always return nil. As a special case, if +TARGET is t, then return non-nil if BRANCH is merged into any one +of the other local branches. + +If, and only if, BRANCH has an upstream, then only return non-nil +if BRANCH is merged into both TARGET (as described above) as well +as into its upstream." + (and (--if-let (and (magit-branch-p branch) + (magit-get-upstream-branch branch)) + (magit-git-success "merge-base" "--is-ancestor" branch it) + t) + (if (eq target t) + (delete (magit-name-local-branch branch) + (magit-list-containing-branches branch)) + (--when-let (or target (magit-get-current-branch)) + (magit-git-success "merge-base" "--is-ancestor" branch it))))) + +(defun magit-get-tracked (refname) + "Return the remote branch tracked by the remote-tracking branch REFNAME. +The returned value has the form (REMOTE . REF), where REMOTE is +the name of a remote and REF is the ref local to the remote." + (when-let ((ref (magit-ref-fullname refname))) + (save-match-data + (-some (lambda (line) + (and (string-match "\ +\\`remote\\.\\([^.]+\\)\\.fetch=\\+?\\([^:]+\\):\\(.+\\)" line) + (let ((rmt (match-string 1 line)) + (src (match-string 2 line)) + (dst (match-string 3 line))) + (and (string-match (format "\\`%s\\'" + (replace-regexp-in-string + "*" "\\(.+\\)" dst t t)) + ref) + (cons rmt (replace-regexp-in-string + "*" (match-string 1 ref) src)))))) + (magit-git-lines "config" "--local" "--list"))))) + +(defun magit-split-branch-name (branch) + (cond ((member branch (magit-list-local-branch-names)) + (cons "." branch)) + ((string-match "/" branch) + (or (-some (lambda (remote) + (and (string-match (format "\\`\\(%s\\)/\\(.+\\)\\'" remote) + branch) + (cons (match-string 1 branch) + (match-string 2 branch)))) + (magit-list-remotes)) + (error "Invalid branch name %s" branch))))) + +(defun magit-get-current-tag (&optional rev with-distance) + "Return the closest tag reachable from REV. + +If optional REV is nil, then default to `HEAD'. +If optional WITH-DISTANCE is non-nil then return (TAG COMMITS), +if it is `dirty' return (TAG COMMIT DIRTY). COMMITS is the number +of commits in `HEAD' but not in TAG and DIRTY is t if there are +uncommitted changes, nil otherwise." + (--when-let (magit-git-str "describe" "--long" "--tags" + (and (eq with-distance 'dirty) "--dirty") rev) + (save-match-data + (string-match + "\\(.+\\)-\\(?:0[0-9]*\\|\\([0-9]+\\)\\)-g[0-9a-z]+\\(-dirty\\)?$" it) + (if with-distance + `(,(match-string 1 it) + ,(string-to-number (or (match-string 2 it) "0")) + ,@(and (match-string 3 it) (list t))) + (match-string 1 it))))) + +(defun magit-get-next-tag (&optional rev with-distance) + "Return the closest tag from which REV is reachable. + +If optional REV is nil, then default to `HEAD'. +If no such tag can be found or if the distance is 0 (in which +case it is the current tag, not the next), return nil instead. +If optional WITH-DISTANCE is non-nil, then return (TAG COMMITS) +where COMMITS is the number of commits in TAG but not in REV." + (--when-let (magit-git-str "describe" "--contains" (or rev "HEAD")) + (save-match-data + (when (string-match "^[^^~]+" it) + (setq it (match-string 0 it)) + (unless (equal it (magit-get-current-tag rev)) + (if with-distance + (list it (car (magit-rev-diff-count it rev))) + it)))))) + +(defvar magit-list-refs-namespaces + '("refs/heads" "refs/remotes" "refs/tags" "refs/pull")) + +(defun magit-list-refs (&optional namespaces format sortby) + "Return list of references. + +When NAMESPACES is non-nil, list refs from these namespaces +rather than those from `magit-list-refs-namespaces'. + +FORMAT is passed to the `--format' flag of `git for-each-ref' +and defaults to \"%(refname)\". If the format is \"%(refname)\" +or \"%(refname:short)\", then drop the symbolic-ref \"HEAD\". + +SORTBY is a key or list of keys to pass to the `--sort' flag of +`git for-each-ref'. When nil, use `magit-list-refs-sortby'" + (unless format + (setq format "%(refname)")) + (let ((refs (magit-git-lines "for-each-ref" + (concat "--format=" format) + (--map (concat "--sort=" it) + (pcase (or sortby magit-list-refs-sortby) + ((and val (pred stringp)) (list val)) + ((and val (pred listp)) val))) + (or namespaces magit-list-refs-namespaces)))) + (if (member format '("%(refname)" "%(refname:short)")) + (--remove (string-match-p "\\(\\`\\|/\\)HEAD\\'" it) refs) + refs))) + +(defun magit-list-branches () + (magit-list-refs (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branches () + (magit-list-refs "refs/heads")) + +(defun magit-list-remote-branches (&optional remote) + (magit-list-refs (concat "refs/remotes/" remote))) + +(defun magit-list-related-branches (relation &optional commit &rest args) + (--remove (string-match-p "\\(\\`(HEAD\\|HEAD -> \\)" it) + (--map (substring it 2) + (magit-git-lines "branch" args relation commit)))) + +(defun magit-list-containing-branches (&optional commit &rest args) + (magit-list-related-branches "--contains" commit args)) + +(defun magit-list-publishing-branches (&optional commit) + (--filter (magit-rev-ancestor-p commit it) + magit-published-branches)) + +(defun magit-list-merged-branches (&optional commit &rest args) + (magit-list-related-branches "--merged" commit args)) + +(defun magit-list-unmerged-branches (&optional commit &rest args) + (magit-list-related-branches "--no-merged" commit args)) + +(defun magit-list-unmerged-to-upstream-branches () + (--filter (when-let ((upstream (magit-get-upstream-branch it))) + (member it (magit-list-unmerged-branches upstream))) + (magit-list-local-branch-names))) + +(defun magit-list-branches-pointing-at (commit) + (let ((re (format "\\`%s refs/\\(heads\\|remotes\\)/\\(.*\\)\\'" + (magit-rev-verify commit)))) + (--keep (and (string-match re it) + (let ((name (match-string 2 it))) + (and (not (string-suffix-p "HEAD" name)) + name))) + (magit-git-lines "show-ref")))) + +(defun magit-list-refnames (&optional namespaces include-special) + (nconc (magit-list-refs namespaces "%(refname:short)") + (and include-special + (magit-list-special-refnames)))) + +(defvar magit-special-refnames + '("HEAD" "ORIG_HEAD" "FETCH_HEAD" "MERGE_HEAD" "CHERRY_PICK_HEAD")) + +(defun magit-list-special-refnames () + (let ((gitdir (magit-gitdir))) + (cl-mapcan (lambda (name) + (and (file-exists-p (expand-file-name name gitdir)) + (list name))) + magit-special-refnames))) + +(defun magit-list-branch-names () + (magit-list-refnames (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branch-names () + (magit-list-refnames "refs/heads")) + +(defun magit-list-remote-branch-names (&optional remote relative) + (if (and remote relative) + (let ((regexp (format "^refs/remotes/%s/\\(.+\\)" remote))) + (--mapcat (when (string-match regexp it) + (list (match-string 1 it))) + (magit-list-remote-branches remote))) + (magit-list-refnames (concat "refs/remotes/" remote)))) + +(defun magit-format-refs (format &rest args) + (let ((lines (magit-git-lines + "for-each-ref" (concat "--format=" format) + (or args (list "refs/heads" "refs/remotes" "refs/tags"))))) + (if (string-match-p "\f" format) + (--map (split-string it "\f") lines) + lines))) + +(defun magit-list-remotes () + (magit-git-lines "remote")) + +(defun magit-list-tags () + (magit-git-lines "tag")) + +(defun magit-list-stashes (&optional format) + (magit-git-lines "stash" "list" (concat "--format=" (or format "%gd")))) + +(defun magit-list-active-notes-refs () + "Return notes refs according to `core.notesRef' and `notes.displayRef'." + (magit-git-lines "for-each-ref" "--format=%(refname)" + (or (magit-get "core.notesRef") "refs/notes/commits") + (magit-get-all "notes.displayRef"))) + +(defun magit-list-notes-refnames () + (--map (substring it 6) (magit-list-refnames "refs/notes"))) + +(defun magit-remote-list-tags (remote) + (--keep (and (not (string-match-p "\\^{}$" it)) + (substring it 51)) + (magit-git-lines "ls-remote" "--tags" remote))) + +(defun magit-remote-list-branches (remote) + (--keep (and (not (string-match-p "\\^{}$" it)) + (substring it 52)) + (magit-git-lines "ls-remote" "--heads" remote))) + +(defun magit-remote-list-refs (remote) + (--keep (and (not (string-match-p "\\^{}$" it)) + (substring it 41)) + (magit-git-lines "ls-remote" remote))) + +(defun magit-list-module-paths () + (--mapcat (and (string-match "^160000 [0-9a-z]\\{40\\} 0\t\\(.+\\)$" it) + (list (match-string 1 it))) + (magit-git-items "ls-files" "-z" "--stage"))) + +(defun magit-get-submodule-name (path) + "Return the name of the submodule at PATH. +PATH has to be relative to the super-repository." + (cadr (split-string + (car (or (magit-git-items + "config" "-z" + "-f" (expand-file-name ".gitmodules" (magit-toplevel)) + "--get-regexp" "^submodule\\..*\\.path$" + (concat "^" (regexp-quote (directory-file-name path)) "$")) + (error "No such submodule `%s'" path))) + "\n"))) + +(defun magit-list-worktrees () + (let (worktrees worktree) + (dolist (line (let ((magit-git-global-arguments + ;; KLUDGE At least in v2.8.3 this triggers a segfault. + (remove "--no-pager" magit-git-global-arguments))) + (magit-git-lines "worktree" "list" "--porcelain"))) + (cond ((string-prefix-p "worktree" line) + (push (setq worktree (list (substring line 9) nil nil nil)) + worktrees)) + ((string-equal line "bare") + (let* ((default-directory (car worktree)) + (wt (and (not (magit-get-boolean "core.bare")) + (magit-get "core.worktree")))) + (if (and wt (file-exists-p (expand-file-name wt))) + (progn (setf (nth 0 worktree) (expand-file-name wt)) + (setf (nth 2 worktree) (magit-rev-parse "HEAD")) + (setf (nth 3 worktree) (magit-get-current-branch))) + (setf (nth 1 worktree) t)))) + ((string-prefix-p "HEAD" line) + (setf (nth 2 worktree) (substring line 5))) + ((string-prefix-p "branch" line) + (setf (nth 3 worktree) (substring line 18))) + ((string-equal line "detached")))) + (nreverse worktrees))) + +(defun magit-symbolic-ref-p (name) + (magit-git-success "symbolic-ref" "--quiet" name)) + +(defun magit-ref-p (rev) + (or (car (member rev (magit-list-refs "refs/"))) + (car (member rev (magit-list-refnames "refs/"))))) + +(defun magit-branch-p (rev) + (or (car (member rev (magit-list-branches))) + (car (member rev (magit-list-branch-names))))) + +(defun magit-local-branch-p (rev) + (or (car (member rev (magit-list-local-branches))) + (car (member rev (magit-list-local-branch-names))))) + +(defun magit-remote-branch-p (rev) + (or (car (member rev (magit-list-remote-branches))) + (car (member rev (magit-list-remote-branch-names))))) + +(defun magit-branch-set-face (branch) + (magit--propertize-face branch (if (magit-local-branch-p branch) + 'magit-branch-local + 'magit-branch-remote))) + +(defun magit-tag-p (rev) + (car (member rev (magit-list-tags)))) + +(defun magit-remote-p (string) + (car (member string (magit-list-remotes)))) + +(defun magit-rev-diff-count (a b) + "Return the commits in A but not B and vice versa. +Return a list of two integers: (A>B B>A)." + (mapcar 'string-to-number + (split-string (magit-git-string "rev-list" + "--count" "--left-right" + (concat a "..." b)) + "\t"))) + +(defun magit-abbrev-length () + (--if-let (magit-get "core.abbrev") + (string-to-number it) + ;; Guess the length git will be using based on an example + ;; abbreviation. Actually HEAD's abbreviation might be an + ;; outlier, so use the shorter of the abbreviations for two + ;; commits. When a commit does not exist, then fall back + ;; to the default of 7. See #3034. + (min (--if-let (magit-rev-parse "--short" "HEAD") (length it) 7) + (--if-let (magit-rev-parse "--short" "HEAD~") (length it) 7)))) + +(defun magit-abbrev-arg (&optional arg) + (format "--%s=%d" (or arg "abbrev") (magit-abbrev-length))) + +(defun magit-rev-abbrev (rev) + (magit-rev-parse (magit-abbrev-arg "short") rev)) + +(defun magit-commit-children (commit &optional args) + (mapcar #'car + (--filter (member commit (cdr it)) + (--map (split-string it " ") + (magit-git-lines + "log" "--format=%H %P" + (or args (list "--branches" "--tags" "--remotes")) + "--not" commit))))) + +(defun magit-commit-parents (commit) + (--when-let (magit-git-string "rev-list" "-1" "--parents" commit) + (cdr (split-string it)))) + +(defun magit-patch-id (rev) + (with-temp-buffer + (magit-process-file + shell-file-name nil '(t nil) nil shell-command-switch + (let ((exec (shell-quote-argument magit-git-executable))) + (format "%s diff-tree -u %s | %s patch-id" exec rev exec))) + (car (split-string (buffer-string))))) + +(defun magit-rev-format (format &optional rev args) + (let ((str (magit-git-string "show" "--no-patch" + (concat "--format=" format) args + (if rev (concat rev "^{commit}") "HEAD") "--"))) + (unless (string-equal str "") + str))) + +(defun magit-rev-insert-format (format &optional rev args) + (magit-git-insert "show" "--no-patch" + (concat "--format=" format) args + (if rev (concat rev "^{commit}") "HEAD") "--")) + +(defun magit-format-rev-summary (rev) + (--when-let (magit-rev-format "%h %s" rev) + (string-match " " it) + (magit--put-face 0 (match-beginning 0) 'magit-hash it) + it)) + +(defvar magit-ref-namespaces + '(("\\`HEAD\\'" . magit-head) + ("\\`refs/tags/\\(.+\\)" . magit-tag) + ("\\`refs/heads/\\(.+\\)" . magit-branch-local) + ("\\`refs/remotes/\\(.+\\)" . magit-branch-remote) + ("\\`refs/bisect/\\(bad\\)" . magit-bisect-bad) + ("\\`refs/bisect/\\(skip.*\\)" . magit-bisect-skip) + ("\\`refs/bisect/\\(good.*\\)" . magit-bisect-good) + ("\\`refs/stash$" . magit-refname-stash) + ("\\`refs/wip/\\(.+\\)" . magit-refname-wip) + ("\\`refs/pullreqs/\\(.+\\)" . magit-refname-pullreq) + ("\\`\\(bad\\):" . magit-bisect-bad) + ("\\`\\(skip\\):" . magit-bisect-skip) + ("\\`\\(good\\):" . magit-bisect-good) + ("\\`\\(.+\\)" . magit-refname)) + "How refs are formatted for display. + +Each entry controls how a certain type of ref is displayed, and +has the form (REGEXP . FACE). REGEXP is a regular expression +used to match full refs. The first entry whose REGEXP matches +the reference is used. + +In log and revision buffers the first regexp submatch becomes the +\"label\" that represents the ref and is propertized with FONT. +In refs buffers the displayed text is controlled by other means +and this option only controls what face is used.") + +(defun magit-format-ref-labels (string) + (save-match-data + (let ((regexp "\\(, \\|tag: \\|HEAD -> \\)") + names) + (if (and (derived-mode-p 'magit-log-mode) + (member "--simplify-by-decoration" magit-buffer-log-args)) + (let ((branches (magit-list-local-branch-names)) + (re (format "^%s/.+" (regexp-opt (magit-list-remotes))))) + (setq names + (--map (cond ((string-equal it "HEAD") it) + ((string-prefix-p "refs/" it) it) + ((member it branches) (concat "refs/heads/" it)) + ((string-match re it) (concat "refs/remotes/" it)) + (t (concat "refs/" it))) + (split-string + (replace-regexp-in-string "tag: " "refs/tags/" string) + regexp t)))) + (setq names (split-string string regexp t))) + (let (state head upstream tags branches remotes other combined) + (dolist (ref names) + (let* ((face (cdr (--first (string-match (car it) ref) + magit-ref-namespaces))) + (name (magit--propertize-face + (or (match-string 1 ref) ref) face))) + (cl-case face + ((magit-bisect-bad magit-bisect-skip magit-bisect-good) + (setq state name)) + (magit-head + (setq head (magit--propertize-face "@" 'magit-head))) + (magit-tag (push name tags)) + (magit-branch-local (push name branches)) + (magit-branch-remote (push name remotes)) + (t (push name other))))) + (setq remotes + (-keep + (lambda (name) + (if (string-match "\\`\\([^/]*\\)/\\(.*\\)\\'" name) + (let ((r (match-string 1 name)) + (b (match-string 2 name))) + (and (not (equal b "HEAD")) + (if (equal (concat "refs/remotes/" name) + (magit-git-string + "symbolic-ref" + (format "refs/remotes/%s/HEAD" r))) + (magit--propertize-face + name 'magit-branch-remote-head) + name))) + name)) + remotes)) + (let* ((current (magit-get-current-branch)) + (target (magit-get-upstream-branch current))) + (dolist (name branches) + (let ((push (car (member (magit-get-push-branch name) remotes)))) + (when push + (setq remotes (delete push remotes)) + (string-match "^[^/]*/" push) + (setq push (substring push 0 (match-end 0)))) + (cond + ((equal name current) + (setq head + (concat push + (magit--propertize-face + name 'magit-branch-current)))) + ((equal name target) + (setq upstream + (concat push + (magit--propertize-face + name '(magit-branch-upstream + magit-branch-local))))) + (t + (push (concat push name) combined))))) + (when (and target (not upstream)) + (if (member target remotes) + (progn + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq remotes (delete target remotes))) + (when-let ((target (car (member target combined)))) + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq combined (delete target combined)))))) + (mapconcat #'identity + (-flatten `(,state + ,head + ,upstream + ,@(nreverse tags) + ,@(nreverse combined) + ,@(nreverse remotes) + ,@other)) + " "))))) + +(defun magit-object-type (object) + (magit-git-string "cat-file" "-t" object)) + +(defmacro magit-with-blob (commit file &rest body) + (declare (indent 2) + (debug (form form body))) + `(with-temp-buffer + (let ((buffer-file-name ,file)) + (save-excursion + (magit-git-insert "cat-file" "-p" + (concat ,commit ":" buffer-file-name))) + (decode-coding-inserted-region + (point-min) (point-max) buffer-file-name t nil nil t) + ,@body))) + +(defmacro magit-with-temp-index (tree arg &rest body) + (declare (indent 2) (debug (form form body))) + (let ((file (cl-gensym "file"))) + `(let ((magit--refresh-cache nil) + (,file (magit-convert-filename-for-git + (make-temp-name (magit-git-dir "index.magit."))))) + (unwind-protect + (magit-with-toplevel + (--when-let ,tree + (or (magit-git-success "read-tree" ,arg it + (concat "--index-output=" ,file)) + (error "Cannot read tree %s" it))) + (if (file-remote-p default-directory) + (let ((magit-tramp-process-environment + (cons (concat "GIT_INDEX_FILE=" ,file) + magit-tramp-process-environment))) + ,@body) + (let ((process-environment + (cons (concat "GIT_INDEX_FILE=" ,file) + process-environment))) + ,@body))) + (ignore-errors + (delete-file (concat (file-remote-p default-directory) ,file))))))) + +(defun magit-commit-tree (message &optional tree &rest parents) + (magit-git-string "commit-tree" "--no-gpg-sign" "-m" message + (--mapcat (list "-p" it) (delq nil parents)) + (or tree + (magit-git-string "write-tree") + (error "Cannot write tree")))) + +(defun magit-commit-worktree (message &optional arg &rest other-parents) + (magit-with-temp-index "HEAD" arg + (and (magit-update-files (magit-unstaged-files)) + (apply #'magit-commit-tree message nil "HEAD" other-parents)))) + +(defun magit-update-files (files) + (magit-git-success "update-index" "--add" "--remove" "--" files)) + +(defun magit-update-ref (ref message rev &optional stashish) + (let ((magit--refresh-cache nil)) + (or (if (not (version< (magit-git-version) "2.6.0")) + (zerop (magit-call-git "update-ref" "--create-reflog" + "-m" message ref rev + (or (magit-rev-verify ref) ""))) + ;; `--create-reflog' didn't exist before v2.6.0 + (let ((oldrev (magit-rev-verify ref)) + (logfile (magit-git-dir (concat "logs/" ref)))) + (unless (file-exists-p logfile) + (when oldrev + (magit-git-success "update-ref" "-d" ref oldrev)) + (make-directory (file-name-directory logfile) t) + (with-temp-file logfile) + (when (and oldrev (not stashish)) + (magit-git-success "update-ref" "-m" "enable reflog" + ref oldrev "")))) + (magit-git-success "update-ref" "-m" message ref rev + (or (magit-rev-verify ref) ""))) + (error "Cannot update %s with %s" ref rev)))) + +(defconst magit-range-re + (concat "\\`\\([^ \t]*[^.]\\)?" ; revA + "\\(\\.\\.\\.?\\)" ; range marker + "\\([^.][^ \t]*\\)?\\'")) ; revB + +(defun magit-split-range (range) + (and (string-match magit-range-re range) + (let ((beg (or (match-string 1 range) "HEAD")) + (end (or (match-string 3 range) "HEAD"))) + (cons (if (string-equal (match-string 2 range) "...") + (magit-git-string "merge-base" beg end) + beg) + end)))) + +(defun magit-hash-range (range) + (if (string-match magit-range-re range) + (concat (magit-rev-hash (match-string 1 range)) + (match-string 2 range) + (magit-rev-hash (match-string 3 range))) + (magit-rev-hash range))) + +(put 'git-revision 'thing-at-point 'magit-thingatpt--git-revision) +(defun magit-thingatpt--git-revision () + (--when-let + (let ((c "\s\n\t~^:?*[\\")) + (cl-letf (((get 'git-revision 'beginning-op) + (if (re-search-backward (format "[%s]" c) nil t) + (forward-char) + (goto-char (point-min)))) + ((get 'git-revision 'end-op) + (lambda () + (re-search-forward (format "\\=[^%s]*" c) nil t)))) + (bounds-of-thing-at-point 'git-revision))) + (let ((text (buffer-substring-no-properties (car it) (cdr it)))) + (and (magit-commit-p text) text)))) + +;;; Completion + +(defvar magit-revision-history nil) + +(defun magit-read-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-branch-or-commit (prompt &optional secondary-default) + (or (magit-completing-read prompt (magit-list-refnames nil t) + nil nil nil 'magit-revision-history + (or (magit-branch-or-commit-at-point) + secondary-default + (magit-get-current-branch))) + (user-error "Nothing selected"))) + +(defun magit-read-range-or-commit (prompt &optional secondary-default) + (magit-read-range + prompt + (or (--when-let (magit-region-values '(commit branch) t) + (deactivate-mark) + (concat (car (last it)) ".." (car it))) + (magit-branch-or-commit-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-range (prompt &optional default) + (magit-completing-read-multiple prompt + (magit-list-refnames) + "\\.\\.\\.?" + default 'magit-revision-history)) + +(defun magit-read-remote-branch + (prompt &optional remote default local-branch require-match) + (let ((choice (magit-completing-read + prompt + (-union (and local-branch + (if remote + (concat remote "/" local-branch) + (--map (concat it "/" local-branch) + (magit-list-remotes)))) + (magit-list-remote-branch-names remote t)) + nil require-match nil 'magit-revision-history default))) + (if (or remote (string-match "\\`\\([^/]+\\)/\\(.+\\)" choice)) + choice + (user-error "`%s' doesn't have the form REMOTE/BRANCH" choice)))) + +(defun magit-read-refspec (prompt remote) + (magit-completing-read prompt + (prog2 (message "Determining available refs...") + (magit-remote-list-refs remote) + (message "Determining available refs...done")))) + +(defun magit-read-local-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-local-branch-names) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-local-branch-or-commit (prompt) + (let ((choices (nconc (magit-list-local-branch-names) + (magit-list-special-refnames))) + (commit (magit-commit-at-point))) + (when commit + (push commit choices)) + (or (magit-completing-read prompt choices + nil nil nil 'magit-revision-history + (or (magit-local-branch-at-point) commit)) + (user-error "Nothing selected")))) + +(defun magit-read-local-branch-or-ref (prompt &optional secondary-default) + (magit-completing-read prompt (nconc (magit-list-local-branch-names) + (magit-list-refs "refs/")) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-other-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt (delete exclude (magit-list-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-other-branch-or-commit + (prompt &optional exclude secondary-default) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-or-commit-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) + (not (and (not current) + (magit-rev-equal atpoint "HEAD"))) + atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (or (magit-completing-read prompt (delete exclude (magit-list-refnames)) + nil nil nil 'magit-revision-history default) + (user-error "Nothing selected")))) + +(defun magit-read-other-local-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-local-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt + (delete exclude (magit-list-local-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-branch-prefer-other (prompt) + (let* ((current (magit-get-current-branch)) + (commit (magit-commit-at-point)) + (atrev (and commit (magit-list-branches-pointing-at commit))) + (atpoint (magit--painted-branch-at-point))) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-section-value-if 'branch) + atpoint + (and (not (cdr atrev)) (car atrev)) + (--first (not (equal it current)) atrev) + (magit-get-previous-branch) + (car atrev))))) + +(defun magit-read-upstream-branch (&optional branch prompt) + "Read the upstream for BRANCH using PROMPT. +If optional BRANCH is nil, then read the upstream for the +current branch, or raise an error if no branch is checked +out. Only existing branches can be selected." + (unless branch + (setq branch (or (magit-get-current-branch) + (error "Need a branch to set its upstream")))) + (let ((branches (delete branch (magit-list-branch-names)))) + (magit-completing-read + (or prompt (format "Change upstream of %s to" branch)) + branches nil t nil 'magit-revision-history + (or (let ((r (car (member (magit-remote-branch-at-point) branches))) + (l (car (member (magit-local-branch-at-point) branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (let ((r (car (member "origin/master" branches))) + (l (car (member "master" branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (car (member (magit-get-previous-branch) branches)))))) + +(defun magit-read-starting-point (prompt &optional branch default) + (or (magit-completing-read + (concat prompt + (and branch + (if (bound-and-true-p ivy-mode) + ;; Ivy-mode strips faces from prompt. + (format " `%s'" branch) + (concat " " (magit--propertize-face + branch 'magit-branch-local)))) + " starting at") + (nconc (list "HEAD") + (magit-list-refnames) + (directory-files (magit-git-dir) nil "_HEAD\\'")) + nil nil nil 'magit-revision-history + (or default (magit--default-starting-point))) + (user-error "Nothing selected"))) + +(defun magit--default-starting-point () + (or (let ((r (magit-remote-branch-at-point)) + (l (magit-local-branch-at-point))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (magit-commit-at-point) + (magit-stash-at-point) + (magit-get-current-branch))) + +(defun magit-read-tag (prompt &optional require-match) + (magit-completing-read prompt (magit-list-tags) nil + require-match nil 'magit-revision-history + (magit-tag-at-point))) + +(defun magit-read-stash (prompt) + (let ((stashes (magit-list-stashes))) + (magit-completing-read prompt stashes nil t nil nil + (magit-stash-at-point) + (car stashes)))) + +(defun magit-read-remote (prompt &optional default use-only) + (let ((remotes (magit-list-remotes))) + (if (and use-only (= (length remotes) 1)) + (car remotes) + (magit-completing-read prompt remotes + nil t nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))))) + +(defun magit-read-remote-or-url (prompt &optional default) + (magit-completing-read prompt + (nconc (magit-list-remotes) + (list "https://" "git://" "git@")) + nil nil nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))) + +(defun magit-read-module-path (prompt &optional predicate) + (magit-completing-read prompt (magit-list-module-paths) + predicate t nil nil + (magit-module-at-point predicate))) + +(defun magit-module-confirm (verb &optional predicate) + (let (modules) + (if current-prefix-arg + (progn + (setq modules (magit-list-module-paths)) + (when predicate + (setq modules (-filter predicate modules))) + (unless modules + (if predicate + (user-error "No modules satisfying %s available" predicate) + (user-error "No modules available")))) + (setq modules (magit-region-values 'magit-module-section)) + (when modules + (when predicate + (setq modules (-filter predicate modules))) + (unless modules + (user-error "No modules satisfying %s selected" predicate)))) + (if (> (length modules) 1) + (magit-confirm t nil (format "%s %%i modules" verb) nil modules) + (list (magit-read-module-path (format "%s module" verb) predicate))))) + +;;; _ +(provide 'magit-git) +;;; magit-git.el ends here diff --git a/elpa/magit-20200318.1224/magit-git.elc b/elpa/magit-20200318.1224/magit-git.elc new file mode 100644 index 00000000..b86a5680 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-git.elc differ diff --git a/elpa/magit-20200318.1224/magit-gitignore.el b/elpa/magit-20200318.1224/magit-gitignore.el new file mode 100644 index 00000000..ad1ac91d --- /dev/null +++ b/elpa/magit-20200318.1224/magit-gitignore.el @@ -0,0 +1,197 @@ +;;; magit-gitignore.el --- intentionally untracked files -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements gitignore commands. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Transient + +;;;###autoload (autoload 'magit-gitignore "magit-gitignore" nil t) +(define-transient-command magit-gitignore () + "Instruct Git to ignore a file or pattern." + :man-page "gitignore" + ["Gitignore" + ("t" "shared at toplevel (.gitignore)" + magit-gitignore-in-topdir) + ("s" "shared in subdirectory (path/to/.gitignore)" + magit-gitignore-in-subdir) + ("p" "privately (.git/info/exclude)" + magit-gitignore-in-gitdir) + ("g" magit-gitignore-on-system + :if (lambda () (magit-get "core.excludesfile")) + :description (lambda () + (format "privately for all repositories (%s)" + (magit-get "core.excludesfile"))))] + ["Skip worktree" + (7 "w" "do skip worktree" magit-skip-worktree) + (7 "W" "do not skip worktree" magit-no-skip-worktree)] + ["Assume unchanged" + (7 "u" "do assume unchanged" magit-assume-unchanged) + (7 "U" "do not assume unchanged" magit-no-assume-unchanged)]) + +;;; Gitignore Commands + +;;;###autoload +(defun magit-gitignore-in-topdir (rule) + "Add the Git ignore RULE to the top-level \".gitignore\" file. +Since this file is tracked, it is shared with other clones of the +repository. Also stage the file." + (interactive (list (magit-gitignore-read-pattern))) + (magit-with-toplevel + (magit--gitignore rule ".gitignore") + (magit-run-git "add" ".gitignore"))) + +;;;###autoload +(defun magit-gitignore-in-subdir (rule directory) + "Add the Git ignore RULE to a \".gitignore\" file. +Prompted the user for a directory and add the rule to the +\".gitignore\" file in that directory. Since such files are +tracked, they are shared with other clones of the repository. +Also stage the file." + (interactive (list (magit-gitignore-read-pattern) + (read-directory-name "Limit rule to files in: "))) + (magit-with-toplevel + (let ((file (expand-file-name ".gitignore" directory))) + (magit--gitignore rule file) + (magit-run-git "add" file)))) + +;;;###autoload +(defun magit-gitignore-in-gitdir (rule) + "Add the Git ignore RULE to \"$GIT_DIR/info/exclude\". +Rules in that file only affects this clone of the repository." + (interactive (list (magit-gitignore-read-pattern))) + (magit--gitignore rule (magit-git-dir "info/exclude")) + (magit-refresh)) + +;;;###autoload +(defun magit-gitignore-on-system (rule) + "Add the Git ignore RULE to the file specified by `core.excludesFile'. +Rules that are defined in that file affect all local repositories." + (interactive (list (magit-gitignore-read-pattern))) + (magit--gitignore rule + (or (magit-get "core.excludesFile") + (error "Variable `core.excludesFile' isn't set"))) + (magit-refresh)) + +(defun magit--gitignore (rule file) + (when-let ((directory (file-name-directory file))) + (make-directory directory t)) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (replace-regexp-in-string "\\(\\\\*\\)" "\\1\\1" rule)) + (insert "\n") + (write-region nil nil file))) + +(defun magit-gitignore-read-pattern () + (let* ((default (magit-current-file)) + (base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base)) + (choices + (delete-dups + (--mapcat + (cons (concat "/" it) + (when-let ((ext (file-name-extension it))) + (list (concat "/" (file-name-directory it) "*." ext) + (concat "*." ext)))) + (sort (nconc + (magit-untracked-files nil base) + ;; The untracked section of the status buffer lists + ;; directories containing only untracked files. + ;; Add those as candidates. + (-filter #'directory-name-p + (magit-list-files + "--other" "--exclude-standard" "--directory" + "--no-empty-directory" "--" base))) + #'string-lessp))))) + (when default + (setq default (concat "/" default)) + (unless (member default choices) + (setq default (concat "*." (file-name-extension default))) + (unless (member default choices) + (setq default nil)))) + (magit-completing-read "File or pattern to ignore" + choices nil nil nil nil default))) + +;;; Skip Worktree Commands + +;;;###autoload +(defun magit-skip-worktree (file) + "Call \"git update-index --skip-worktree -- FILE\"." + (interactive + (list (magit-read-file-choice "Skip worktree for" + (magit-with-toplevel + (cl-set-difference + (magit-list-files) + (magit-skip-worktree-files)))))) + (magit-with-toplevel + (magit-run-git "update-index" "--skip-worktree" "--" file))) + +;;;###autoload +(defun magit-no-skip-worktree (file) + "Call \"git update-index --no-skip-worktree -- FILE\"." + (interactive + (list (magit-read-file-choice "Do not skip worktree for" + (magit-with-toplevel + (magit-skip-worktree-files))))) + (magit-with-toplevel + (magit-run-git "update-index" "--no-skip-worktree" "--" file))) + +;;; Assume Unchanged Commands + +;;;###autoload +(defun magit-assume-unchanged (file) + "Call \"git update-index --assume-unchanged -- FILE\"." + (interactive + (list (magit-read-file-choice "Assume file to be unchanged" + (magit-with-toplevel + (cl-set-difference + (magit-list-files) + (magit-assume-unchanged-files)))))) + (magit-with-toplevel + (magit-run-git "update-index" "--assume-unchanged" "--" file))) + +;;;###autoload +(defun magit-no-assume-unchanged (file) + "Call \"git update-index --no-assume-unchanged -- FILE\"." + (interactive + (list (magit-read-file-choice "Do not assume file to be unchanged" + (magit-with-toplevel + (magit-assume-unchanged-files))))) + (magit-with-toplevel + (magit-run-git "update-index" "--no-assume-unchanged" "--" file))) + +;;; _ +(provide 'magit-gitignore) +;;; magit-gitignore.el ends here diff --git a/elpa/magit-20200318.1224/magit-gitignore.elc b/elpa/magit-20200318.1224/magit-gitignore.elc new file mode 100644 index 00000000..75e57b3f Binary files /dev/null and b/elpa/magit-20200318.1224/magit-gitignore.elc differ diff --git a/elpa/magit-20200318.1224/magit-imenu.el b/elpa/magit-20200318.1224/magit-imenu.el new file mode 100644 index 00000000..bba7eed5 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-imenu.el @@ -0,0 +1,245 @@ +;;; magit-imenu.el --- Integrate Imenu in magit major modes -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Damien Cassou +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Emacs' major modes can facilitate navigation in their buffers by +;; supporting Imenu. In such major modes, launching Imenu (M-x imenu) +;; makes Emacs display a list of items (e.g., function definitions in +;; a programming major mode). Selecting an item from this list moves +;; point to this item. + +;; magit-imenu.el adds Imenu support to every major mode in Magit. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) +(require 'git-rebase) + +;;; Core + +(defun magit-imenu--index-function (entry-types menu-types) + "Return an alist of imenu entries in current buffer. + +ENTRY-TYPES is a list of section types to be selected through +`imenu'. + +MENU-TYPES is a list of section types containing elements of +ENTRY-TYPES. Elements of MENU-TYPES are are used to categories +elements of ENTRY-TYPES. + +This function is used as a helper for functions set as +`imenu-create-index-function'." + (let ((entries (make-hash-table :test 'equal))) + (goto-char (point-max)) + (while (magit-section--backward-find + (lambda () + (let* ((section (magit-current-section)) + (type (oref section type)) + (parent (oref section parent)) + (parent-type (oref parent type))) + (and (-contains-p entry-types type) + (-contains-p menu-types parent-type))))) + (let* ((section (magit-current-section)) + (name (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (parent (oref section parent)) + (parent-title (buffer-substring-no-properties + (oref parent start) + (1- (oref parent content))))) + (puthash parent-title + (cons (cons name (point)) + (gethash parent-title entries (list))) + entries))) + (mapcar (lambda (menu-title) + (cons menu-title (gethash menu-title entries))) + (hash-table-keys entries)))) + +;;; Log mode + +;;;###autoload +(defun magit-imenu--log-prev-index-position-function () + "Move point to previous line in current buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (magit-section--backward-find + (lambda () + (-contains-p '(commit stash) + (oref (magit-current-section) type))))) + +;;;###autoload +(defun magit-imenu--log-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (save-match-data + (looking-at "\\([^ ]+\\)[ *|]+\\(.+\\)$") + (format "%s: %s" + (match-string-no-properties 1) + (match-string-no-properties 2)))) + +;;; Diff mode + +;;;###autoload +(defun magit-imenu--diff-prev-index-position-function () + "Move point to previous file line in current buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (magit-section--backward-find + (lambda () + (let ((section (magit-current-section))) + (and (magit-file-section-p section) + (not (equal (oref (oref section parent) type) + 'diffstat))))))) + +;;;###autoload +(defun magit-imenu--diff-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + +;;; Status mode + +;;;###autoload +(defun magit-imenu--status-create-index-function () + "Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'." + (magit-imenu--index-function + '(file commit stash) + '(unpushed unstaged unpulled untracked staged stashes))) + +;;;; Refs mode + +;;;###autoload +(defun magit-imenu--refs-create-index-function () + "Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'." + (magit-imenu--index-function + '(branch commit tag) + '(local remote tags))) + +;;;; Cherry mode + +;;;###autoload +(defun magit-imenu--cherry-create-index-function () + "Return an alist of all imenu entries in current buffer. +This function is used as a value for +`imenu-create-index-function'." + (magit-imenu--index-function + '(commit) + '(cherries))) + +;;;; Submodule list mode + +;;;###autoload +(defun magit-imenu--submodule-prev-index-position-function () + "Move point to previous line in magit-submodule-list buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (unless (bobp) + (forward-line -1))) + +;;;###autoload +(defun magit-imenu--submodule-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (elt (tabulated-list-get-entry) 0)) + +;;;; Repolist mode + +;;;###autoload +(defun magit-imenu--repolist-prev-index-position-function () + "Move point to previous line in magit-repolist buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (unless (bobp) + (forward-line -1))) + +;;;###autoload +(defun magit-imenu--repolist-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (let ((entry (tabulated-list-get-entry))) + (format "%s (%s)" + (elt entry 0) + (elt entry (1- (length entry)))))) + +;;;; Process mode + +;;;###autoload +(defun magit-imenu--process-prev-index-position-function () + "Move point to previous process in magit-process buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (magit-section--backward-find + (lambda () + (eq (oref (magit-current-section) type) 'process)))) + +;;;###autoload +(defun magit-imenu--process-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + +;;;; Rebase mode + +;;;###autoload +(defun magit-imenu--rebase-prev-index-position-function () + "Move point to previous commit in git-rebase buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (catch 'found + (while (not (bobp)) + (git-rebase-backward-line) + (when (git-rebase-line-p) + (throw 'found t))))) + +;;;###autoload +(defun magit-imenu--rebase-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + +;;; _ +(provide 'magit-imenu) +;;; magit-imenu.el ends here diff --git a/elpa/magit-20200318.1224/magit-imenu.elc b/elpa/magit-20200318.1224/magit-imenu.elc new file mode 100644 index 00000000..3b6d7f02 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-imenu.elc differ diff --git a/elpa/magit-20200318.1224/magit-log.el b/elpa/magit-20200318.1224/magit-log.el new file mode 100644 index 00000000..54e9b1c3 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-log.el @@ -0,0 +1,1782 @@ +;;; magit-log.el --- inspect Git history -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for looking at Git logs, including +;; special logs like cherry-logs, as well as for selecting a commit +;; from a log. + +;;; Code: + +(require 'magit-core) +(require 'magit-diff) + +(declare-function magit-blob-visit "magit-files" (blob-or-file line)) +(declare-function magit-insert-head-branch-header "magit-status" + (&optional branch)) +(declare-function magit-insert-upstream-branch-header "magit-status" + (&optional branch pull keyword)) +(declare-function magit-read-file-from-rev "magit-files" + (rev prompt &optional default)) +(declare-function magit-show-commit "magit-diff" + (arg1 &optional arg2 arg3 arg4)) +(declare-function magit-reflog-format-subject "magit-reflog" (subject)) +(defvar magit-refs-focus-column-width) +(defvar magit-refs-margin) +(defvar magit-refs-show-commit-count) +(defvar magit-buffer-margin) +(defvar magit-status-margin) +(defvar magit-status-sections-hook) + +(require 'ansi-color) +(require 'crm) +(require 'which-func) + +(eval-when-compile + (require 'subr-x)) + +;;; Options +;;;; Log Mode + +(defgroup magit-log nil + "Inspect and manipulate Git history." + :link '(info-link "(magit)Logging") + :group 'magit-modes) + +(defcustom magit-log-mode-hook nil + "Hook run after entering Magit-Log mode." + :group 'magit-log + :type 'hook) + +(defcustom magit-log-remove-graph-args '("--follow" "--grep" "-G" "-S" "-L") + "The log arguments that cause the `--graph' argument to be dropped." + :package-version '(magit . "2.3.0") + :group 'magit-log + :type '(repeat (string :tag "Argument")) + :options '("--follow" "--grep" "-G" "-S" "-L")) + +(defcustom magit-log-revision-headers-format "\ +%+b +Author: %aN <%aE> +Committer: %cN <%cE>" + "Additional format string used with the `++header' argument." + :package-version '(magit . "2.3.0") + :group 'magit-log + :type 'string) + +(defcustom magit-log-auto-more nil + "Insert more log entries automatically when moving past the last entry. +Only considered when moving past the last entry with +`magit-goto-*-section' commands." + :group 'magit-log + :type 'boolean) + +(defcustom magit-log-margin '(t age magit-log-margin-width t 18) + "Format of the margin in `magit-log-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set (apply-partially #'magit-margin-set-variable 'magit-log-mode)) + +(defcustom magit-log-margin-show-committer-date nil + "Whether to show the committer date in the margin. + +This option only controls whether the committer date is displayed +instead of the author date. Whether some date is displayed in +the margin and whether the margin is displayed at all is +controlled by other options." + :package-version '(magit . "3.0.0") + :group 'magit-log + :group 'magit-margin + :type 'boolean) + +(defcustom magit-log-show-refname-after-summary nil + "Whether to show refnames after commit summaries. +This is useful if you use really long branch names." + :package-version '(magit . "2.2.0") + :group 'magit-log + :type 'boolean) + +(defcustom magit-log-highlight-keywords t + "Whether to highlight bracketed keywords in commit summaries." + :package-version '(magit . "2.12.0") + :group 'magit-log + :type 'boolean) + +(defcustom magit-log-header-line-function 'magit-log-header-line-sentence + "Function used to generate text shown in header line of log buffers." + :package-version '(magit . "2.12.0") + :group 'magit-log + :type '(choice (function-item magit-log-header-line-arguments) + (function-item magit-log-header-line-sentence) + function)) + +(defcustom magit-log-trace-definition-function 'magit-which-function + "Function used to determine the function at point. +This is used by the command `magit-log-trace-definition'. +You should prefer `magit-which-function' over `which-function' +because the latter may make use of Imenu's outdated cache." + :package-version '(magit . "3.0.0") + :group 'magit-log + :type '(choice (function-item magit-which-function) + (function-item which-function) + (function-item add-log-current-defun) + function)) + +(defface magit-log-graph + '((((class color) (background light)) :foreground "grey30") + (((class color) (background dark)) :foreground "grey80")) + "Face for the graph part of the log output." + :group 'magit-faces) + +(defface magit-log-author + '((((class color) (background light)) + :foreground "firebrick" + :slant normal + :weight normal) + (((class color) (background dark)) + :foreground "tomato" + :slant normal + :weight normal)) + "Face for the author part of the log output." + :group 'magit-faces) + +(defface magit-log-date + '((((class color) (background light)) + :foreground "grey30" + :slant normal + :weight normal) + (((class color) (background dark)) + :foreground "grey80" + :slant normal + :weight normal)) + "Face for the date part of the log output." + :group 'magit-faces) + +(defface magit-header-line-log-select + '((t :inherit bold)) + "Face for the `header-line' in `magit-log-select-mode'." + :group 'magit-faces) + +;;;; File Log + +(defcustom magit-log-buffer-file-locked t + "Whether `magit-log-buffer-file-quick' uses a dedicated buffer." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :group 'magit-log + :type 'boolean) + +;;;; Select Mode + +(defcustom magit-log-select-show-usage 'both + "Whether to show usage information when selecting a commit from a log. +The message can be shown in the `echo-area' or the `header-line', or in +`both' places. If the value isn't one of these symbols, then it should +be nil, in which case no usage information is shown." + :package-version '(magit . "2.1.0") + :group 'magit-log + :type '(choice (const :tag "in echo-area" echo-area) + (const :tag "in header-line" header-line) + (const :tag "in both places" both) + (const :tag "nowhere"))) + +(defcustom magit-log-select-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width t + (nth 4 magit-log-margin)) + "Format of the margin in `magit-log-select-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-log-select-mode)) + +;;;; Cherry Mode + +(defcustom magit-cherry-sections-hook + '(magit-insert-cherry-headers + magit-insert-cherry-commits) + "Hook run to insert sections into the cherry buffer." + :package-version '(magit . "2.1.0") + :group 'magit-log + :type 'hook) + +(defcustom magit-cherry-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width t + (nth 4 magit-log-margin)) + "Format of the margin in `magit-cherry-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-cherry-mode)) + +;;;; Log Sections + +(defcustom magit-log-section-commit-count 10 + "How many recent commits to show in certain log sections. +How many recent commits `magit-insert-recent-commits' and +`magit-insert-unpulled-from-upstream-or-recent' (provided +the upstream isn't ahead of the current branch) show." + :package-version '(magit . "2.1.0") + :group 'magit-status + :type 'number) + +;;; Arguments +;;;; Prefix Classes + +(defclass magit-log-prefix (transient-prefix) + ((history-key :initform 'magit-log) + (major-mode :initform 'magit-log-mode))) + +(defclass magit-log-refresh-prefix (magit-log-prefix) + ((history-key :initform 'magit-log) + (major-mode :initform nil))) + +;;;; Prefix Methods + +(cl-defmethod transient-init-value ((obj magit-log-prefix)) + (pcase-let ((`(,args ,files) + (magit-log--get-value 'magit-log-mode + magit-prefix-use-buffer-arguments))) + (unless (eq current-transient-command 'magit-dispatch) + (when-let ((file (magit-file-relative-name))) + (setq files (list file)))) + (oset obj value (if files `(("--" ,@files) ,args) args)))) + +(cl-defmethod transient-init-value ((obj magit-log-refresh-prefix)) + (oset obj value (if magit-buffer-log-files + `(("--" ,@magit-buffer-log-files) + ,magit-buffer-log-args) + magit-buffer-log-args))) + +(cl-defmethod transient-set-value ((obj magit-log-prefix)) + (magit-log--set-value obj)) + +(cl-defmethod transient-save-value ((obj magit-log-prefix)) + (magit-log--set-value obj 'save)) + +;;;; Argument Access + +(defun magit-log-arguments (&optional mode) + "Return the current log arguments." + (if (memq current-transient-command '(magit-log magit-log-refresh)) + (pcase-let ((`(,args ,alist) + (-separate #'atom (transient-get-value)))) + (list args (cdr (assoc "--" alist)))) + (magit-log--get-value (or mode 'magit-log-mode)))) + +(defun magit-log--get-value (mode &optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args files) + (cond + ((and (memq use-buffer-args '(always selected current)) + (eq major-mode mode)) + (setq args magit-buffer-log-args) + (setq files magit-buffer-log-files)) + ((and (memq use-buffer-args '(always selected)) + (when-let ((buffer (magit-get-mode-buffer + mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-log-args buffer)) + (setq files (buffer-local-value 'magit-buffer-log-files buffer)) + t))) + ((plist-member (symbol-plist mode) 'magit-log-current-arguments) + (setq args (get mode 'magit-log-current-arguments))) + ((when-let ((elt (assq (intern (format "magit-log:%s" mode)) + transient-values))) + (setq args (cdr elt)) + t)) + (t + (setq args (get mode 'magit-log-default-arguments)))) + (list args files))) + +(defun magit-log--set-value (obj &optional save) + (pcase-let* ((obj (oref obj prototype)) + (mode (or (oref obj major-mode) major-mode)) + (key (intern (format "magit-log:%s" mode))) + (`(,args ,alist) + (-separate #'atom (transient-get-value))) + (files (cdr (assoc "--" alist)))) + (put mode 'magit-log-current-arguments args) + (when save + (setf (alist-get key transient-values) args) + (transient-save-values)) + (transient--history-push obj) + (setq magit-buffer-log-args args) + (unless (derived-mode-p 'magit-log-select-mode) + (setq magit-buffer-log-files files)) + (magit-refresh))) + +;;; Commands +;;;; Prefix Commands + +;;;###autoload (autoload 'magit-log "magit-log" nil t) +(define-transient-command magit-log () + "Show a commit or reference log." + :man-page "git-log" + :class 'magit-log-prefix + ;; The grouping in git-log(1) appears to be guided by implementation + ;; details, so our logical grouping only follows it to an extend. + ;; Arguments that are "misplaced" here: + ;; 1. From "Commit Formatting". + ;; 2. From "Common Diff Options". + ;; 3. From unnamed first group. + ;; 4. Implemented by Magit. + ["Commit limiting" + (magit-log:-n) + (magit:--author) + (7 "=s" "Limit to commits since" "--since=" transient-read-date) + (7 "=u" "Limit to commits until" "--until=" transient-read-date) + (magit-log:--grep) + (7 "-I" "Invert search pattern" "--invert-grep") + (magit-log:-G) ;2 + (magit-log:-S) ;2 + (magit-log:-L) ;2 + (7 "=m" "Omit merges" "--no-merges") + (7 "=p" "First parent" "--first-parent")] + ["History simplification" + ( "-D" "Simplify by decoration" "--simplify-by-decoration") + (magit:--) + ( "-f" "Follow renames when showing single-file log" "--follow") ;3 + (6 "/s" "Only commits changing given paths" "--sparse") + (7 "/d" "Only selected commits plus meaningful history" "--dense") + (7 "/a" "Only commits existing directly on ancestry path" "--ancestry-path") + (6 "/f" "Do not prune history" "--full-history") + (7 "/m" "Prune some history" "--simplify-merges")] + ["Commit ordering" + (magit-log:--*-order) + ("-r" "Reverse order" "--reverse")] + ["Formatting" + ("-g" "Show graph" "--graph") ;1 + ("-c" "Show graph in color" "--color") ;2 + ("-d" "Show refnames" "--decorate") ;3 + ("=S" "Show signatures" "--show-signature") ;1 + ("-h" "Show header" "++header") ;4 + ("-p" "Show diffs" ("-p" "--patch")) ;2 + ("-s" "Show diffstats" "--stat")] ;2 + [["Log" + ("l" "current" magit-log-current) + ("o" "other" magit-log-other) + ("h" "HEAD" magit-log-head)] + ["" + ("L" "local branches" magit-log-branches) + (7 "B" "matching branches" magit-log-matching-branches) + (7 "T" "matching tags" magit-log-matching-tags) + ("b" "all branches" magit-log-all-branches) + ("a" "all references" magit-log-all) + (7 "m" "merged" magit-log-merged)] + ["Reflog" + ("r" "current" magit-reflog-current) + ("O" "other" magit-reflog-other) + ("H" "HEAD" magit-reflog-head)] + [:if magit--any-wip-mode-enabled-p + :description "Wiplog" + ("i" "index" magit-wip-log-index) + ("w" "worktree" magit-wip-log-worktree)]]) + +;;;###autoload (autoload 'magit-log-refresh "magit-log" nil t) +(define-transient-command magit-log-refresh () + "Change the arguments used for the log(s) in the current buffer." + :man-page "git-log" + :class 'magit-log-refresh-prefix + [:if-mode magit-log-mode + :class transient-subgroups + ["Commit limiting" + (magit-log:-n) + (magit:--author) + (magit-log:--grep) + (7 "-I" "Invert search pattern" "--invert-grep") + (magit-log:-G) + (magit-log:-S) + (magit-log:-L)] + ["History simplification" + ( "-D" "Simplify by decoration" "--simplify-by-decoration") + (magit:--) + ( "-f" "Follow renames when showing single-file log" "--follow") ;3 + (6 "/s" "Only commits changing given paths" "--sparse") + (7 "/d" "Only selected commits plus meaningful history" "--dense") + (7 "/a" "Only commits existing directly on ancestry path" "--ancestry-path") + (6 "/f" "Do not prune history" "--full-history") + (7 "/m" "Prune some history" "--simplify-merges")] + ["Commit ordering" + (magit-log:--*-order) + ("-r" "Reverse order" "--reverse")] + ["Formatting" + ("-g" "Show graph" "--graph") + ("-c" "Show graph in color" "--color") + ("-d" "Show refnames" "--decorate") + ("=S" "Show signatures" "--show-signature") + ("-h" "Show header" "++header") + ("-p" "Show diffs" ("-p" "--patch")) + ("-s" "Show diffstats" "--stat")]] + [:if-not-mode magit-log-mode + :description "Arguments" + (magit-log:-n) + (magit-log:--*-order) + ("-g" "Show graph" "--graph") + ("-c" "Show graph in color" "--color") + ("-d" "Show refnames" "--decorate")] + [["Refresh" + ("g" "buffer" magit-log-refresh) + ("s" "buffer and set defaults" transient-set :transient nil) + ("w" "buffer and save defaults" transient-save :transient nil)] + ["Margin" + ("L" "toggle visibility" magit-toggle-margin) + ("l" "cycle style" magit-cycle-margin-style) + ("d" "toggle details" magit-toggle-margin-details) + ("x" "toggle shortstat" magit-toggle-log-margin-style)] + [:if-mode magit-log-mode + :description "Toggle" + ("b" "buffer lock" magit-toggle-buffer-lock)]] + (interactive) + (cond + ((not (eq current-transient-command 'magit-log-refresh)) + (pcase major-mode + (`magit-reflog-mode + (user-error "Cannot change log arguments in reflog buffers")) + (`magit-cherry-mode + (user-error "Cannot change log arguments in cherry buffers"))) + (transient-setup 'magit-log-refresh)) + (t + (pcase-let ((`(,args ,files) (magit-log-arguments))) + (setq magit-buffer-log-args args) + (unless (derived-mode-p 'magit-log-select-mode) + (setq magit-buffer-log-files files))) + (magit-refresh)))) + +;;;; Infix Commands + +(define-infix-argument magit-log:-n () + :description "Limit number of commits" + :class 'transient-option + ;; For historic reasons (and because it easy to guess what "-n" + ;; stands for) this is the only argument where we do not use the + ;; long argument ("--max-count"). + :shortarg "-n" + :argument "-n" + :reader 'transient-read-number-N+) + +(define-infix-argument magit:--author () + :description "Limit to author" + :class 'transient-option + :key "-A" + :argument "--author=" + :reader 'magit-transient-read-person) + +(define-infix-argument magit-log:--*-order () + :description "Order commits by" + :class 'transient-switches + :key "-o" + :argument-format "--%s-order" + :argument-regexp "\\(--\\(topo\\|author-date\\|date\\)-order\\)" + :choices '("topo" "author-date" "date")) + +(define-infix-argument magit-log:--grep () + :description "Search messages" + :class 'transient-option + :key "-F" + :argument "--grep=") + +(define-infix-argument magit-log:-G () + :description "Search changes" + :class 'transient-option + :argument "-G") + +(define-infix-argument magit-log:-S () + :description "Search occurrences" + :class 'transient-option + :argument "-S") + +(define-infix-argument magit-log:-L () + :description "Trace line evolution" + :class 'transient-option + :argument "-L" + :reader 'magit-read-file-trace) + +(defun magit-read-file-trace (&rest _ignored) + (let ((file (magit-read-file-from-rev "HEAD" "File")) + (trace (magit-read-string "Trace"))) + (concat trace ":" file))) + +;;;; Setup Commands + +(defvar magit-log-read-revs-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map crm-local-completion-map) + (define-key map "\s" 'self-insert-command) + map)) + +(defun magit-log-read-revs (&optional use-current) + (or (and use-current (--when-let (magit-get-current-branch) (list it))) + (let ((collection (magit-list-refnames nil t))) + (split-string + (magit-completing-read-multiple "Log rev,s" collection + "\\(\\.\\.\\.?\\|[, ]\\)" + (or (magit-branch-or-commit-at-point) + (unless use-current + (magit-get-previous-branch))) + 'magit-revision-history + magit-log-read-revs-map) + "[, ]" t)))) + +(defun magit-log-read-pattern (option) + "Read a string from the user to pass as parameter to OPTION." + (magit-read-string (format "Type a pattern to pass to %s" option))) + +;;;###autoload +(defun magit-log-current (revs &optional args files) + "Show log for the current branch. +When `HEAD' is detached or with a prefix argument show log for +one or more revs read from the minibuffer." + (interactive (cons (magit-log-read-revs t) + (magit-log-arguments))) + (magit-log-setup-buffer revs args files)) + +;;;###autoload +(defun magit-log-other (revs &optional args files) + "Show log for one or more revs read from the minibuffer. +The user can input any revision or revisions separated by a +space, or even ranges, but only branches and tags, and a +representation of the commit at point, are available as +completion candidates." + (interactive (cons (magit-log-read-revs) + (magit-log-arguments))) + (magit-log-setup-buffer revs args files)) + +;;;###autoload +(defun magit-log-head (&optional args files) + "Show log for `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list "HEAD") args files)) + +;;;###autoload +(defun magit-log-branches (&optional args files) + "Show log for all local branches and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--branches") + (list "HEAD" "--branches")) + args files)) + +;;;###autoload +(defun magit-log-matching-branches (pattern &optional args files) + "Show log for all branches matching PATTERN and `HEAD'." + (interactive (cons (magit-log-read-pattern "--branches") (magit-log-arguments))) + (magit-log-setup-buffer + (list "HEAD" (format "--branches=%s" pattern)) + args files)) + +;;;###autoload +(defun magit-log-matching-tags (pattern &optional args files) + "Show log for all tags matching PATTERN and `HEAD'." + (interactive (cons (magit-log-read-pattern "--tags") (magit-log-arguments))) + (magit-log-setup-buffer + (list "HEAD" (format "--tags=%s" pattern)) + args files)) + +;;;###autoload +(defun magit-log-all-branches (&optional args files) + "Show log for all local and remote branches and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--branches" "--remotes") + (list "HEAD" "--branches" "--remotes")) + args files)) + +;;;###autoload +(defun magit-log-all (&optional args files) + "Show log for all references and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--all") + (list "HEAD" "--all")) + args files)) + +;;;###autoload +(defun magit-log-buffer-file (&optional follow beg end) + "Show log for the blob or file visited in the current buffer. +With a prefix argument or when `--follow' is an active log +argument, then follow renames. When the region is active, +restrict the log to the lines that the region touches." + (interactive + (cons current-prefix-arg + (and (region-active-p) + (magit-file-relative-name) + (save-restriction + (widen) + (list (line-number-at-pos (region-beginning)) + (line-number-at-pos + (let ((end (region-end))) + (if (char-after end) + end + ;; Ensure that we don't get the line number + ;; of a trailing newline. + (1- end))))))))) + (require 'magit) + (if-let ((file (magit-file-relative-name))) + (magit-log-setup-buffer + (list (or magit-buffer-refname + (magit-get-current-branch) + "HEAD")) + (let ((args (car (magit-log-arguments)))) + (when (and follow (not (member "--follow" args))) + (push "--follow" args)) + (when (and (file-regular-p + (expand-file-name file (magit-toplevel))) + beg end) + (setq args (cons (format "-L%s,%s:%s" beg end file) + (cl-delete "-L" args :test + 'string-prefix-p))) + (setq file nil)) + args) + (and file (list file)) + magit-log-buffer-file-locked) + (user-error "Buffer isn't visiting a file"))) + +;;;###autoload +(defun magit-log-trace-definition (file fn rev) + "Show log for the definition at point." + (interactive (list (or (magit-file-relative-name) + (user-error "Buffer isn't visiting a file")) + (or (funcall magit-log-trace-definition-function) + (user-error "No function at point found")) + (or magit-buffer-refname + (magit-get-current-branch) + "HEAD"))) + (require 'magit) + (magit-log-setup-buffer + (list rev) + (cons (format "-L:%s%s:%s" + (replace-regexp-in-string ":" "\\:" (regexp-quote fn) nil t) + (if (derived-mode-p 'lisp-mode 'emacs-lisp-mode) + ;; Git doesn't treat "-" the same way as + ;; "_", leading to false-positives such as + ;; "foo-suffix" being considered a match + ;; for "foo". Wing it. + "\\( \\|$\\)" + ;; We could use "\\b" here, but since Git + ;; already does something equivalent, that + ;; isn't necessary. + "") + file) + (cl-delete "-L" (car (magit-log-arguments)) + :test 'string-prefix-p)) + nil magit-log-buffer-file-locked)) + +(defun magit-diff-trace-definition () + "Show log for the definition at point in a diff." + (interactive) + (pcase-let ((`(,buf ,pos) (magit-diff-visit-file--noselect))) + (magit--with-temp-position buf pos + (call-interactively #'magit-log-trace-definition)))) + +;;;###autoload +(defun magit-log-merged (commit branch &optional args files) + "Show log for the merge of COMMIT into BRANCH. + +More precisely, find merge commit M that brought COMMIT into +BRANCH, and show the log of the range \"M^1..M\". If COMMIT is +directly on BRANCH, then show approximately twenty surrounding +commits instead. + +This command requires git-when-merged, which is available from +https://github.com/mhagger/git-when-merged." + (interactive + (append (let ((commit (magit-read-branch-or-commit "Commit"))) + (list commit + (magit-read-other-branch "Merged into" commit))) + (magit-log-arguments))) + (unless (executable-find "git-when-merged") + (user-error "This command requires git-when-merged (%s)" + "https://github.com/mhagger/git-when-merged")) + (let (exit m) + (with-temp-buffer + (save-excursion + (setq exit (magit-process-file + magit-git-executable nil t nil + "when-merged" "-c" + "--abbrev" (number-to-string (magit-abbrev-length)) + commit branch))) + (setq m (buffer-substring-no-properties (point) (line-end-position)))) + (if (zerop exit) + (magit-log-setup-buffer (list (format "%s^1..%s" m m)) + args files nil commit) + (setq m (string-trim-left (substring m (string-match " " m)))) + (if (equal m "Commit is directly on this branch.") + (let* ((from (concat commit "~10")) + (to (- (car (magit-rev-diff-count branch commit)) 10)) + (to (if (<= to 0) + branch + (format "%s~%s" branch to)))) + (unless (magit-rev-verify-commit from) + (setq from (magit-git-string "rev-list" "--max-parents=0" + commit))) + (magit-log-setup-buffer (list (concat from ".." to)) + (cons "--first-parent" args) + files nil commit)) + (user-error "Could not find when %s was merged into %s: %s" + commit branch m))))) + +;;;; Limit Commands + +(defun magit-log-toggle-commit-limit () + "Toggle the number of commits the current log buffer is limited to. +If the number of commits is currently limited, then remove that +limit. Otherwise set it to 256." + (interactive) + (magit-log-set-commit-limit (lambda (&rest _) nil))) + +(defun magit-log-double-commit-limit () + "Double the number of commits the current log buffer is limited to." + (interactive) + (magit-log-set-commit-limit '*)) + +(defun magit-log-half-commit-limit () + "Half the number of commits the current log buffer is limited to." + (interactive) + (magit-log-set-commit-limit '/)) + +(defun magit-log-set-commit-limit (fn) + (let* ((val magit-buffer-log-args) + (arg (--first (string-match "^-n\\([0-9]+\\)?$" it) val)) + (num (and arg (string-to-number (match-string 1 arg)))) + (num (if num (funcall fn num 2) 256))) + (setq val (delete arg val)) + (setq magit-buffer-log-args + (if (and num (> num 0)) + (cons (format "-n%i" num) val) + val))) + (magit-refresh)) + +(defun magit-log-get-commit-limit () + (--when-let (--first (string-match "^-n\\([0-9]+\\)?$" it) + magit-buffer-log-args) + (string-to-number (match-string 1 it)))) + +;;;; Mode Commands + +(defun magit-log-bury-buffer (&optional arg) + "Bury the current buffer or the revision buffer in the same frame. +Like `magit-mode-bury-buffer' (which see) but with a negative +prefix argument instead bury the revision buffer, provided it +is displayed in the current frame." + (interactive "p") + (if (< arg 0) + (let* ((buf (magit-get-mode-buffer 'magit-revision-mode)) + (win (and buf (get-buffer-window buf (selected-frame))))) + (if win + (with-selected-window win + (with-current-buffer buf + (magit-mode-bury-buffer (> (abs arg) 1)))) + (user-error "No revision buffer in this frame"))) + (magit-mode-bury-buffer (> arg 1)))) + +;;;###autoload +(defun magit-log-move-to-parent (&optional n) + "Move to the Nth parent of the current commit." + (interactive "p") + (when (derived-mode-p 'magit-log-mode) + (when (magit-section-match 'commit) + (let* ((section (magit-current-section)) + (parent-rev (format "%s^%s" (oref section value) (or n 1)))) + (if-let ((parent-hash (magit-rev-parse "--short" parent-rev))) + (if-let ((parent (--first (equal (oref it value) + parent-hash) + (magit-section-siblings section 'next)))) + (magit-section-goto parent) + (user-error + (substitute-command-keys + (concat "Parent " parent-hash " not found. Try typing " + "\\[magit-log-double-commit-limit] first")))) + (user-error "Parent %s does not exist" parent-rev)))))) + +;;; Log Mode + +(defvar magit-log-disable-graph-hack-args + '("-G" "--grep" "--author") + "Arguments which disable the graph speedup hack.") + +(defvar magit-log-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + (define-key map "\C-c\C-b" 'magit-go-backward) + (define-key map "\C-c\C-f" 'magit-go-forward) + (define-key map "\C-c\C-n" 'magit-log-move-to-parent) + (define-key map "=" 'magit-log-toggle-commit-limit) + (define-key map "+" 'magit-log-double-commit-limit) + (define-key map "-" 'magit-log-half-commit-limit) + (define-key map "q" 'magit-log-bury-buffer) + map) + "Keymap for `magit-log-mode'.") + +(define-derived-mode magit-log-mode magit-mode "Magit Log" + "Mode for looking at Git log. + +This mode is documented in info node `(magit)Log Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-branch] to see available branch commands. +Type \\[magit-merge] to merge the branch or commit at point. +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-log-mode-map}" + :group 'magit-log + (hack-dir-local-variables-non-file-buffer) + (setq imenu-prev-index-position-function + 'magit-imenu--log-prev-index-position-function) + (setq imenu-extract-index-name-function + 'magit-imenu--log-extract-index-name-function)) + +(put 'magit-log-mode 'magit-log-default-arguments + '("--graph" "-n256" "--decorate")) + +(defun magit-log-setup-buffer (revs args files &optional locked focus) + (require 'magit) + (with-current-buffer + (magit-setup-buffer #'magit-log-mode locked + (magit-buffer-revisions revs) + (magit-buffer-log-args args) + (magit-buffer-log-files files)) + (when (if focus + (magit-log-goto-commit-section focus) + (magit-log-goto-same-commit)) + (magit-section-update-highlight)) + (current-buffer))) + +(defun magit-log-refresh-buffer () + (let ((revs magit-buffer-revisions) + (args magit-buffer-log-args) + (files magit-buffer-log-files)) + (magit-set-header-line-format + (funcall magit-log-header-line-function revs args files)) + (if (= (length files) 1) + (unless (magit-file-tracked-p (car files)) + (setq args (cons "--full-history" args))) + (setq args (remove "--follow" args))) + (when (and (car magit-log-remove-graph-args) + (--any-p (string-match-p + (concat "^" (regexp-opt magit-log-remove-graph-args)) it) + args)) + (setq args (remove "--graph" args))) + (unless (member "--graph" args) + (setq args (remove "--color" args))) + (when-let ((limit (magit-log-get-commit-limit)) + (limit (* 2 limit)) ; increase odds for complete graph + (count (and (= (length revs) 1) + (> limit 1024) ; otherwise it's fast enough + (setq revs (car revs)) + (not (string-match-p "\\.\\." revs)) + (not (member revs '("--all" "--branches"))) + (-none-p (lambda (arg) + (--any-p (string-prefix-p it arg) + magit-log-disable-graph-hack-args)) + args) + (magit-git-string "rev-list" "--count" + "--first-parent" args revs)))) + (setq revs (if (< (string-to-number count) limit) + revs + (format "%s~%s..%s" revs limit revs)))) + (magit-insert-section (logbuf) + (magit-insert-log revs args files)))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-log-mode)) + (append magit-buffer-revisions + (if (and magit-buffer-revisions magit-buffer-log-files) + (cons "--" magit-buffer-log-files) + magit-buffer-log-files))) + +(defun magit-log-header-line-arguments (revs args files) + "Return string describing some of the used arguments." + (mapconcat (lambda (arg) + (if (string-match-p " " arg) + (prin1 arg) + arg)) + `("git" "log" ,@args ,@revs "--" ,@files) + " ")) + +(defun magit-log-header-line-sentence (revs args files) + "Return string containing all arguments." + (concat "Commits in " + (mapconcat #'identity revs " ") + (and (member "--reverse" args) + " in reverse") + (and files (concat " touching " + (mapconcat 'identity files " "))) + (--some (and (string-prefix-p "-L" it) + (concat " " it)) + args))) + +(defun magit-insert-log (revs &optional args files) + "Insert a log section. +Do not add this to a hook variable." + (let ((magit-git-global-arguments + (remove "--literal-pathspecs" magit-git-global-arguments))) + (magit-git-wash (apply-partially #'magit-log-wash-log 'log) + "log" + (format "--format=%s%%h%%x00%s%%x00%s%%x00%%aN%%x00%s%%x00%%s%s" + (if (and (member "--left-right" args) + (not (member "--graph" args))) + "%m " + "") + (if (member "--decorate" args) "%D" "") + (if (member "--show-signature" args) + (progn (setq args (remove "--show-signature" args)) "%G?") + "") + (if magit-log-margin-show-committer-date "%ct" "%at") + (if (member "++header" args) + (if (member "--graph" (setq args (remove "++header" args))) + (concat "\n" magit-log-revision-headers-format "\n") + (concat "\n" magit-log-revision-headers-format "\n")) + "")) + (progn + (--when-let (--first (string-match "^\\+\\+order=\\(.+\\)$" it) args) + (setq args (cons (format "--%s-order" (match-string 1 it)) + (remove it args)))) + (when (member "--decorate" args) + (setq args (cons "--decorate=full" (remove "--decorate" args)))) + (when (member "--reverse" args) + (setq args (remove "--graph" args))) + args) + "--use-mailmap" "--no-prefix" revs "--" files))) + +(defvar magit-commit-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-show-commit) + (define-key map "a" 'magit-cherry-apply) + map) + "Keymap for `commit' sections.") + +(defvar magit-module-commit-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-show-commit) + map) + "Keymap for `module-commit' sections.") + +(defconst magit-log-heading-re + (concat "^" + "\\(?4:[-_/|\\*o<>. ]*\\)" ; graph + "\\(?1:[0-9a-fA-F]+\\)?\0" ; sha1 + "\\(?3:[^\0\n]+\\)?\0" ; refs + "\\(?7:[BGUXYREN]\\)?\0" ; gpg + "\\(?5:[^\0\n]*\\)\0" ; author + ;; Note: Date is optional because, prior to Git v2.19.0, + ;; `git rebase -i --root` corrupts the root's author date. + "\\(?6:[^\0\n]*\\)\0" ; date + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-cherry-re + (concat "^" + "\\(?8:[-+]\\) " ; cherry + "\\(?1:[0-9a-fA-F]+\\) " ; sha1 + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-module-re + (concat "^" + "\\(?:\\(?11:[<>]\\) \\)?" ; side + "\\(?1:[0-9a-fA-F]+\\) " ; sha1 + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-bisect-vis-re + (concat "^" + "\\(?4:[-_/|\\*o<>. ]*\\)" ; graph + "\\(?1:[0-9a-fA-F]+\\)?\0" ; sha1 + "\\(?3:[^\0\n]+\\)?\0" ; refs + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-bisect-log-re + (concat "^# " + "\\(?3:bad:\\|skip:\\|good:\\) " ; "refs" + "\\[\\(?1:[^]\n]+\\)\\] " ; sha1 + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-reflog-re + (concat "^" + "\\(?1:[^\0\n]+\\)\0" ; sha1 + "\\(?5:[^\0\n]*\\)\0" ; author + "\\(?:\\(?:[^@\n]+@{\\(?6:[^}\n]+\\)}\0" ; date + "\\(?10:merge \\|autosave \\|restart \\|[^:\n]+: \\)?" ; refsub + "\\(?2:.*\\)?\\)\\|\0\\)$")) ; msg + +(defconst magit-reflog-subject-re + (concat "\\(?1:[^ ]+\\) ?" ; command + "\\(?2:\\(?: ?-[^ ]+\\)+\\)?" ; option + "\\(?: ?(\\(?3:[^)]+\\))\\)?")) ; type + +(defconst magit-log-stash-re + (concat "^" + "\\(?1:[^\0\n]+\\)\0" ; "sha1" + "\\(?5:[^\0\n]*\\)\0" ; author + "\\(?6:[^\0\n]+\\)\0" ; date + "\\(?2:.*\\)$")) ; msg + +(defvar magit-log-count nil) + +(defvar magit-log-format-message-function 'magit-log-propertize-keywords) + +(defun magit-log-wash-log (style args) + (setq args (-flatten args)) + (when (and (member "--graph" args) + (member "--color" args)) + (let ((ansi-color-apply-face-function + (lambda (beg end face) + (put-text-property beg end 'font-lock-face + (or face 'magit-log-graph))))) + (ansi-color-apply-on-region (point-min) (point-max)))) + (when (eq style 'cherry) + (reverse-region (point-min) (point-max))) + (let ((magit-log-count 0)) + (when (looking-at "^\\.\\.\\.") + (magit-delete-line)) + (magit-wash-sequence (apply-partially 'magit-log-wash-rev style + (magit-abbrev-length))) + (if (derived-mode-p 'magit-log-mode 'magit-reflog-mode) + (when (eq magit-log-count (magit-log-get-commit-limit)) + (magit-insert-section (longer) + (insert-text-button + (substitute-command-keys + (format "Type \\<%s>\\[%s] to show more history" + 'magit-log-mode-map + 'magit-log-double-commit-limit)) + 'action (lambda (_button) + (magit-log-double-commit-limit)) + 'follow-link t + 'mouse-face 'magit-section-highlight))) + (insert ?\n)))) + +(cl-defun magit-log-wash-rev (style abbrev) + (when (derived-mode-p 'magit-log-mode 'magit-reflog-mode) + (cl-incf magit-log-count)) + (looking-at (pcase style + (`log magit-log-heading-re) + (`cherry magit-log-cherry-re) + (`module magit-log-module-re) + (`reflog magit-log-reflog-re) + (`stash magit-log-stash-re) + (`bisect-vis magit-log-bisect-vis-re) + (`bisect-log magit-log-bisect-log-re))) + (magit-bind-match-strings + (hash msg refs graph author date gpg cherry _ refsub side) nil + (setq msg (substring-no-properties msg)) + (when refs + (setq refs (substring-no-properties refs))) + (let ((align (or (eq style 'cherry) + (not (member "--stat" magit-buffer-log-args)))) + (non-graph-re (if (eq style 'bisect-vis) + magit-log-bisect-vis-re + magit-log-heading-re))) + (magit-delete-line) + ;; If the reflog entries have been pruned, the output of `git + ;; reflog show' includes a partial line that refers to the hash + ;; of the youngest expired reflog entry. + (when (and (eq style 'reflog) (not date)) + (cl-return-from magit-log-wash-rev t)) + (magit-insert-section section (commit hash) + (pcase style + (`stash (oset section type 'stash)) + (`module (oset section type 'module-commit)) + (`bisect-log (setq hash (magit-rev-parse "--short" hash)))) + (when cherry + (when (and (derived-mode-p 'magit-refs-mode) + magit-refs-show-commit-count) + (insert (make-string (1- magit-refs-focus-column-width) ?\s))) + (insert (propertize cherry 'font-lock-face + (if (string= cherry "-") + 'magit-cherry-equivalent + 'magit-cherry-unmatched))) + (insert ?\s)) + (when side + (insert (propertize side 'font-lock-face + (if (string= side "<") + 'magit-cherry-equivalent + 'magit-cherry-unmatched))) + (insert ?\s)) + (when align + (insert (propertize hash 'font-lock-face 'magit-hash) ?\s)) + (when graph + (insert graph)) + (unless align + (insert (propertize hash 'font-lock-face 'magit-hash) ?\s)) + (when (and refs (not magit-log-show-refname-after-summary)) + (insert (magit-format-ref-labels refs) ?\s)) + (when (eq style 'reflog) + (insert (format "%-2s " (1- magit-log-count))) + (when refsub + (insert (magit-reflog-format-subject + (substring refsub 0 (if (string-match-p ":" refsub) -2 -1)))))) + (when msg + (when gpg + (setq msg (propertize msg 'font-lock-face + (pcase (aref gpg 0) + (?G 'magit-signature-good) + (?B 'magit-signature-bad) + (?U 'magit-signature-untrusted) + (?X 'magit-signature-expired) + (?Y 'magit-signature-expired-key) + (?R 'magit-signature-revoked) + (?E 'magit-signature-error))))) + (insert (funcall magit-log-format-message-function hash msg))) + (when (and refs magit-log-show-refname-after-summary) + (insert ?\s) + (insert (magit-format-ref-labels refs))) + (insert ?\n) + (when (memq style '(log reflog stash)) + (goto-char (line-beginning-position)) + (when (and refsub + (string-match "\\`\\([^ ]\\) \\+\\(..\\)\\(..\\)" date)) + (setq date (+ (string-to-number (match-string 1 date)) + (* (string-to-number (match-string 2 date)) 60 60) + (* (string-to-number (match-string 3 date)) 60)))) + (save-excursion + (backward-char) + (magit-log-format-margin hash author date))) + (when (and (eq style 'cherry) + (magit-buffer-margin-p)) + (save-excursion + (backward-char) + (apply #'magit-log-format-margin hash + (split-string (magit-rev-format "%aN%x00%ct" hash) "\0")))) + (when (and graph + (not (eobp)) + (not (looking-at non-graph-re))) + (when (looking-at "") + (magit-insert-heading) + (delete-char 1) + (magit-insert-section (commit-header) + (forward-line) + (magit-insert-heading) + (re-search-forward "") + (backward-delete-char 1) + (forward-char) + (insert ?\n)) + (delete-char 1)) + (if (looking-at "^\\(---\\|\n\s\\|\ndiff\\)") + (let ((limit (save-excursion + (and (re-search-forward non-graph-re nil t) + (match-beginning 0))))) + (unless (oref magit-insert-section--current content) + (magit-insert-heading)) + (delete-char (if (looking-at "\n") 1 4)) + (magit-diff-wash-diffs (list "--stat") limit)) + (when align + (setq align (make-string (1+ abbrev) ? ))) + (when (and (not (eobp)) (not (looking-at non-graph-re))) + (when align + (setq align (make-string (1+ abbrev) ? ))) + (while (and (not (eobp)) (not (looking-at non-graph-re))) + (when align + (save-excursion (insert align))) + (magit-make-margin-overlay) + (forward-line)) + ;; When `--format' is used and its value isn't one of the + ;; predefined formats, then `git-log' does not insert a + ;; separator line. + (save-excursion + (forward-line -1) + (looking-at "[-_/|\\*o<>. ]*")) + (setq graph (match-string 0)) + (unless (string-match-p "[/\\.]" graph) + (insert graph ?\n)))))))) + t) + +(defun magit-log-propertize-keywords (_rev msg) + (let ((boundary 0)) + (when (string-match "^\\(?:squash\\|fixup\\)! " msg boundary) + (setq boundary (match-end 0)) + (magit--put-face (match-beginning 0) (1- boundary) + 'magit-keyword-squash msg)) + (when magit-log-highlight-keywords + (while (string-match "\\[[^[]*?]" msg boundary) + (setq boundary (match-end 0)) + (magit--put-face (match-beginning 0) boundary + 'magit-keyword msg)))) + msg) + +(defun magit-log-maybe-show-more-commits (section) + "When point is at the end of a log buffer, insert more commits. + +Log buffers end with a button \"Type + to show more history\". +When the use of a section movement command puts point on that +button, then automatically show more commits, without the user +having to press \"+\". + +This function is called by `magit-section-movement-hook' and +exists mostly for backward compatibility reasons." + (when (and (eq (oref section type) 'longer) + magit-log-auto-more) + (magit-log-double-commit-limit) + (forward-line -1) + (magit-section-forward))) + +(add-hook 'magit-section-movement-hook #'magit-log-maybe-show-more-commits) + +(defvar magit--update-revision-buffer nil) + +(defun magit-log-maybe-update-revision-buffer (&optional _) + "When moving in a log or cherry buffer, update the revision buffer. +If there is no revision buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-log-mode 'magit-cherry-mode 'magit-reflog-mode) + (magit--maybe-update-revision-buffer))) + +(add-hook 'magit-section-movement-hook #'magit-log-maybe-update-revision-buffer) + +(defun magit--maybe-update-revision-buffer () + (when-let ((commit (magit-section-value-if 'commit)) + (buffer (magit-get-mode-buffer 'magit-revision-mode nil t))) + (if magit--update-revision-buffer + (setq magit--update-revision-buffer (list commit buffer)) + (setq magit--update-revision-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (let ((args (with-current-buffer buffer + (let ((magit-direct-use-buffer-arguments 'selected)) + (magit-show-commit--arguments))))) + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-revision-buffer)) + (setq magit--update-revision-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-show-commit rev args)))) + (setq magit--update-revision-buffer nil))))))) + +(defvar magit--update-blob-buffer nil) + +(defun magit-log-maybe-update-blob-buffer (&optional _) + "When moving in a log or cherry buffer, update the blob buffer. +If there is no blob buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-log-mode 'magit-cherry-mode 'magit-reflog-mode) + (magit--maybe-update-blob-buffer))) + +(defun magit--maybe-update-blob-buffer () + (when-let ((commit (magit-section-value-if 'commit)) + (buffer (--first (with-current-buffer it + (eq revert-buffer-function + 'magit-revert-rev-file-buffer)) + (mapcar #'window-buffer (window-list))))) + (if magit--update-blob-buffer + (setq magit--update-blob-buffer (list commit buffer)) + (setq magit--update-blob-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-blob-buffer)) + (setq magit--update-blob-buffer nil) + (when (buffer-live-p buf) + (with-selected-window (get-buffer-window buf) + (with-current-buffer buf + (save-excursion + (magit-blob-visit (list (magit-rev-parse rev) + (magit-file-relative-name + magit-buffer-file-name)) + (line-number-at-pos)))))))))))) + +(defun magit-log-goto-commit-section (rev) + (let ((abbrev (magit-rev-format "%h" rev))) + (when-let ((section (--first (equal (oref it value) abbrev) + (oref magit-root-section children)))) + (goto-char (oref section start))))) + +(defun magit-log-goto-same-commit () + (when (and magit-previous-section + (magit-section-match '(commit branch) + magit-previous-section)) + (magit-log-goto-commit-section (oref magit-previous-section value)))) + +;;; Log Margin + +(defvar-local magit-log-margin-show-shortstat nil) + +(defun magit-toggle-log-margin-style () + "Toggle between the regular and the shortstat margin style. +The shortstat style is experimental and rather slow." + (interactive) + (setq magit-log-margin-show-shortstat + (not magit-log-margin-show-shortstat)) + (magit-set-buffer-margin nil t)) + +(defun magit-log-format-margin (rev author date) + (when (magit-margin-option) + (if magit-log-margin-show-shortstat + (magit-log-format-shortstat-margin rev) + (magit-log-format-author-margin author date)))) + +(defun magit-log-format-author-margin (author date &optional previous-line) + (pcase-let ((`(,_ ,style ,width ,details ,details-width) + (or magit-buffer-margin + (symbol-value (magit-margin-option))))) + (magit-make-margin-overlay + (concat (and details + (concat (magit--propertize-face + (truncate-string-to-width + (or author "") + details-width + nil ?\s (make-string 1 magit-ellipsis)) + 'magit-log-author) + " ")) + (magit--propertize-face + (if (stringp style) + (format-time-string + style + (seconds-to-time (string-to-number date))) + (pcase-let* ((abbr (eq style 'age-abbreviated)) + (`(,cnt ,unit) (magit--age date abbr))) + (format (format (if abbr "%%2i%%-%ic" "%%2i %%-%is") + (- width (if details (1+ details-width) 0))) + cnt unit))) + 'magit-log-date)) + previous-line))) + +(defun magit-log-format-shortstat-margin (rev) + (magit-make-margin-overlay + (if-let ((line (and rev (magit-git-string + "show" "--format=" "--shortstat" rev)))) + (if (string-match "\ +\\([0-9]+\\) files? changed, \ +\\(?:\\([0-9]+\\) insertions?(\\+)\\)?\ +\\(?:\\(?:, \\)?\\([0-9]+\\) deletions?(-)\\)?\\'" line) + (magit-bind-match-strings (files add del) line + (format + "%5s %5s%4s" + (if add + (magit--propertize-face (format "%s+" add) + 'magit-diffstat-added) + "") + (if del + (magit--propertize-face (format "%s-" del) + 'magit-diffstat-removed) + "") + files)) + "") + ""))) + +(defun magit-log-margin-width (style details details-width) + (if magit-log-margin-show-shortstat + 16 + (+ (if details (1+ details-width) 0) + (if (stringp style) + (length (format-time-string style)) + (+ 2 ; two digits + 1 ; trailing space + (if (eq style 'age-abbreviated) + 1 ; single character + (+ 1 ; gap after digits + (apply #'max (--map (max (length (nth 1 it)) + (length (nth 2 it))) + magit--age-spec))))))))) + +;;; Select Mode + +(defvar magit-log-select-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-log-mode-map) + (define-key map "\C-c\C-b" 'undefined) + (define-key map "\C-c\C-f" 'undefined) + (define-key map "." 'magit-log-select-pick) + (define-key map "e" 'magit-log-select-pick) + (define-key map "\C-c\C-c" 'magit-log-select-pick) + (define-key map "q" 'magit-log-select-quit) + (define-key map "\C-c\C-k" 'magit-log-select-quit) + map) + "Keymap for `magit-log-select-mode'.") + +(put 'magit-log-select-pick :advertised-binding [?\C-c ?\C-c]) +(put 'magit-log-select-quit :advertised-binding [?\C-c ?\C-k]) + +(define-derived-mode magit-log-select-mode magit-log-mode "Magit Select" + "Mode for selecting a commit from history. + +This mode is documented in info node `(magit)Select from Log'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +\\\ +Type \\[magit-log-select-pick] to select the commit at point. +Type \\[magit-log-select-quit] to abort without selecting a commit." + :group 'magit-log + (hack-dir-local-variables-non-file-buffer)) + +(put 'magit-log-select-mode 'magit-log-default-arguments + '("--graph" "-n256" "--decorate")) + +(defun magit-log-select-setup-buffer (revs args) + (magit-setup-buffer #'magit-log-select-mode nil + (magit-buffer-revisions revs) + (magit-buffer-log-args args))) + +(defun magit-log-select-refresh-buffer () + (magit-insert-section (logbuf) + (magit-insert-log magit-buffer-revisions + magit-buffer-log-args))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-log-select-mode)) + magit-buffer-revisions) + +(defvar-local magit-log-select-pick-function nil) +(defvar-local magit-log-select-quit-function nil) + +(defun magit-log-select (pick &optional msg quit branch args initial) + (declare (indent defun)) + (unless initial + (setq initial (magit-commit-at-point))) + (magit-log-select-setup-buffer + (or branch (magit-get-current-branch) "HEAD") + (append args + (car (magit-log--get-value 'magit-log-select-mode + magit-direct-use-buffer-arguments)))) + (when initial + (magit-log-goto-commit-section initial)) + (setq magit-log-select-pick-function pick) + (setq magit-log-select-quit-function quit) + (when magit-log-select-show-usage + (let ((pick (propertize (substitute-command-keys + "\\[magit-log-select-pick]") + 'font-lock-face + 'magit-header-line-key)) + (quit (propertize (substitute-command-keys + "\\[magit-log-select-quit]") + 'font-lock-face + 'magit-header-line-key))) + (setq msg (format-spec + (if msg + (if (string-suffix-p "," msg) + (concat msg " or %q to abort") + msg) + "Type %p to select commit at point, or %q to abort") + `((?p . ,pick) + (?q . ,quit))))) + (magit--add-face-text-property + 0 (length msg) 'magit-header-line-log-select t msg) + (when (memq magit-log-select-show-usage '(both header-line)) + (magit-set-header-line-format msg)) + (when (memq magit-log-select-show-usage '(both echo-area)) + (message "%s" (substring-no-properties msg))))) + +(defun magit-log-select-pick () + "Select the commit at point and act on it. +Call `magit-log-select-pick-function' with the selected +commit as argument." + (interactive) + (let ((fun magit-log-select-pick-function) + (rev (magit-commit-at-point))) + (magit-mode-bury-buffer 'kill) + (funcall fun rev))) + +(defun magit-log-select-quit () + "Abort selecting a commit, don't act on any commit." + (interactive) + (magit-mode-bury-buffer 'kill) + (when magit-log-select-quit-function + (funcall magit-log-select-quit-function))) + +;;; Cherry Mode + +(defvar magit-cherry-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + (define-key map "q" 'magit-log-bury-buffer) + (define-key map "L" 'magit-margin-settings) + map) + "Keymap for `magit-cherry-mode'.") + +(define-derived-mode magit-cherry-mode magit-mode "Magit Cherry" + "Mode for looking at commits not merged upstream. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-cherry-pick] to apply the commit at point. + +\\{magit-cherry-mode-map}" + :group 'magit-log + (hack-dir-local-variables-non-file-buffer) + (setq imenu-create-index-function + 'magit-imenu--cherry-create-index-function)) + +(defun magit-cherry-setup-buffer (head upstream) + (magit-setup-buffer #'magit-cherry-mode nil + (magit-buffer-refname head) + (magit-buffer-upstream upstream) + (magit-buffer-range (concat upstream ".." head)))) + +(defun magit-cherry-refresh-buffer () + (magit-insert-section (cherry) + (magit-run-section-hook 'magit-cherry-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-cherry-mode)) + magit-buffer-range) + +;;;###autoload +(defun magit-cherry (head upstream) + "Show commits in a branch that are not merged in the upstream branch." + (interactive + (let ((head (magit-read-branch "Cherry head"))) + (list head (magit-read-other-branch "Cherry upstream" head + (magit-get-upstream-branch head))))) + (require 'magit) + (magit-cherry-setup-buffer head upstream)) + +(defun magit-insert-cherry-headers () + "Insert headers appropriate for `magit-cherry-mode' buffers." + (let ((branch (propertize magit-buffer-refname + 'font-lock-face 'magit-branch-local)) + (upstream (propertize magit-buffer-upstream 'font-lock-face + (if (magit-local-branch-p magit-buffer-upstream) + 'magit-branch-local + 'magit-branch-remote)))) + (magit-insert-head-branch-header branch) + (magit-insert-upstream-branch-header branch upstream "Upstream: ") + (insert ?\n))) + +(defun magit-insert-cherry-commits () + "Insert commit sections into a `magit-cherry-mode' buffer." + (magit-insert-section (cherries) + (magit-insert-heading "Cherry commits:") + (magit-git-wash (apply-partially 'magit-log-wash-log 'cherry) + "cherry" "-v" "--abbrev" + magit-buffer-upstream + magit-buffer-refname))) + +;;; Log Sections +;;;; Standard Log Sections + +(defvar magit-unpulled-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-diff-dwim) + map) + "Keymap for `unpulled' sections.") + +(magit-define-section-jumper magit-jump-to-unpulled-from-upstream + "Unpulled from @{upstream}" unpulled "..@{upstream}") + +(defun magit-insert-unpulled-from-upstream () + "Insert commits that haven't been pulled from the upstream yet." + (when-let ((upstream (magit-get-upstream-branch))) + (magit-insert-section (unpulled "..@{upstream}" t) + (magit-insert-heading + (format (propertize "Unpulled from %s." + 'font-lock-face 'magit-section-heading) + upstream)) + (magit-insert-log "..@{upstream}" magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(magit-define-section-jumper magit-jump-to-unpulled-from-pushremote + "Unpulled from " unpulled + (concat ".." (magit-get-push-branch))) + +(defun magit-insert-unpulled-from-pushremote () + "Insert commits that haven't been pulled from the push-remote yet." + (--when-let (magit-get-push-branch) + (unless (and (equal (magit-rev-name it) + (magit-rev-name "@{upstream}")) + (or (memq 'magit-insert-unpulled-from-upstream + magit-status-sections-hook) + (memq 'magit-insert-unpulled-from-upstream-or-recent + magit-status-sections-hook))) + (magit-insert-section (unpulled (concat ".." it) t) + (magit-insert-heading + (format (propertize "Unpulled from %s." + 'font-lock-face 'magit-section-heading) + (propertize it 'font-lock-face 'magit-branch-remote))) + (magit-insert-log (concat ".." it) magit-buffer-log-args) + (magit-log-insert-child-count))))) + +(defvar magit-unpushed-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-diff-dwim) + map) + "Keymap for `unpushed' sections.") + +(magit-define-section-jumper magit-jump-to-unpushed-to-upstream + "Unpushed to @{upstream}" unpushed "@{upstream}..") + +(defun magit-insert-unpushed-to-upstream-or-recent () + "Insert section showing unpushed or other recent commits. +If an upstream is configured for the current branch and it is +behind of the current branch, then show the commits that have +not yet been pushed into the upstream branch. If no upstream is +configured or if the upstream is not behind of the current branch, +then show the last `magit-log-section-commit-count' commits." + (let ((upstream (magit-get-upstream-branch))) + (if (or (not upstream) + (magit-rev-ancestor-p "HEAD" upstream)) + (magit-insert-recent-commits 'unpushed "@{upstream}..") + (magit-insert-unpushed-to-upstream)))) + +(defun magit-insert-unpushed-to-upstream () + "Insert commits that haven't been pushed to the upstream yet." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpushed "@{upstream}..") + (magit-insert-heading + (format (propertize "Unmerged into %s." + 'font-lock-face 'magit-section-heading) + (magit-get-upstream-branch))) + (magit-insert-log "@{upstream}.." magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(defun magit-insert-recent-commits (&optional type value) + "Insert section showing recent commits. +Show the last `magit-log-section-commit-count' commits." + (let* ((start (format "HEAD~%s" magit-log-section-commit-count)) + (range (and (magit-rev-verify start) + (concat start "..HEAD")))) + (magit-insert-section ((eval (or type 'recent)) + (or value range) + t) + (magit-insert-heading "Recent commits") + (magit-insert-log range + (cons (format "-n%d" magit-log-section-commit-count) + (--remove (string-prefix-p "-n" it) + magit-buffer-log-args)))))) + +(magit-define-section-jumper magit-jump-to-unpushed-to-pushremote + "Unpushed to " unpushed + (concat (magit-get-push-branch) "..")) + +(defun magit-insert-unpushed-to-pushremote () + "Insert commits that haven't been pushed to the push-remote yet." + (--when-let (magit-get-push-branch) + (unless (and (equal (magit-rev-name it) + (magit-rev-name "@{upstream}")) + (or (memq 'magit-insert-unpushed-to-upstream + magit-status-sections-hook) + (memq 'magit-insert-unpushed-to-upstream-or-recent + magit-status-sections-hook))) + (magit-insert-section (unpushed (concat it "..") t) + (magit-insert-heading + (format (propertize "Unpushed to %s." + 'font-lock-face 'magit-section-heading) + (propertize it 'font-lock-face 'magit-branch-remote))) + (magit-insert-log (concat it "..") magit-buffer-log-args) + (magit-log-insert-child-count))))) + +(defun magit-log-insert-child-count () + (when magit-section-show-child-count + (let ((count (length (oref magit-insert-section--current children)))) + (when (> count 0) + (when (= count (magit-log-get-commit-limit)) + (setq count (format "%s+" count))) + (save-excursion + (goto-char (- (oref magit-insert-section--current content) 2)) + (insert (format " (%s)" count)) + (delete-char 1)))))) + +;;;; Auxiliary Log Sections + +(defun magit-insert-unpulled-cherries () + "Insert section showing unpulled commits. +Like `magit-insert-unpulled-from-upstream' but prefix each commit +which has not been applied yet (i.e. a commit with a patch-id +not shared with any local commit) with \"+\", and all others with +\"-\"." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpulled "..@{upstream}") + (magit-insert-heading "Unpulled commits:") + (magit-git-wash (apply-partially 'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) + (magit-get-current-branch) "@{upstream}")))) + +(defun magit-insert-unpushed-cherries () + "Insert section showing unpushed commits. +Like `magit-insert-unpushed-to-upstream' but prefix each commit +which has not been applied to upstream yet (i.e. a commit with +a patch-id not shared with any upstream commit) with \"+\", and +all others with \"-\"." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpushed "@{upstream}..") + (magit-insert-heading "Unpushed commits:") + (magit-git-wash (apply-partially 'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) "@{upstream}")))) + +;;; _ +(provide 'magit-log) +;;; magit-log.el ends here diff --git a/elpa/magit-20200318.1224/magit-log.elc b/elpa/magit-20200318.1224/magit-log.elc new file mode 100644 index 00000000..bb11fc8c Binary files /dev/null and b/elpa/magit-20200318.1224/magit-log.elc differ diff --git a/elpa/magit-20200318.1224/magit-margin.el b/elpa/magit-20200318.1224/magit-margin.el new file mode 100644 index 00000000..af85389c --- /dev/null +++ b/elpa/magit-20200318.1224/magit-margin.el @@ -0,0 +1,241 @@ +;;; magit-margin.el --- margins in Magit buffers -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for showing additional information +;; in the margins of Magit buffers. Currently this is only used for +;; commits, for which the committer date or age, and optionally the +;; author name are shown. + +;;; Code: + +(require 'dash) + +(eval-when-compile + (require 'subr-x)) + +(require 'magit-section) +(require 'magit-transient) +(require 'magit-mode) + +(defgroup magit-margin nil + "Information Magit displays in the margin. + +You can change the STYLE and AUTHOR-WIDTH of all `magit-*-margin' +options to the same values by customizing `magit-log-margin' +*before* `magit' is loaded. If you do that, then the respective +values for the other options will default to what you have set +for that variable. Likewise if you set `magit-log-margin's INIT +to nil, then that is used in the default of all other options. But +setting it to t, i.e. re-enforcing the default for that option, +does not carry to other options." + :link '(info-link "(magit)Log Margin") + :group 'magit-log) + +(defvar-local magit-buffer-margin nil) +(put 'magit-buffer-margin 'permanent-local t) + +(defvar-local magit-set-buffer-margin-refresh nil) + +(defvar magit--age-spec) + +;;; Commands + +(define-transient-command magit-margin-settings () + "Change what information is displayed in the margin." + :info-manual "(magit) Log Margin" + ["Margin" + ("L" "Toggle visibility" magit-toggle-margin) + ("l" "Cycle style" magit-cycle-margin-style) + ("d" "Toggle details" magit-toggle-margin-details) + ("v" "Change verbosity" magit-refs-set-show-commit-count + :if-derived magit-refs-mode)]) + +(defun magit-toggle-margin () + "Show or hide the Magit margin." + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + (setcar magit-buffer-margin (not (magit-buffer-margin-p))) + (magit-set-buffer-margin)) + +(defun magit-cycle-margin-style () + "Cycle style used for the Magit margin." + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + ;; This is only suitable for commit margins (there are not others). + (setf (cadr magit-buffer-margin) + (pcase (cadr magit-buffer-margin) + (`age 'age-abbreviated) + (`age-abbreviated + (let ((default (cadr (symbol-value (magit-margin-option))))) + (if (stringp default) default "%Y-%m-%d %H:%M "))) + (_ 'age))) + (magit-set-buffer-margin nil t)) + +(defun magit-toggle-margin-details () + "Show or hide details in the Magit margin." + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + (setf (nth 3 magit-buffer-margin) + (not (nth 3 magit-buffer-margin))) + (magit-set-buffer-margin nil t)) + +;;; Core + +(defun magit-buffer-margin-p () + (car magit-buffer-margin)) + +(defun magit-margin-option () + (pcase major-mode + (`magit-cherry-mode 'magit-cherry-margin) + (`magit-log-mode 'magit-log-margin) + (`magit-log-select-mode 'magit-log-select-margin) + (`magit-reflog-mode 'magit-reflog-margin) + (`magit-refs-mode 'magit-refs-margin) + (`magit-stashes-mode 'magit-stashes-margin) + (`magit-status-mode 'magit-status-margin) + (`forge-notifications-mode 'magit-status-margin))) + +(defun magit-set-buffer-margin (&optional reset refresh) + (when-let ((option (magit-margin-option))) + (let* ((default (symbol-value option)) + (default-width (nth 2 default))) + (when (or reset (not magit-buffer-margin)) + (setq magit-buffer-margin (copy-sequence default))) + (pcase-let ((`(,enable ,style ,_width ,details ,details-width) + magit-buffer-margin)) + (when (functionp default-width) + (setf (nth 2 magit-buffer-margin) + (funcall default-width style details details-width))) + (dolist (window (get-buffer-window-list nil nil 0)) + (with-selected-window window + (magit-set-window-margin window) + (if enable + (add-hook 'window-configuration-change-hook + 'magit-set-window-margin nil t) + (remove-hook 'window-configuration-change-hook + 'magit-set-window-margin t)))) + (when (and enable (or refresh magit-set-buffer-margin-refresh)) + (magit-refresh-buffer)))))) + +(defun magit-set-window-margin (&optional window) + (when (or window (setq window (get-buffer-window))) + (with-selected-window window + (set-window-margins + nil (car (window-margins)) + (and (magit-buffer-margin-p) + (nth 2 magit-buffer-margin)))))) + +(defun magit-make-margin-overlay (&optional string previous-line) + (if previous-line + (save-excursion + (forward-line -1) + (magit-make-margin-overlay string)) + ;; Don't put the overlay on the complete line to work around #1880. + (let ((o (make-overlay (1+ (line-beginning-position)) + (line-end-position) + nil t))) + (overlay-put o 'evaporate t) + (overlay-put o 'before-string + (propertize "o" 'display + (list (list 'margin 'right-margin) + (or string " "))))))) + +(defun magit-maybe-make-margin-overlay () + (when (or (magit-section-match + '(unpulled unpushed recent stashes local cherries) + magit-insert-section--current) + (and (eq major-mode 'magit-refs-mode) + (magit-section-match + '(remote commit tags) + magit-insert-section--current))) + (magit-make-margin-overlay nil t))) + +;;; Custom Support + +(defun magit-margin-set-variable (mode symbol value) + (set-default symbol value) + (message "Updating margins in %s buffers..." mode) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (eq major-mode mode) + (magit-set-buffer-margin t) + (magit-refresh)))) + (message "Updating margins in %s buffers...done" mode)) + +(defconst magit-log-margin--custom-type + '(list (boolean :tag "Show margin initially") + (choice :tag "Show committer" + (string :tag "date using time-format" "%Y-%m-%d %H:%M ") + (const :tag "date's age" age) + (const :tag "date's age (abbreviated)" age-abbreviated)) + (const :tag "Calculate width using magit-log-margin-width" + magit-log-margin-width) + (boolean :tag "Show author name by default") + (integer :tag "Show author name using width"))) + +;;; Time Utilities + +(defvar magit--age-spec + `((?Y "year" "years" ,(round (* 60 60 24 365.2425))) + (?M "month" "months" ,(round (* 60 60 24 30.436875))) + (?w "week" "weeks" ,(* 60 60 24 7)) + (?d "day" "days" ,(* 60 60 24)) + (?h "hour" "hours" ,(* 60 60)) + (?m "minute" "minutes" 60) + (?s "second" "seconds" 1)) + "Time units used when formatting relative commit ages. + +The value is a list of time units, beginning with the longest. +Each element has the form (CHAR UNIT UNITS SECONDS). UNIT is the +time unit, UNITS is the plural of that unit. CHAR is a character +abbreviation. And SECONDS is the number of seconds in one UNIT. + +This is defined as a variable to make it possible to use time +units for a language other than English. It is not defined +as an option, because most other parts of Magit are always in +English.") + +(defun magit--age (date &optional abbreviate) + (cl-labels ((fn (age spec) + (pcase-let ((`(,char ,unit ,units ,weight) (car spec))) + (let ((cnt (round (/ age weight 1.0)))) + (if (or (not (cdr spec)) + (>= (/ age weight) 1)) + (list cnt (cond (abbreviate char) + ((= cnt 1) unit) + (t units))) + (fn age (cdr spec))))))) + (fn (abs (- (float-time) + (if (stringp date) + (string-to-number date) + date))) + magit--age-spec))) + +;;; _ +(provide 'magit-margin) +;;; magit-margin.el ends here diff --git a/elpa/magit-20200318.1224/magit-margin.elc b/elpa/magit-20200318.1224/magit-margin.elc new file mode 100644 index 00000000..f6ed55f6 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-margin.elc differ diff --git a/elpa/magit-20200318.1224/magit-merge.el b/elpa/magit-20200318.1224/magit-merge.el new file mode 100644 index 00000000..839414b5 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-merge.el @@ -0,0 +1,302 @@ +;;; magit-merge.el --- merge functionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements merge commands. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) +(require 'magit-diff) + +(declare-function magit-git-push "magit-push" (branch target args)) + +;;; Commands + +;;;###autoload (autoload 'magit-merge "magit" nil t) +(define-transient-command magit-merge () + "Merge branches." + :man-page "git-merge" + :incompatible '(("--ff-only" "--no-ff")) + ["Arguments" + :if-not magit-merge-in-progress-p + ("-f" "Fast-forward only" "--ff-only") + ("-n" "No fast-forward" "--no-ff") + (magit-merge:--strategy) + (5 magit-diff:--diff-algorithm :argument "--Xdiff-algorithm=") + (5 magit:--gpg-sign)] + ["Actions" + :if-not magit-merge-in-progress-p + [("m" "Merge" magit-merge-plain) + ("e" "Merge and edit message" magit-merge-editmsg) + ("n" "Merge but don't commit" magit-merge-nocommit) + ("a" "Absorb" magit-merge-absorb)] + [("p" "Preview merge" magit-merge-preview) + "" + ("s" "Squash merge" magit-merge-squash) + ("i" "Merge into" magit-merge-into)]] + ["Actions" + :if magit-merge-in-progress-p + ("m" "Commit merge" magit-commit-create) + ("a" "Abort merge" magit-merge-abort)]) + +(defun magit-merge-arguments () + (transient-args 'magit-merge)) + +(define-infix-argument magit-merge:--strategy () + :description "Strategy" + :class 'transient-option + ;; key for merge and rebase: "-s" + ;; key for cherry-pick and revert: "=s" + ;; shortarg for merge and rebase: "-s" + ;; shortarg for cherry-pick and revert: none + :key "-s" + :argument "--strategy=" + :choices '("resolve" "recursive" "octopus" "ours" "subtree")) + +;;;###autoload +(defun magit-merge-plain (rev &optional args nocommit) + "Merge commit REV into the current branch; using default message. + +Unless there are conflicts or a prefix argument is used create a +merge commit using a generic commit message and without letting +the user inspect the result. With a prefix argument pretend the +merge failed to give the user the opportunity to inspect the +merge. + +\(git merge --no-edit|--no-commit [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments) + current-prefix-arg)) + (magit-merge-assert) + (magit-run-git-async "merge" (if nocommit "--no-commit" "--no-edit") args rev)) + +;;;###autoload +(defun magit-merge-editmsg (rev &optional args) + "Merge commit REV into the current branch; and edit message. +Perform the merge and prepare a commit message but let the user +edit it. +\n(git merge --edit --no-ff [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments))) + (magit-merge-assert) + (cl-pushnew "--no-ff" args :test #'equal) + (apply #'magit-run-git-with-editor "merge" "--edit" + (append (delete "--ff-only" args) + (list rev)))) + +;;;###autoload +(defun magit-merge-nocommit (rev &optional args) + "Merge commit REV into the current branch; pretending it failed. +Pretend the merge failed to give the user the opportunity to +inspect the merge and change the commit message. +\n(git merge --no-commit --no-ff [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments))) + (magit-merge-assert) + (cl-pushnew "--no-ff" args :test #'equal) + (magit-run-git-async "merge" "--no-commit" args rev)) + +;;;###autoload +(defun magit-merge-into (branch &optional args) + "Merge the current branch into BRANCH and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +branch, then also remove the respective remote branch." + (interactive + (list (magit-read-other-local-branch + (format "Merge `%s' into" (magit-get-current-branch)) + nil + (when-let ((upstream (magit-get-upstream-branch)) + (upstream (cdr (magit-split-branch-name upstream)))) + (and (magit-branch-p upstream) upstream))) + (magit-merge-arguments))) + (let ((current (magit-get-current-branch))) + (when (zerop (magit-call-git "checkout" branch)) + (magit--merge-absorb current args)))) + +;;;###autoload +(defun magit-merge-absorb (branch &optional args) + "Merge BRANCH into the current branch and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch." + (interactive (list (magit-read-other-local-branch "Absorb branch") + (magit-merge-arguments))) + (magit--merge-absorb branch args)) + +(defun magit--merge-absorb (branch args) + (when (equal branch "master") + (unless (yes-or-no-p + "Do you really want to merge `master' into another branch? ") + (user-error "Abort"))) + (if-let ((target (magit-get-push-branch branch t))) + (progn + (magit-git-push branch target (list "--force-with-lease")) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (not (zerop (process-exit-status process))) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit--merge-absorb-1 branch args)))))) + (magit--merge-absorb-1 branch args))) + +(defun magit--merge-absorb-1 (branch args) + (if-let ((pr (magit-get "branch" branch "pullRequest"))) + (magit-run-git-async + "merge" args "-m" + (format "Merge branch '%s'%s [%s]" + branch + (let ((current (magit-get-current-branch))) + (if (equal current "master") "" (format " into %s" current))) + pr) + branch) + (magit-run-git-async "merge" args "--no-edit" branch)) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-branch-maybe-delete-pr-remote branch) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" "-D" branch)))))) + +;;;###autoload +(defun magit-merge-squash (rev) + "Squash commit REV into the current branch; don't create a commit. +\n(git merge --squash REV)" + (interactive (list (magit-read-other-branch-or-commit "Squash"))) + (magit-merge-assert) + (magit-run-git-async "merge" "--squash" rev)) + +;;;###autoload +(defun magit-merge-preview (rev) + "Preview result of merging REV into the current branch." + (interactive (list (magit-read-other-branch-or-commit "Preview merge"))) + (magit-merge-preview-setup-buffer rev)) + +;;;###autoload +(defun magit-merge-abort () + "Abort the current merge operation. +\n(git merge --abort)" + (interactive) + (unless (file-exists-p (magit-git-dir "MERGE_HEAD")) + (user-error "No merge in progress")) + (magit-confirm 'abort-merge) + (magit-run-git-async "merge" "--abort")) + +(defun magit-checkout-stage (file arg) + "During a conflict checkout and stage side, or restore conflict." + (interactive + (let ((file (magit-completing-read "Checkout file" + (magit-tracked-files) nil nil nil + 'magit-read-file-hist + (magit-current-file)))) + (cond ((member file (magit-unmerged-files)) + (list file (magit-checkout-read-stage file))) + ((yes-or-no-p (format "Restore conflicts in %s? " file)) + (list file "--merge")) + (t + (user-error "Quit"))))) + (pcase (cons arg (cddr (car (magit-file-status file)))) + ((or `("--ours" ?D ,_) + `("--theirs" ,_ ?D)) + (magit-run-git "rm" "--" file)) + (_ (if (equal arg "--merge") + ;; This fails if the file was deleted on one + ;; side. And we cannot do anything about it. + (magit-run-git "checkout" "--merge" "--" file) + (magit-call-git "checkout" arg "--" file) + (magit-run-git "add" "-u" "--" file))))) + +;;; Utilities + +(defun magit-merge-in-progress-p () + (file-exists-p (magit-git-dir "MERGE_HEAD"))) + +(defun magit--merge-range (&optional head) + (unless head + (setq head (magit-get-shortname + (car (magit-file-lines (magit-git-dir "MERGE_HEAD")))))) + (and head + (concat (magit-git-string "merge-base" "--octopus" "HEAD" head) + ".." head))) + +(defun magit-merge-assert () + (or (not (magit-anything-modified-p t)) + (magit-confirm 'merge-dirty + "Merging with dirty worktree is risky. Continue"))) + +(defun magit-checkout-read-stage (file) + (magit-read-char-case (format "For %s checkout: " file) t + (?o "[o]ur stage" "--ours") + (?t "[t]heir stage" "--theirs") + (?c "[c]onflict" "--merge"))) + +;;; Sections + +(defvar magit-unmerged-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-diff-dwim) + map) + "Keymap for `unmerged' sections.") + +(defun magit-insert-merge-log () + "Insert section for the on-going merge. +Display the heads that are being merged. +If no merge is in progress, do nothing." + (when (magit-merge-in-progress-p) + (let* ((heads (mapcar #'magit-get-shortname + (magit-file-lines (magit-git-dir "MERGE_HEAD")))) + (range (magit--merge-range (car heads)))) + (magit-insert-section (unmerged range) + (magit-insert-heading + (format "Merging %s:" (mapconcat #'identity heads ", "))) + (magit-insert-log + range + (let ((args magit-buffer-log-args)) + (unless (member "--decorate=full" magit-buffer-log-args) + (push "--decorate=full" args)) + args)))))) + +;;; _ +(provide 'magit-merge) +;;; magit-merge.el ends here diff --git a/elpa/magit-20200318.1224/magit-merge.elc b/elpa/magit-20200318.1224/magit-merge.elc new file mode 100644 index 00000000..b2dcb3d4 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-merge.elc differ diff --git a/elpa/magit-20200318.1224/magit-mode.el b/elpa/magit-20200318.1224/magit-mode.el new file mode 100644 index 00000000..6a3804d4 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-mode.el @@ -0,0 +1,1431 @@ +;;; magit-mode.el --- create and refresh Magit buffers -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements the abstract major-mode `magit-mode' from +;; which almost all other Magit major-modes derive. The code in here +;; is mostly concerned with creating and refreshing Magit buffers. + +;;; Code: + +(require 'cl-lib) +(require 'dash) + +(eval-when-compile + (require 'subr-x)) + +(require 'transient) + +(require 'magit-section) +(require 'magit-git) + +;; For `magit-display-buffer-fullcolumn-most-v1' from `git-commit' +(defvar git-commit-mode) +;; For `magit-refresh' +(defvar magit-post-commit-hook-commands) +(defvar magit-post-stage-hook-commands) +(defvar magit-post-unstage-hook-commands) +;; For `magit-refresh' and `magit-refresh-all' +(declare-function magit-auto-revert-buffers "magit-autorevert" ()) +;; For `magit-refresh-buffer' +(declare-function magit-process-unset-mode-line-error-status "magit-process" ()) +;; For `magit-refresh-get-relative-position' +(declare-function magit-hunk-section-p "magit-diff" (obj)) +;; For `magit-mode-setup-internal' +(declare-function magit-status-goto-initial-section "magit-status" ()) +;; For `magit-mode' from `bookmark' +(defvar bookmark-make-record-function) + +(require 'format-spec) +(require 'help-mode) + +;;; Options + +(defcustom magit-mode-hook + '(magit-load-config-extensions) + "Hook run when entering a mode derived from Magit mode." + :package-version '(magit . "3.0.0") + :group 'magit-modes + :type 'hook + :options '(magit-load-config-extensions + bug-reference-mode)) + +(defcustom magit-setup-buffer-hook + '(magit-maybe-save-repository-buffers + magit-set-buffer-margin) + "Hook run by `magit-setup-buffer'. + +This is run right after displaying the buffer and right before +generating or updating its content. `magit-mode-hook' and other, +more specific, `magit-mode-*-hook's on the other hand are run +right before displaying the buffer. Usually one of these hooks +should be used instead of this one." + :package-version '(magit . "2.3.0") + :group 'magit-modes + :type 'hook + :options '(magit-maybe-save-repository-buffers + magit-set-buffer-margin)) + +(defcustom magit-pre-refresh-hook '(magit-maybe-save-repository-buffers) + "Hook run before refreshing in `magit-refresh'. + +This hook, or `magit-post-refresh-hook', should be used +for functions that are not tied to a particular buffer. + +To run a function with a particular buffer current, use +`magit-refresh-buffer-hook' and use `derived-mode-p' +inside your function." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :type 'hook + :options '(magit-maybe-save-repository-buffers)) + +(defcustom magit-post-refresh-hook nil + "Hook run after refreshing in `magit-refresh'. + +This hook, or `magit-pre-refresh-hook', should be used +for functions that are not tied to a particular buffer. + +To run a function with a particular buffer current, use +`magit-refresh-buffer-hook' and use `derived-mode-p' +inside your function." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-display-buffer-function 'magit-display-buffer-traditional + "The function used display a Magit buffer. + +All Magit buffers (buffers whose major-modes derive from +`magit-mode') are displayed using `magit-display-buffer', +which in turn uses the function specified here." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type '(radio (function-item magit-display-buffer-traditional) + (function-item magit-display-buffer-same-window-except-diff-v1) + (function-item magit-display-buffer-fullframe-status-v1) + (function-item magit-display-buffer-fullframe-status-topleft-v1) + (function-item magit-display-buffer-fullcolumn-most-v1) + (function-item display-buffer) + (function :tag "Function"))) + +(defcustom magit-pre-display-buffer-hook '(magit-save-window-configuration) + "Hook run by `magit-display-buffer' before displaying the buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'hook + :get 'magit-hook-custom-get + :options '(magit-save-window-configuration)) + +(defcustom magit-post-display-buffer-hook '(magit-maybe-set-dedicated) + "Hook run by `magit-display-buffer' after displaying the buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'hook + :get 'magit-hook-custom-get + :options '(magit-maybe-set-dedicated)) + +(defcustom magit-generate-buffer-name-function + 'magit-generate-buffer-name-default-function + "The function used to generate the name for a Magit buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type '(radio (function-item magit-generate-buffer-name-default-function) + (function :tag "Function"))) + +(defcustom magit-buffer-name-format "%x%M%v: %t%x" + "The format string used to name Magit buffers. + +The following %-sequences are supported: + +`%m' The name of the major-mode, but with the `-mode' suffix + removed. + +`%M' Like \"%m\" but abbreviate `magit-status-mode' as `magit'. + +`%v' The value the buffer is locked to, in parentheses, or an + empty string if the buffer is not locked to a value. + +`%V' Like \"%v\", but the string is prefixed with a space, unless + it is an empty string. + +`%t' The top-level directory of the working tree of the + repository, or if `magit-uniquify-buffer-names' is non-nil + an abbreviation of that. + +`%x' If `magit-uniquify-buffer-names' is nil \"*\", otherwise the + empty string. Due to limitations of the `uniquify' package, + buffer names must end with the path. + +`%T' Obsolete, use \"%t%x\" instead. Like \"%t\", but append an + asterisk if and only if `magit-uniquify-buffer-names' is nil. + +The value should always contain \"%m\" or \"%M\", \"%v\" or +\"%V\", and \"%t\" (or the obsolete \"%T\"). + +If `magit-uniquify-buffer-names' is non-nil, then the value must +end with \"%t\" or \"%t%x\" (or the obsolete \"%T\"). See issue +#2841. + +This is used by `magit-generate-buffer-name-default-function'. +If another `magit-generate-buffer-name-function' is used, then +it may not respect this option, or on the contrary it may +support additional %-sequences." + :package-version '(magit . "2.12.0") + :group 'magit-buffers + :type 'string) + +(defcustom magit-uniquify-buffer-names t + "Whether to uniquify the names of Magit buffers." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'boolean) + +(defcustom magit-bury-buffer-function 'magit-restore-window-configuration + "The function used to bury or kill the current Magit buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type '(radio (function-item quit-window) + (function-item magit-mode-quit-window) + (function-item magit-restore-window-configuration) + (function :tag "Function"))) + +(defcustom magit-prefix-use-buffer-arguments 'selected + "Whether certain prefix commands reuse arguments active in relevant buffer. + +This affects the transient prefix commands `magit-diff', +`magit-log' and `magit-show-refs'. + +Valid values are: + +`always': Always use the set of arguments that is currently + active in the respective buffer, provided that buffer exists + of course. +`selected': Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default. +`current': Use the set of arguments from the respective buffer, + but only if it is the current buffer. +`never': Never use the set of arguments from the respective + buffer. + +For more information see info node `(magit)Transient Arguments +and Buffer Arguments'." + :package-version '(magit . "3.0.0") + :group 'magit-buffers + :group 'magit-commands + :type '(choice + (const :tag "always use args from buffer" always) + (const :tag "use args from buffer if displayed in frame" selected) + (const :tag "use args from buffer if it is current" current) + (const :tag "never use args from buffer" never))) + +(defcustom magit-direct-use-buffer-arguments 'selected + "Whether certain commands reuse arguments active in relevant buffer. + +This affects certain commands such as `magit-show-commit' that +are suffixes of the diff or log transient prefix commands, but +only if they are invoked directly, i.e. *not* as a suffix. + +Valid values are: + +`always': Always use the set of arguments that is currently + active in the respective buffer, provided that buffer exists + of course. +`selected': Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default. +`current': Use the set of arguments from the respective buffer, + but only if it is the current buffer. +`never': Never use the set of arguments from the respective + buffer. + +For more information see info node `(magit)Transient Arguments +and Buffer Arguments'." + :package-version '(magit . "3.0.0") + :group 'magit-buffers + :group 'magit-commands + :type '(choice + (const :tag "always use args from buffer" always) + (const :tag "use args from buffer if displayed in frame" selected) + (const :tag "use args from buffer if it is current" current) + (const :tag "never use args from buffer" never))) + +(defcustom magit-region-highlight-hook '(magit-diff-update-hunk-region) + "Functions used to highlight the region. + +Each function is run with the current section as only argument +until one of them returns non-nil. If all functions return nil, +then fall back to regular region highlighting." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'hook + :options '(magit-diff-update-hunk-region)) + +(defcustom magit-create-buffer-hook nil + "Normal hook run after creating a new `magit-mode' buffer." + :package-version '(magit . "2.90.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-refresh-buffer-hook nil + "Normal hook for `magit-refresh-buffer' to run after refreshing." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-refresh-status-buffer t + "Whether the status buffer is refreshed after running git. + +When this is non-nil, then the status buffer is automatically +refreshed after running git for side-effects, in addition to the +current Magit buffer, which is always refreshed automatically. + +Only set this to nil after exhausting all other options to +improve performance." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :group 'magit-status + :type 'boolean) + +(defcustom magit-refresh-verbose nil + "Whether to revert Magit buffers verbosely." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'boolean) + +(defcustom magit-save-repository-buffers t + "Whether to save file-visiting buffers when appropriate. + +If non-nil, then all modified file-visiting buffers belonging +to the current repository may be saved before running Magit +commands and before creating or refreshing Magit buffers. +If `dontask', then this is done without user intervention, for +any other non-nil value the user has to confirm each save. + +The default is t to avoid surprises, but `dontask' is the +recommended value." + :group 'magit-essentials + :group 'magit-buffers + :type '(choice (const :tag "Never" nil) + (const :tag "Ask" t) + (const :tag "Save without asking" dontask))) + +;;; Key Bindings + +(defvar magit-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-section-mode-map) + (define-key map [C-return] 'magit-visit-thing) + (define-key map (kbd "C-m") 'magit-visit-thing) + (define-key map (kbd "C-M-i") 'magit-dired-jump) + (define-key map [M-tab] 'magit-section-cycle-diffs) + (define-key map (kbd "P") 'magit-push) + (define-key map (kbd "k") 'magit-delete-thing) + (define-key map (kbd "K") 'magit-file-untrack) + (define-key map (kbd "i") 'magit-gitignore) + (define-key map (kbd "I") 'magit-gitignore) + (define-key map (kbd "SPC") 'magit-diff-show-or-scroll-up) + (define-key map (kbd "DEL") 'magit-diff-show-or-scroll-down) + (define-key map "+" 'magit-diff-more-context) + (define-key map "-" 'magit-diff-less-context) + (define-key map "0" 'magit-diff-default-context) + (define-key map "$" 'magit-process-buffer) + (define-key map "%" 'magit-worktree) + (define-key map "a" 'magit-cherry-apply) + (define-key map "A" 'magit-cherry-pick) + (define-key map "b" 'magit-branch) + (define-key map "B" 'magit-bisect) + (define-key map "c" 'magit-commit) + (define-key map "C" 'magit-clone) + (define-key map "d" 'magit-diff) + (define-key map "D" 'magit-diff-refresh) + (define-key map "e" 'magit-ediff-dwim) + (define-key map "E" 'magit-ediff) + (define-key map "f" 'magit-fetch) + (define-key map "F" 'magit-pull) + (define-key map "g" 'magit-refresh) + (define-key map "G" 'magit-refresh-all) + (define-key map "h" 'magit-dispatch) + (define-key map "?" 'magit-dispatch) + (define-key map "l" 'magit-log) + (define-key map "L" 'magit-log-refresh) + (define-key map "m" 'magit-merge) + (define-key map "M" 'magit-remote) + (define-key map "o" 'magit-submodule) + (define-key map "O" 'magit-subtree) + (define-key map "q" 'magit-mode-bury-buffer) + (define-key map "r" 'magit-rebase) + (define-key map "R" 'magit-file-rename) + (define-key map "s" 'magit-stage-file) + (define-key map "S" 'magit-stage-modified) + (define-key map "t" 'magit-tag) + (define-key map "T" 'magit-notes) + (define-key map "u" 'magit-unstage-file) + (define-key map "U" 'magit-unstage-all) + (define-key map "v" 'magit-revert-no-commit) + (define-key map "V" 'magit-revert) + (define-key map "w" 'magit-am) + (define-key map "W" 'magit-patch) + (define-key map "x" 'magit-reset-quickly) + (define-key map "X" 'magit-reset) + (define-key map "y" 'magit-show-refs) + (define-key map "Y" 'magit-cherry) + (define-key map "z" 'magit-stash) + (define-key map "Z" 'magit-stash) + (define-key map ":" 'magit-git-command) + (define-key map "!" 'magit-run) + (define-key map (kbd "C-c C-c") 'magit-dispatch) + (define-key map (kbd "C-c C-e") 'magit-edit-thing) + (define-key map (kbd "C-c C-o") 'magit-browse-thing) + (define-key map (kbd "C-c C-w") 'magit-browse-thing) + (define-key map (kbd "C-x a") 'magit-add-change-log-entry) + (define-key map (kbd "C-x 4 a") 'magit-add-change-log-entry-other-window) + (define-key map (kbd "C-w") 'magit-copy-section-value) + (define-key map (kbd "M-w") 'magit-copy-buffer-revision) + (define-key map [remap previous-line] 'magit-previous-line) + (define-key map [remap next-line] 'magit-next-line) + (define-key map [remap evil-previous-line] 'evil-previous-visual-line) + (define-key map [remap evil-next-line] 'evil-next-visual-line) + map) + "Parent keymap for all keymaps of modes derived from `magit-mode'.") + +(defun magit-delete-thing () + "This is a placeholder command. +Where applicable, section-specific keymaps bind another command +which deletes the thing at point." + (interactive) + (user-error "There is no thing at point that could be deleted")) + +(defun magit-visit-thing () + "This is a placeholder command. +Where applicable, section-specific keymaps bind another command +which visits the thing at point." + (interactive) + (if (eq current-transient-command 'magit-dispatch) + (call-interactively (key-binding (this-command-keys))) + (user-error "There is no thing at point that could be visited"))) + +(defun magit-edit-thing () + "This is a placeholder command. +Where applicable, section-specific keymaps bind another command +which lets you edit the thing at point, likely in another buffer." + (interactive) + (if (eq current-transient-command 'magit-dispatch) + (call-interactively (key-binding (this-command-keys))) + (user-error "There is no thing at point that could be edited"))) + +(defun magit-browse-thing () + "This is a placeholder command. +Where applicable, section-specific keymaps bind another command +which visits the thing at point using `browse-url'." + (interactive) + (user-error "There is no thing at point that could be browsed")) + +(defvar bug-reference-map) +(with-eval-after-load 'bug-reference + (define-key bug-reference-map [remap magit-visit-thing] + 'bug-reference-push-button)) + +(easy-menu-define magit-mode-menu magit-mode-map + "Magit menu" + '("Magit" + ["Refresh" magit-refresh t] + ["Refresh all" magit-refresh-all t] + "---" + ["Stage" magit-stage t] + ["Stage modified" magit-stage-modified t] + ["Unstage" magit-unstage t] + ["Reset index" magit-reset-index t] + ["Commit" magit-commit t] + ["Add log entry" magit-commit-add-log t] + ["Tag" magit-tag-create t] + "---" + ["Diff working tree" magit-diff-working-tree t] + ["Diff" magit-diff t] + ("Log" + ["Log" magit-log-other t] + ["Reflog" magit-reflog-other t] + ["Extended..." magit-log t]) + "---" + ["Cherry pick" magit-cherry-pick t] + ["Revert commit" magit-revert t] + "---" + ["Ignore globally" magit-gitignore-globally t] + ["Ignore locally" magit-gitignore-locally t] + ["Discard" magit-discard t] + ["Reset head and index" magit-reset-mixed t] + ["Stash" magit-stash-both t] + ["Snapshot" magit-snapshot-both t] + "---" + ["Branch..." magit-checkout t] + ["Merge" magit-merge t] + ["Ediff resolve" magit-ediff-resolve t] + ["Rebase..." magit-rebase t] + "---" + ["Push" magit-push t] + ["Pull" magit-pull-branch t] + ["Remote update" magit-fetch-all t] + ("Submodule" + ["Submodule update" magit-submodule-update t] + ["Submodule update and init" magit-submodule-setup t] + ["Submodule init" magit-submodule-init t] + ["Submodule sync" magit-submodule-sync t]) + "---" + ("Extensions") + "---" + ["Display Git output" magit-process-buffer t] + ["Quit Magit" magit-mode-bury-buffer t])) + +;;; Mode + +(defun magit-load-config-extensions () + "Load Magit extensions that are defined at the Git config layer." + (dolist (ext (magit-get-all "magit.extension")) + (let ((sym (intern (format "magit-%s-mode" ext)))) + (when (fboundp sym) + (funcall sym 1))))) + +(define-derived-mode magit-mode magit-section-mode "Magit" + "Parent major mode from which Magit major modes inherit. + +Magit is documented in info node `(magit)'." + :group 'magit + (hack-dir-local-variables-non-file-buffer) + (setq mode-line-process (magit-repository-local-get 'mode-line-process)) + (setq-local bookmark-make-record-function 'magit--make-bookmark)) + +;;; Highlighting + +;;; Local Variables + +(defvar-local magit-buffer-arguments nil) +(defvar-local magit-buffer-diff-args nil) +(defvar-local magit-buffer-diff-files nil) +(defvar-local magit-buffer-diff-files-suspended nil) +(defvar-local magit-buffer-file-name nil) +(defvar-local magit-buffer-files nil) +(defvar-local magit-buffer-log-args nil) +(defvar-local magit-buffer-log-files nil) +(defvar-local magit-buffer-range nil) +(defvar-local magit-buffer-range-hashed nil) +(defvar-local magit-buffer-refname nil) +(defvar-local magit-buffer-revision nil) +(defvar-local magit-buffer-revision-hash nil) +(defvar-local magit-buffer-revisions nil) +(defvar-local magit-buffer-typearg nil) +(defvar-local magit-buffer-upstream nil) + +;; These variables are also used in file-visiting buffers. +;; Because the user may change the major-mode, they have +;; to be permanent buffer-local. +(put 'magit-buffer-file-name 'permanent-local t) +(put 'magit-buffer-refname 'permanent-local t) +(put 'magit-buffer-revision 'permanent-local t) +(put 'magit-buffer-revision-hash 'permanent-local t) + +;; `magit-status' re-enables mode function but its refresher +;; function does not reinstate this. +(put 'magit-buffer-diff-files-suspended 'permanent-local t) + +(defvar-local magit-refresh-args nil + "Obsolete. Possibly the arguments used to refresh the current buffer. +Some third-party packages might still use this, but Magit does not.") +(put 'magit-refresh-args 'permanent-local t) +(make-obsolete-variable 'magit-refresh-args nil "Magit 3.0.0") + +(defvar magit-buffer-lock-functions nil + "Obsolete buffer-locking support for third-party modes. +Implement the generic function `magit-buffer-value' for +your mode instead of adding an entry to this variable.") +(make-obsolete-variable 'magit-buffer-lock-functions nil "Magit 3.0.0") + +(cl-defgeneric magit-buffer-value () + (when-let ((fn (cdr (assq major-mode magit-buffer-lock-functions)))) + (funcall fn (with-no-warnings magit-refresh-args)))) + +(defvar-local magit-previous-section nil) +(put 'magit-previous-section 'permanent-local t) + +;;; Setup Buffer + +(defmacro magit-setup-buffer (mode &optional locked &rest bindings) + (declare (indent 2)) + `(magit-setup-buffer-internal + ,mode ,locked + ,(cons 'list (mapcar (pcase-lambda (`(,var ,form)) + `(list ',var ,form)) + bindings)))) + +(defun magit-setup-buffer-internal (mode locked bindings) + (let* ((value (and locked + (with-temp-buffer + (pcase-dolist (`(,var ,val) bindings) + (set (make-local-variable var) val)) + (let ((major-mode mode)) + (magit-buffer-value))))) + (buffer (magit-get-mode-buffer mode value)) + (section (and buffer (magit-current-section))) + (created (not buffer))) + (unless buffer + (setq buffer (magit-with-toplevel + (magit-generate-new-buffer mode value)))) + (with-current-buffer buffer + (setq magit-previous-section section) + (funcall mode) + (magit-xref-setup 'magit-setup-buffer-internal bindings) + (pcase-dolist (`(,var ,val) bindings) + (set (make-local-variable var) val)) + (when created + (magit-status-goto-initial-section) + (run-hooks 'magit-create-buffer-hook))) + (magit-display-buffer buffer) + (with-current-buffer buffer + (run-hooks 'magit-setup-buffer-hook) + (magit-refresh-buffer)) + buffer)) + +(defun magit-mode-setup (mode &rest args) + "Setup up a MODE buffer using ARGS to generate its content." + (declare (obsolete magit-setup-buffer "Magit 3.0.0")) + (with-no-warnings + (magit-mode-setup-internal mode args))) + +(defun magit-mode-setup-internal (mode args &optional locked) + "Setup up a MODE buffer using ARGS to generate its content. +When optional LOCKED is non-nil, then create a buffer that is +locked to its value, which is derived from MODE and ARGS." + (declare (obsolete magit-setup-buffer "Magit 3.0.0")) + (let* ((value (and locked + (with-temp-buffer + (with-no-warnings + (setq magit-refresh-args args)) + (let ((major-mode mode)) + (magit-buffer-value))))) + (buffer (magit-get-mode-buffer mode value)) + (section (and buffer (magit-current-section))) + (created (not buffer))) + (unless buffer + (setq buffer (magit-with-toplevel + (magit-generate-new-buffer mode value)))) + (with-current-buffer buffer + (setq magit-previous-section section) + (with-no-warnings + (setq magit-refresh-args args)) + (funcall mode) + (magit-xref-setup 'magit-mode-setup-internal args) + (when created + (magit-status-goto-initial-section) + (run-hooks 'magit-create-buffer-hook))) + (magit-display-buffer buffer) + (with-current-buffer buffer + (run-hooks 'magit-mode-setup-hook) + (magit-refresh-buffer)))) + +;;; Display Buffer + +(defvar magit-display-buffer-noselect nil + "If non-nil, then `magit-display-buffer' doesn't call `select-window'.") + +(defun magit-display-buffer (buffer &optional display-function) + "Display BUFFER in some window and maybe select it. + +If optional DISPLAY-FUNCTION is non-nil, then use that to display +the buffer. Otherwise use `magit-display-buffer-function', which +is the normal case. + +Then, unless `magit-display-buffer-noselect' is non-nil, select +the window which was used to display the buffer. + +Also run the hooks `magit-pre-display-buffer-hook' +and `magit-post-display-buffer-hook'." + (with-current-buffer buffer + (run-hooks 'magit-pre-display-buffer-hook)) + (let ((window (funcall (or display-function magit-display-buffer-function) + buffer))) + (unless magit-display-buffer-noselect + (let* ((old-frame (selected-frame)) + (new-frame (window-frame window))) + (select-window window) + (unless (eq old-frame new-frame) + (select-frame-set-input-focus new-frame))))) + (with-current-buffer buffer + (run-hooks 'magit-post-display-buffer-hook))) + +(defun magit-display-buffer-traditional (buffer) + "Display BUFFER the way this has traditionally been done." + (display-buffer + buffer (if (and (derived-mode-p 'magit-mode) + (not (memq (with-current-buffer buffer major-mode) + '(magit-process-mode + magit-revision-mode + magit-diff-mode + magit-stash-mode + magit-status-mode)))) + '(display-buffer-same-window) + nil))) ; display in another window + +(defun magit-display-buffer-same-window-except-diff-v1 (buffer) + "Display BUFFER in the selected window except for some modes. +If a buffer's `major-mode' derives from `magit-diff-mode' or +`magit-process-mode', display it in another window. Display all +other buffers in the selected window." + (display-buffer + buffer (if (with-current-buffer buffer + (derived-mode-p 'magit-diff-mode 'magit-process-mode)) + nil ; display in another window + '(display-buffer-same-window)))) + +(defun magit--display-buffer-fullframe (buffer alist) + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) + (delete-other-windows window) + window)) + +(defun magit-display-buffer-fullframe-status-v1 (buffer) + "Display BUFFER, filling entire frame if BUFFER is a status buffer. +Otherwise, behave like `magit-display-buffer-traditional'." + (if (eq (with-current-buffer buffer major-mode) + 'magit-status-mode) + (display-buffer buffer '(magit--display-buffer-fullframe)) + (magit-display-buffer-traditional buffer))) + +(defun magit--display-buffer-topleft (buffer alist) + (or (display-buffer-reuse-window buffer alist) + (when-let ((window2 (display-buffer-pop-up-window buffer alist))) + (let ((window1 (get-buffer-window)) + (buffer1 (current-buffer)) + (buffer2 (window-buffer window2)) + (w2-quit-restore (window-parameter window2 'quit-restore))) + (set-window-buffer window1 buffer2) + (set-window-buffer window2 buffer1) + (select-window window2) + ;; Swap some window state that `magit-mode-quit-window' and + ;; `quit-restore-window' inspect. + (set-window-prev-buffers window2 (cdr (window-prev-buffers window1))) + (set-window-prev-buffers window1 nil) + (set-window-parameter window2 'magit-dedicated + (window-parameter window1 'magit-dedicated)) + (set-window-parameter window1 'magit-dedicated t) + (set-window-parameter window1 'quit-restore + (list 'window 'window + (nth 2 w2-quit-restore) + (nth 3 w2-quit-restore))) + (set-window-parameter window2 'quit-restore nil) + window1)))) + +(defun magit-display-buffer-fullframe-status-topleft-v1 (buffer) + "Display BUFFER, filling entire frame if BUFFER is a status buffer. +When BUFFER derives from `magit-diff-mode' or +`magit-process-mode', try to display BUFFER to the top or left of +the current buffer rather than to the bottom or right, as +`magit-display-buffer-fullframe-status-v1' would. Whether the +split is made vertically or horizontally is determined by +`split-window-preferred-function'." + (display-buffer + buffer + (cond ((eq (with-current-buffer buffer major-mode) + 'magit-status-mode) + '(magit--display-buffer-fullframe)) + ((with-current-buffer buffer + (derived-mode-p 'magit-diff-mode 'magit-process-mode)) + '(magit--display-buffer-topleft)) + (t + '(display-buffer-same-window))))) + +(defun magit--display-buffer-fullcolumn (buffer alist) + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-below-selected buffer alist)))) + (delete-other-windows-vertically window) + window)) + +(defun magit-display-buffer-fullcolumn-most-v1 (buffer) + "Display BUFFER using the full column except in some cases. +For most cases where BUFFER's `major-mode' derives from +`magit-mode', display it in the selected window and grow that +window to the full height of the frame, deleting other windows in +that column as necessary. However, display BUFFER in another +window if 1) BUFFER's mode derives from `magit-process-mode', or +2) BUFFER's mode derives from `magit-diff-mode', provided that +the mode of the current buffer derives from `magit-log-mode' or +`magit-cherry-mode'." + (display-buffer + buffer + (cond ((and (or git-commit-mode + (derived-mode-p 'magit-log-mode + 'magit-cherry-mode + 'magit-reflog-mode)) + (with-current-buffer buffer + (derived-mode-p 'magit-diff-mode))) + nil) + ((with-current-buffer buffer + (derived-mode-p 'magit-process-mode)) + nil) + (t + '(magit--display-buffer-fullcolumn))))) + +(defun magit-maybe-set-dedicated () + "Mark the selected window as dedicated if appropriate. + +If a new window was created to display the buffer, then remember +that fact. That information is used by `magit-mode-quit-window', +to determine whether the window should be deleted when its last +Magit buffer is buried." + (let ((window (get-buffer-window (current-buffer)))) + (when (and (window-live-p window) + (not (window-prev-buffers window))) + (set-window-parameter window 'magit-dedicated t)))) + +;;; Get Buffer + +(defvar-local magit--default-directory nil + "Value of `default-directory' when buffer is generated. +This exists to prevent a let-bound `default-directory' from +tricking `magit-get-mode-buffer' or `magit-mode-get-buffers' +into thinking a buffer belongs to a repo that it doesn't.") +(put 'magit--default-directory 'permanent-local t) + +(defun magit-mode-get-buffers () + (let ((topdir (magit-toplevel))) + (--filter (with-current-buffer it + (and (derived-mode-p 'magit-mode) + (equal magit--default-directory topdir))) + (buffer-list)))) + +(defvar-local magit-buffer-locked-p nil) +(put 'magit-buffer-locked-p 'permanent-local t) + +(defun magit-get-mode-buffer (mode &optional value frame) + "Return buffer belonging to the current repository whose major-mode is MODE. + +If no such buffer exists then return nil. Multiple buffers with +the same major-mode may exist for a repository but only one can +exist that hasn't been looked to its value. Return that buffer +\(or nil if there is no such buffer) unless VALUE is non-nil, in +which case return the buffer that has been looked to that value. + +If FRAME nil or omitted, then consider all buffers. Otherwise + only consider buffers that are displayed in some live window + on some frame. +If `all', then consider all buffers on all frames. +If `visible', then only consider buffers on all visible frames. +If `selected' or t, then only consider buffers on the selected + frame. +If a frame, then only consider buffers on that frame." + (if-let ((topdir (magit-toplevel))) + (cl-flet* ((b (buffer) + (with-current-buffer buffer + (and (eq major-mode mode) + (equal magit--default-directory topdir) + (if value + (and magit-buffer-locked-p + (equal (magit-buffer-value) value)) + (not magit-buffer-locked-p)) + buffer))) + (w (window) + (b (window-buffer window))) + (f (frame) + (-some #'w (window-list frame 'no-minibuf)))) + (pcase-exhaustive frame + (`nil (-some #'b (buffer-list))) + (`all (-some #'f (frame-list))) + (`visible (-some #'f (visible-frame-list))) + ((or `selected `t) (-some #'w (window-list (selected-frame)))) + ((guard (framep frame)) (-some #'w (window-list frame))))) + (magit--not-inside-repository-error))) + +(defun magit-mode-get-buffer (mode &optional create frame value) + (declare (obsolete magit-get-mode-buffer "Magit 3.0.0")) + (when create + (error "`magit-mode-get-buffer's CREATE argument is obsolete")) + (if-let ((topdir (magit-toplevel))) + (--first (with-current-buffer it + (and (eq major-mode mode) + (equal magit--default-directory topdir) + (if value + (and magit-buffer-locked-p + (equal (magit-buffer-value) value)) + (not magit-buffer-locked-p)))) + (if frame + (mapcar #'window-buffer + (window-list (unless (eq frame t) frame))) + (buffer-list))) + (magit--not-inside-repository-error))) + +(defun magit-generate-new-buffer (mode &optional value) + (let* ((name (funcall magit-generate-buffer-name-function mode value)) + (buffer (generate-new-buffer name))) + (with-current-buffer buffer + (setq magit--default-directory default-directory) + (setq magit-buffer-locked-p (and value t)) + (magit-restore-section-visibility-cache mode)) + (when magit-uniquify-buffer-names + (add-to-list 'uniquify-list-buffers-directory-modes mode) + (with-current-buffer buffer + (setq list-buffers-directory (abbreviate-file-name default-directory))) + (let ((uniquify-buffer-name-style + (if (memq uniquify-buffer-name-style '(nil forward)) + 'post-forward-angle-brackets + uniquify-buffer-name-style))) + (uniquify-rationalize-file-buffer-names + name (file-name-directory (directory-file-name default-directory)) + buffer))) + buffer)) + +(defun magit-generate-buffer-name-default-function (mode &optional value) + "Generate buffer name for a MODE buffer in the current repository. +The returned name is based on `magit-buffer-name-format' and +takes `magit-uniquify-buffer-names' and VALUE, if non-nil, into +account." + (let ((m (substring (symbol-name mode) 0 -5)) + (v (and value (format "%s" (if (listp value) value (list value))))) + (n (if magit-uniquify-buffer-names + (file-name-nondirectory + (directory-file-name default-directory)) + (abbreviate-file-name default-directory)))) + (format-spec + magit-buffer-name-format + `((?m . ,m) + (?M . ,(if (eq mode 'magit-status-mode) "magit" m)) + (?v . ,(or v "")) + (?V . ,(if v (concat " " v) "")) + (?t . ,n) + (?x . ,(if magit-uniquify-buffer-names "" "*")) + (?T . ,(if magit-uniquify-buffer-names n (concat n "*"))))))) + +;;; Buffer Lock + +(defun magit-toggle-buffer-lock () + "Lock the current buffer to its value or unlock it. + +Locking a buffer to its value prevents it from being reused to +display another value. The name of a locked buffer contains its +value, which allows telling it apart from other locked buffers +and the unlocked buffer. + +Not all Magit buffers can be locked to their values, for example +it wouldn't make sense to lock a status buffer. + +There can only be a single unlocked buffer using a certain +major-mode per repository. So when a buffer is being unlocked +and another unlocked buffer already exists for that mode and +repository, then the former buffer is instead deleted and the +latter is displayed in its place." + (interactive) + (if magit-buffer-locked-p + (if-let ((unlocked (magit-get-mode-buffer major-mode))) + (let ((locked (current-buffer))) + (switch-to-buffer unlocked nil t) + (kill-buffer locked)) + (setq magit-buffer-locked-p nil) + (rename-buffer (funcall magit-generate-buffer-name-function + major-mode))) + (if-let ((value (magit-buffer-value))) + (if-let ((locked (magit-get-mode-buffer major-mode value))) + (let ((unlocked (current-buffer))) + (switch-to-buffer locked nil t) + (kill-buffer unlocked)) + (setq magit-buffer-locked-p t) + (rename-buffer (funcall magit-generate-buffer-name-function + major-mode value))) + (user-error "Buffer has no value it could be locked to")))) + +;;; Bury Buffer + +(defun magit-mode-bury-buffer (&optional kill-buffer) + "Bury the current buffer. +With a prefix argument, kill the buffer instead. +With two prefix arguments, also kill all Magit buffers associated +with this repository. +This is done using `magit-bury-buffer-function'." + (interactive "P") + ;; Kill all associated Magit buffers when a double prefix arg is given. + (when (>= (prefix-numeric-value kill-buffer) 16) + (let ((current (current-buffer))) + (dolist (buf (magit-mode-get-buffers)) + (unless (eq buf current) + (kill-buffer buf))))) + (funcall magit-bury-buffer-function kill-buffer)) + +(defun magit-mode-quit-window (kill-buffer) + "Quit the selected window and bury its buffer. + +This behaves similar to `quit-window', but when the window +was originally created to display a Magit buffer and the +current buffer is the last remaining Magit buffer that was +ever displayed in the selected window, then delete that +window." + (if (or (one-window-p) + (--first (let ((buffer (car it))) + (and (not (eq buffer (current-buffer))) + (buffer-live-p buffer) + (or (not (window-parameter nil 'magit-dedicated)) + (with-current-buffer buffer + (derived-mode-p 'magit-mode + 'magit-process-mode))))) + (window-prev-buffers))) + (quit-window kill-buffer) + (let ((window (selected-window))) + (quit-window kill-buffer) + (when (window-live-p window) + (delete-window window))))) + +;;; Refresh Buffers + +(defvar inhibit-magit-refresh nil) + +(defun magit-refresh () + "Refresh some buffers belonging to the current repository. + +Refresh the current buffer if its major mode derives from +`magit-mode', and refresh the corresponding status buffer. + +Run hooks `magit-pre-refresh-hook' and `magit-post-refresh-hook'." + (interactive) + (unless inhibit-magit-refresh + (unwind-protect + (let ((start (current-time)) + (magit--refresh-cache (or magit--refresh-cache + (list (cons 0 0))))) + (when magit-refresh-verbose + (message "Refreshing magit...")) + (magit-run-hook-with-benchmark 'magit-pre-refresh-hook) + (cond ((derived-mode-p 'magit-mode) + (magit-refresh-buffer)) + ((derived-mode-p 'tabulated-list-mode) + (revert-buffer))) + (--when-let (and magit-refresh-status-buffer + (not (derived-mode-p 'magit-status-mode)) + (magit-get-mode-buffer 'magit-status-mode)) + (with-current-buffer it + (magit-refresh-buffer))) + (magit-auto-revert-buffers) + (cond + ((and (not this-command) + (memq last-command magit-post-commit-hook-commands)) + (magit-run-hook-with-benchmark 'magit-post-commit-hook)) + ((memq this-command magit-post-stage-hook-commands) + (magit-run-hook-with-benchmark 'magit-post-stage-hook)) + ((memq this-command magit-post-unstage-hook-commands) + (magit-run-hook-with-benchmark 'magit-post-unstage-hook))) + (magit-run-hook-with-benchmark 'magit-post-refresh-hook) + (when magit-refresh-verbose + (message "Refreshing magit...done (%.3fs, cached %s/%s)" + (float-time (time-subtract (current-time) start)) + (caar magit--refresh-cache) + (+ (caar magit--refresh-cache) + (cdar magit--refresh-cache))))) + (run-hooks 'magit-unwind-refresh-hook)))) + +(defun magit-refresh-all () + "Refresh all buffers belonging to the current repository. + +Refresh all Magit buffers belonging to the current repository, +and revert buffers that visit files located inside the current +repository. + +Run hooks `magit-pre-refresh-hook' and `magit-post-refresh-hook'." + (interactive) + (magit-run-hook-with-benchmark 'magit-pre-refresh-hook) + (dolist (buffer (magit-mode-get-buffers)) + (with-current-buffer buffer (magit-refresh-buffer))) + (magit-auto-revert-buffers) + (magit-run-hook-with-benchmark 'magit-post-refresh-hook)) + +(defvar-local magit-refresh-start-time nil) + +(defun magit-refresh-buffer () + "Refresh the current Magit buffer." + (setq magit-refresh-start-time (current-time)) + (let ((refresh (intern (format "%s-refresh-buffer" + (substring (symbol-name major-mode) 0 -5)))) + (magit--refresh-cache (or magit--refresh-cache (list (cons 0 0))))) + (when (functionp refresh) + (when magit-refresh-verbose + (message "Refreshing buffer `%s'..." (buffer-name))) + (let* ((buffer (current-buffer)) + (windows + (--mapcat (with-selected-window it + (with-current-buffer buffer + (when-let ((section (magit-current-section))) + (list + (nconc (list it section) + (magit-refresh-get-relative-position)))))) + (or (get-buffer-window-list buffer nil t) + (list (selected-window)))))) + (deactivate-mark) + (setq magit-section-highlight-overlays nil) + (setq magit-section-highlighted-section nil) + (setq magit-section-highlighted-sections nil) + (setq magit-section-unhighlight-sections nil) + (magit-process-unset-mode-line-error-status) + (let ((inhibit-read-only t)) + (erase-buffer) + (save-excursion + (apply refresh (with-no-warnings magit-refresh-args)))) + (pcase-dolist (`(,window . ,args) windows) + (with-selected-window window + (with-current-buffer buffer + (apply #'magit-section-goto-successor args)))) + (run-hooks 'magit-refresh-buffer-hook) + (magit-section-update-highlight) + (set-buffer-modified-p nil)) + (when magit-refresh-verbose + (message "Refreshing buffer `%s'...done (%.3fs)" (buffer-name) + (float-time (time-subtract (current-time) + magit-refresh-start-time))))))) + +(defun magit-refresh-get-relative-position () + (when-let ((section (magit-current-section))) + (let ((start (oref section start))) + (list (count-lines start (point)) + (- (point) (line-beginning-position)) + (and (magit-hunk-section-p section) + (region-active-p) + (progn (goto-char (line-beginning-position)) + (when (looking-at "^[-+]") (forward-line)) + (while (looking-at "^[ @]") (forward-line)) + (let ((beg (point))) + (cond ((looking-at "^[-+]") + (forward-line) + (while (looking-at "^[-+]") (forward-line)) + (while (looking-at "^ ") (forward-line)) + (forward-line -1) + (regexp-quote (buffer-substring-no-properties + beg (line-end-position)))) + (t t))))))))) + +;;; Save File-Visiting Buffers + +(defvar disable-magit-save-buffers nil) + +(defun magit-pre-command-hook () + (setq disable-magit-save-buffers nil)) +(add-hook 'pre-command-hook #'magit-pre-command-hook) + +(defvar magit-after-save-refresh-buffers nil) + +(defun magit-after-save-refresh-buffers () + (dolist (buffer magit-after-save-refresh-buffers) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (magit-refresh-buffer)))) + (setq magit-after-save-refresh-buffers nil) + (remove-hook 'post-command-hook 'magit-after-save-refresh-buffers)) + +(defun magit-after-save-refresh-status () + "Refresh the status buffer of the current repository. + +This function is intended to be added to `after-save-hook'. + +If the status buffer does not exist or the file being visited in +the current buffer isn't inside the working tree of a repository, +then do nothing. + +Note that refreshing a Magit buffer is done by re-creating its +contents from scratch, which can be slow in large repositories. +If you are not satisfied with Magit's performance, then you +should obviously not add this function to that hook." + (when (and (not disable-magit-save-buffers) + (magit-inside-worktree-p t)) + (--when-let (ignore-errors (magit-get-mode-buffer 'magit-status-mode)) + (add-to-list 'magit-after-save-refresh-buffers it) + (add-hook 'post-command-hook 'magit-after-save-refresh-buffers)))) + +(defun magit-maybe-save-repository-buffers () + "Maybe save file-visiting buffers belonging to the current repository. +Do so if `magit-save-repository-buffers' is non-nil. You should +not remove this from any hooks, instead set that variable to nil +if you so desire." + (when (and magit-save-repository-buffers + (not disable-magit-save-buffers)) + (setq disable-magit-save-buffers t) + (let ((msg (current-message))) + (magit-save-repository-buffers + (eq magit-save-repository-buffers 'dontask)) + (when (and msg + (current-message) + (not (equal msg (current-message)))) + (message "%s" msg))))) + +(add-hook 'magit-pre-refresh-hook #'magit-maybe-save-repository-buffers) +(add-hook 'magit-pre-call-git-hook #'magit-maybe-save-repository-buffers) +(add-hook 'magit-pre-start-git-hook #'magit-maybe-save-repository-buffers) + +(defvar-local magit-inhibit-refresh-save nil) + +(defun magit-save-repository-buffers (&optional arg) + "Save file-visiting buffers belonging to the current repository. +After any buffer where `buffer-save-without-query' is non-nil +is saved without asking, the user is asked about each modified +buffer which visits a file in the current repository. Optional +argument (the prefix) non-nil means save all with no questions." + (interactive "P") + (when-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (let ((remote (file-remote-p topdir)) + (save-some-buffers-action-alist + `((?Y (lambda (buffer) + (with-current-buffer buffer + (setq buffer-save-without-query t) + (save-buffer))) + "to save the current buffer and remember choice") + (?N (lambda (buffer) + (with-current-buffer buffer + (setq magit-inhibit-refresh-save t))) + "to skip the current buffer and remember choice") + ,@save-some-buffers-action-alist))) + (save-some-buffers + arg (lambda () + (and (not magit-inhibit-refresh-save) + buffer-file-name + ;; Avoid needlessly connecting to unrelated remotes. + (equal (file-remote-p buffer-file-name) + remote) + ;; For remote files this makes network requests and + ;; therefore has to come after the above to avoid + ;; unnecessarily waiting for unrelated hosts. + (file-exists-p (file-name-directory buffer-file-name)) + (string-prefix-p topdir (file-truename buffer-file-name)) + (equal (magit-rev-parse-safe "--show-toplevel") + topdir))))))) + +;;; Restore Window Configuration + +(defvar magit-inhibit-save-previous-winconf nil) + +(defvar-local magit-previous-window-configuration nil) +(put 'magit-previous-window-configuration 'permanent-local t) + +(defun magit-save-window-configuration () + "Save the current window configuration. + +Later, when the buffer is buried, it may be restored by +`magit-restore-window-configuration'." + (if magit-inhibit-save-previous-winconf + (when (eq magit-inhibit-save-previous-winconf 'unset) + (setq magit-previous-window-configuration nil)) + (unless (get-buffer-window (current-buffer) (selected-frame)) + (setq magit-previous-window-configuration + (current-window-configuration))))) + +(defun magit-restore-window-configuration (&optional kill-buffer) + "Bury or kill the current buffer and restore previous window configuration." + (let ((winconf magit-previous-window-configuration) + (buffer (current-buffer)) + (frame (selected-frame))) + (quit-window kill-buffer (selected-window)) + (when (and winconf (equal frame (window-configuration-frame winconf))) + (set-window-configuration winconf) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq magit-previous-window-configuration nil)))))) + +;;; Buffer History + +(defun magit-go-backward () + "Move backward in current buffer's history." + (interactive) + (if help-xref-stack + (help-xref-go-back (current-buffer)) + (user-error "No previous entry in buffer's history"))) + +(defun magit-go-forward () + "Move forward in current buffer's history." + (interactive) + (if help-xref-forward-stack + (help-xref-go-forward (current-buffer)) + (user-error "No next entry in buffer's history"))) + +(defun magit-insert-xref-buttons () + "Insert xref buttons." + (when (or help-xref-stack help-xref-forward-stack) + (when help-xref-stack + (magit-xref-insert-button help-back-label 'magit-xref-backward)) + (when help-xref-forward-stack + (when help-xref-stack + (insert " ")) + (magit-xref-insert-button help-forward-label 'magit-xref-forward)))) + +(defun magit-xref-insert-button (label type) + (magit-insert-section (button label) + (insert-text-button label 'type type + 'help-args (list (current-buffer))))) + +(define-button-type 'magit-xref-backward + :supertype 'help-back + 'mouse-face 'magit-section-highlight + 'help-echo (purecopy "mouse-2, RET: go back to previous history entry")) + +(define-button-type 'magit-xref-forward + :supertype 'help-forward + 'mouse-face 'magit-section-highlight + 'help-echo (purecopy "mouse-2, RET: go back to next history entry")) + +(defvar magit-xref-modes + '(magit-log-mode + magit-reflog-mode + magit-diff-mode + magit-revision-mode) + "List of modes for which to insert navigation buttons.") + +(defun magit-xref-setup (fn args) + (when (memq major-mode magit-xref-modes) + (when help-xref-stack-item + (push (cons (point) help-xref-stack-item) help-xref-stack) + (setq help-xref-forward-stack nil)) + (when (called-interactively-p 'interactive) + (--when-let (nthcdr 10 help-xref-stack) + (setcdr it nil))) + (setq help-xref-stack-item + (list 'magit-xref-restore fn default-directory args)))) + +(defun magit-xref-restore (fn dir args) + (setq default-directory dir) + (funcall fn major-mode nil args) + (magit-refresh-buffer)) + +;;; Repository-Local Cache + +(defvar magit-repository-local-cache nil + "Alist mapping `magit-toplevel' paths to alists of key/value pairs.") + +(defun magit-repository-local-repository () + "Return the key for the current repository." + (or (bound-and-true-p magit--default-directory) + (magit-toplevel))) + +(defun magit-repository-local-set (key value &optional repository) + "Set the repository-local VALUE for KEY. + +Unless specified, REPOSITORY is the current buffer's repository. + +If REPOSITORY is nil (meaning there is no current repository), +then the value is not cached, and we return nil." + (let* ((repokey (or repository (magit-repository-local-repository))) + (cache (assoc repokey magit-repository-local-cache))) + ;; Don't cache values for a nil REPOSITORY, as the 'set' and 'get' + ;; calls for some KEY may happen in unrelated contexts. + (when repokey + (if cache + (let ((keyvalue (assoc key (cdr cache)))) + (if keyvalue + ;; Update pre-existing value for key. + (setcdr keyvalue value) + ;; No such key in repository-local cache. + (push (cons key value) (cdr cache)))) + ;; No cache for this repository. + (push (cons repokey (list (cons key value))) + magit-repository-local-cache))))) + +(defun magit-repository-local-exists-p (key &optional repository) + "Non-nil when a repository-local value exists for KEY. + +Returns a (KEY . value) cons cell. + +The KEY is matched using `equal'. + +Unless specified, REPOSITORY is the current buffer's repository." + (let* ((repokey (or repository (magit-repository-local-repository))) + (cache (assoc repokey magit-repository-local-cache))) + (and cache + (assoc key (cdr cache))))) + +(defun magit-repository-local-get (key &optional default repository) + "Return the repository-local value for KEY. + +Return DEFAULT if no value for KEY exists. + +The KEY is matched using `equal'. + +Unless specified, REPOSITORY is the current buffer's repository." + (let ((keyvalue (magit-repository-local-exists-p key repository))) + (if keyvalue + (cdr keyvalue) + default))) + +(defun magit-repository-local-delete (key &optional repository) + "Delete the repository-local value for KEY. + +Unless specified, REPOSITORY is the current buffer's repository." + (let* ((repokey (or repository (magit-repository-local-repository))) + (cache (assoc repokey magit-repository-local-cache))) + (when cache + ;; There is no `assoc-delete-all'. + (setf (cdr cache) + (cl-delete key (cdr cache) :key #'car :test #'equal))))) + +(defun magit-preserve-section-visibility-cache () + (when (derived-mode-p 'magit-status-mode 'magit-refs-mode) + (magit-repository-local-set + (cons major-mode 'magit-section-visibility-cache) + magit-section-visibility-cache))) + +(defun magit-restore-section-visibility-cache (mode) + (setq magit-section-visibility-cache + (magit-repository-local-get + (cons mode 'magit-section-visibility-cache)))) + +(defun magit-zap-caches () + "Zap caches for the current repository. +Remove the repository's entry from `magit-repository-local-cache' +and set `magit-section-visibility-cache' to nil in all of the +repository's Magit buffers." + (interactive) + (magit-with-toplevel + (setq magit-repository-local-cache + (cl-delete default-directory + magit-repository-local-cache + :key #'car :test #'equal))) + (dolist (buffer (magit-mode-get-buffers)) + (with-current-buffer buffer + (setq magit-section-visibility-cache nil))) + (setq magit--libgit-available-p eieio-unbound)) + +;;; Utilities + +(defun magit-toggle-verbose-refresh () + "Toggle whether Magit refreshes buffers verbosely. +Enabling this helps figuring out which sections are bottlenecks. +The additional output can be found in the *Messages* buffer." + (interactive) + (setq magit-refresh-verbose (not magit-refresh-verbose)) + (message "%s verbose refreshing" + (if magit-refresh-verbose "Enabled" "Disabled"))) + +(defun magit-run-hook-with-benchmark (hook) + (when hook + (if magit-refresh-verbose + (let ((start (current-time))) + (message "Running %s..." hook) + (run-hooks hook) + (message "Running %s...done (%.3fs)" hook + (float-time (time-subtract (current-time) start)))) + (run-hooks hook)))) + +;;; _ +(provide 'magit-mode) +;;; magit-mode.el ends here diff --git a/elpa/magit-20200318.1224/magit-mode.elc b/elpa/magit-20200318.1224/magit-mode.elc new file mode 100644 index 00000000..56014afb Binary files /dev/null and b/elpa/magit-20200318.1224/magit-mode.elc differ diff --git a/elpa/magit-20200318.1224/magit-notes.el b/elpa/magit-20200318.1224/magit-notes.el new file mode 100644 index 00000000..99196089 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-notes.el @@ -0,0 +1,200 @@ +;;; magit-notes.el --- notes support -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for `git-notes'. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-notes "magit" nil t) +(define-transient-command magit-notes () + "Edit notes attached to commits." + :man-page "git-notes" + ["Configure local settings" + ("c" magit-core.notesRef) + ("d" magit-notes.displayRef)] + ["Configure global settings" + ("C" magit-global-core.notesRef) + ("D" magit-global-notes.displayRef)] + ["Arguments for prune" + :if-not magit-notes-merging-p + ("-n" "Dry run" ("-n" "--dry-run"))] + ["Arguments for edit and remove" + :if-not magit-notes-merging-p + (magit-notes:--ref)] + ["Arguments for merge" + :if-not magit-notes-merging-p + (magit-notes:--strategy)] + ["Actions" + :if-not magit-notes-merging-p + ("T" "Edit" magit-notes-edit) + ("r" "Remove" magit-notes-remove) + ("m" "Merge" magit-notes-merge) + ("p" "Prune" magit-notes-prune)] + ["Actions" + :if magit-notes-merging-p + ("c" "Commit merge" magit-notes-merge-commit) + ("a" "Abort merge" magit-notes-merge-abort)]) + +(defun magit-notes-merging-p () + (let ((dir (magit-git-dir "NOTES_MERGE_WORKTREE"))) + (and (file-directory-p dir) + (directory-files dir nil "^[^.]")))) + +(define-infix-command magit-core.notesRef () + :class 'magit--git-variable + :variable "core.notesRef" + :reader 'magit-notes-read-ref + :prompt "Set local core.notesRef") + +(define-infix-command magit-notes.displayRef () + :class 'magit--git-variable + :variable "notes.displayRef" + :multi-value t + :reader 'magit-notes-read-refs + :prompt "Set local notes.displayRef") + +(define-infix-command magit-global-core.notesRef () + :class 'magit--git-variable + :variable "core.notesRef" + :reader 'magit-notes-read-ref + :prompt "Set global core.notesRef") + +(define-infix-command magit-global-notes.displayRef () + :class 'magit--git-variable + :variable "notes.displayRef" + :multi-value t + :reader 'magit-notes-read-refs + :prompt "Set global notes.displayRef") + +(define-infix-argument magit-notes:--ref () + :description "Merge strategy" + :class 'transient-option + :key "-r" + :argument "--ref=" + :reader 'magit-notes-read-ref) + +(define-infix-argument magit-notes:--strategy () + :description "Merge strategy" + :class 'transient-option + :shortarg "-s" + :argument "--strategy=" + :choices '("manual" "ours" "theirs" "union" "cat_sort_uniq")) + +(defun magit-notes-edit (commit &optional ref) + "Edit the note attached to COMMIT. +REF is the notes ref used to store the notes. + +Interactively or when optional REF is nil use the value of Git +variable `core.notesRef' or \"refs/notes/commits\" if that is +undefined." + (interactive (magit-notes-read-args "Edit notes")) + (magit-run-git-with-editor "notes" (and ref (concat "--ref=" ref)) + "edit" commit)) + +(defun magit-notes-remove (commit &optional ref) + "Remove the note attached to COMMIT. +REF is the notes ref from which the note is removed. + +Interactively or when optional REF is nil use the value of Git +variable `core.notesRef' or \"refs/notes/commits\" if that is +undefined." + (interactive (magit-notes-read-args "Remove notes")) + (magit-run-git-with-editor "notes" (and ref (concat "--ref=" ref)) + "remove" commit)) + +(defun magit-notes-merge (ref) + "Merge the notes ref REF into the current notes ref. + +The current notes ref is the value of Git variable +`core.notesRef' or \"refs/notes/commits\" if that is undefined. + +When there are conflicts, then they have to be resolved in the +temporary worktree \".git/NOTES_MERGE_WORKTREE\". When +done use `magit-notes-merge-commit' to finish. To abort +use `magit-notes-merge-abort'." + (interactive (list (magit-read-string-ns "Merge reference"))) + (magit-run-git-with-editor "notes" "merge" ref)) + +(defun magit-notes-merge-commit () + "Commit the current notes ref merge. +Also see `magit-notes-merge'." + (interactive) + (magit-run-git-with-editor "notes" "merge" "--commit")) + +(defun magit-notes-merge-abort () + "Abort the current notes ref merge. +Also see `magit-notes-merge'." + (interactive) + (magit-run-git-with-editor "notes" "merge" "--abort")) + +(defun magit-notes-prune (&optional dry-run) + "Remove notes about unreachable commits." + (interactive (list (and (member "--dry-run" (transient-args 'magit-notes)) t))) + (when dry-run + (magit-process-buffer)) + (magit-run-git-with-editor "notes" "prune" (and dry-run "--dry-run"))) + +;;; Readers + +(defun magit-notes-read-ref (prompt _initial-input history) + (--when-let (magit-completing-read + prompt (magit-list-notes-refnames) nil nil + (--when-let (magit-get "core.notesRef") + (if (string-prefix-p "refs/notes/" it) + (substring it 11) + it)) + history) + (if (string-prefix-p "refs/" it) + it + (concat "refs/notes/" it)))) + +(defun magit-notes-read-refs (prompt) + (mapcar (lambda (ref) + (if (string-prefix-p "refs/" ref) + ref + (concat "refs/notes/" ref))) + (completing-read-multiple + (concat prompt ": ") + (magit-list-notes-refnames) nil nil + (mapconcat (lambda (ref) + (if (string-prefix-p "refs/notes/" ref) + (substring ref 11) + ref)) + (magit-get-all "notes.displayRef") + ",")))) + +(defun magit-notes-read-args (prompt) + (list (magit-read-branch-or-commit prompt (magit-stash-at-point)) + (--when-let (--first (string-match "^--ref=\\(.+\\)" it) + (transient-args 'magit-notes)) + (match-string 1 it)))) + +;;; _ +(provide 'magit-notes) +;;; magit-notes.el ends here diff --git a/elpa/magit-20200318.1224/magit-notes.elc b/elpa/magit-20200318.1224/magit-notes.elc new file mode 100644 index 00000000..bbbefeef Binary files /dev/null and b/elpa/magit-20200318.1224/magit-notes.elc differ diff --git a/elpa/magit-20200318.1224/magit-obsolete.el b/elpa/magit-20200318.1224/magit-obsolete.el new file mode 100644 index 00000000..d7c2f1b9 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-obsolete.el @@ -0,0 +1,109 @@ +;;; magit-obsolete.el --- obsolete definitions -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library defines aliases for obsolete variables and functions. + +;;; Code: + +(require 'magit) + +;;; Obsolete since v3.0.0 + +(define-obsolete-function-alias 'magit-diff-visit-file-worktree + 'magit-diff-visit-worktree-file "Magit 3.0.0") + +(define-obsolete-function-alias 'magit-status-internal + 'magit-status-setup-buffer "Magit 3.0.0") + +(define-obsolete-variable-alias 'magit-mode-setup-hook + 'magit-setup-buffer-hook "Magit 3.0.0") + +(define-obsolete-variable-alias 'magit-branch-popup-show-variables + 'magit-branch-direct-configure "Magit 3.0.0") + +(define-obsolete-function-alias 'magit-dispatch-popup + 'magit-dispatch "Magit 3.0.0") + +(define-obsolete-function-alias 'magit-repolist-column-dirty + 'magit-repolist-column-flag "Magit 3.0.0") + +(define-obsolete-variable-alias 'magit-disable-line-numbers + 'magit-section-disable-line-numbers "Magit 3.0.0") + +(defun magit--magit-popup-warning () + (display-warning 'magit "\ +Magit no longer uses Magit-Popup. +It now uses Transient. +See https://emacsair.me/2019/02/14/transient-0.1. + +However your configuration and/or some third-party package that +you use still depends on the `magit-popup' package. But because +`magit' no longer depends on that, `package' has removed it from +your system. + +If some package that you use still depends on `magit-popup' but +does not declare it as a dependency, then please contact its +maintainer about that and install `magit-popup' explicitly. + +If you yourself use functions that are defined in `magit-popup' +in your configuration, then the next step depends on what you use +that for. + +* If you use `magit-popup' to define your own popups but do not + modify any of Magit's old popups, then you have to install + `magit-popup' explicitly. (You can also migrate to Transient, + but there is no need to rush that.) + +* If you add additional arguments and/or actions to Magit's popups, + then you have to port that to modify the new \"transients\" instead. + See https://github.com/magit/magit/wiki/\ +Converting-popup-modifications-to-transient-modifications + +To find installed packages that still use `magit-popup' you can +use e.g. \"M-x rgrep RET magit-popup RET RET ~/.emacs.d/ RET\".")) +(cl-eval-when (eval load) + (unless (require (quote magit-popup) nil t) + (defun magit-define-popup-switch (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-option (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-variable (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-action (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-sequence-action (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-key (&rest _) + (magit--magit-popup-warning)) + (defun magit-define-popup-keys-deferred (&rest _) + (magit--magit-popup-warning)) + (defun magit-change-popup-key (&rest _) + (magit--magit-popup-warning)) + (defun magit-remove-popup-key (&rest _) + (magit--magit-popup-warning)))) + +;;; _ +(provide 'magit-obsolete) +;;; magit-obsolete.el ends here diff --git a/elpa/magit-20200318.1224/magit-obsolete.elc b/elpa/magit-20200318.1224/magit-obsolete.elc new file mode 100644 index 00000000..ca174f6c Binary files /dev/null and b/elpa/magit-20200318.1224/magit-obsolete.elc differ diff --git a/elpa/magit-20200318.1224/magit-patch.el b/elpa/magit-20200318.1224/magit-patch.el new file mode 100644 index 00000000..2eb54acc --- /dev/null +++ b/elpa/magit-20200318.1224/magit-patch.el @@ -0,0 +1,331 @@ +;;; magit-patch.el --- creating and applying patches -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements patch commands. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Options + +(defcustom magit-patch-save-arguments '(exclude "--stat") + "Control arguments used by the command `magit-patch-save'. + +`magit-patch-save' (which see) saves a diff for the changes +shown in the current buffer in a patch file. It may use the +same arguments as used in the buffer or a subset thereof, or +a constant list of arguments, depending on this option and +the prefix argument." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type '(choice (const :tag "use buffer arguments" buffer) + (cons :tag "use buffer arguments except" + (const :format "" exclude) + (repeat :format "%v%i\n" + (string :tag "Argument"))) + (repeat :tag "use constant arguments" + (string :tag "Argument")))) + +;;; Commands + +;;;###autoload (autoload 'magit-patch "magit-patch" nil t) +(define-transient-command magit-patch () + "Create or apply patches." + ["Actions" + ("c" "Create patches" magit-patch-create) + ("a" "Apply patch" magit-patch-apply) + ("s" "Save diff as patch" magit-patch-save) + ("r" "Request pull" magit-request-pull)]) + +;;;###autoload (autoload 'magit-patch-create "magit-patch" nil t) +(define-transient-command magit-patch-create (range args files) + "Create patches for the commits in RANGE. +When a single commit is given for RANGE, create a patch for the +changes introduced by that commit (unlike 'git format-patch' +which creates patches for all commits that are reachable from +`HEAD' but not from the specified commit)." + :man-page "git-format-patch" + :incompatible '(("--subject-prefix=" "--rfc")) + ["Mail arguments" + (6 magit-format-patch:--in-reply-to) + (6 magit-format-patch:--thread) + (6 magit-format-patch:--from) + (6 magit-format-patch:--to) + (6 magit-format-patch:--cc)] + ["Patch arguments" + (magit-format-patch:--base) + (magit-format-patch:--reroll-count) + (5 magit-format-patch:--interdiff) + (magit-format-patch:--range-diff) + (magit-format-patch:--subject-prefix) + ("C-m r " "RFC subject prefix" "--rfc") + ("C-m l " "Add cover letter" "--cover-letter") + (5 magit-format-patch:--cover-from-description) + (5 magit-format-patch:--notes) + (magit-format-patch:--output-directory)] + ["Diff arguments" + (magit-diff:-U) + (magit-diff:-M) + (magit-diff:-C) + (magit-diff:--diff-algorithm) + (magit:--) + (7 "-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + (7 "-w" "Ignore all whitespace" ("-w" "--ignore-all-space"))] + ["Actions" + ("c" "Create patches" magit-patch-create)] + (interactive + (if (not (eq current-transient-command 'magit-patch-create)) + (list nil nil nil) + (cons (if-let ((revs (magit-region-values 'commit t))) + (concat (car (last revs)) "^.." (car revs)) + (let ((range (magit-read-range-or-commit + "Format range or commit"))) + (if (string-match-p "\\.\\." range) + range + (format "%s~..%s" range range)))) + (let ((args (transient-args 'magit-patch-create))) + (list (-filter #'stringp args) + (cdr (assoc "--" args))))))) + (if (not range) + (transient-setup 'magit-patch-create) + (magit-run-git "format-patch" range args "--" files) + (when (member "--cover-letter" args) + (save-match-data + (find-file + (expand-file-name + (concat (--some (and (string-match "\\`--reroll-count=\\(.+\\)" it) + (format "v%s-" (match-string 1 it))) + args) + "0000-cover-letter.patch") + (let ((topdir (magit-toplevel))) + (or (--some (and (string-match "\\`--output-directory=\\(.+\\)" it) + (expand-file-name (match-string 1 it) topdir)) + args) + topdir)))))))) + +(define-infix-argument magit-format-patch:--in-reply-to () + :description "In reply to" + :class 'transient-option + :key "C-m C-r" + :argument "--in-reply-to=") + +(define-infix-argument magit-format-patch:--thread () + :description "Thread style" + :class 'transient-option + :key "C-m s " + :argument "--thread=" + :reader #'magit-format-patch-select-thread-style) + +(defun magit-format-patch-select-thread-style (&rest _ignore) + (magit-read-char-case "Thread style " t + (?d "[d]eep" "deep") + (?s "[s]hallow" "shallow"))) + +(define-infix-argument magit-format-patch:--base () + :description "Insert base commit" + :class 'transient-option + :key "C-m b " + :argument "--base=" + :reader #'magit-format-patch-select-base) + +(defun magit-format-patch-select-base (prompt initial-input history) + (or (magit-completing-read prompt (cons "auto" (magit-list-refnames)) + nil nil initial-input history "auto") + (user-error "Nothing selected"))) + +(define-infix-argument magit-format-patch:--reroll-count () + :description "Reroll count" + :class 'transient-option + :key "C-m v " + :shortarg "-v" + :argument "--reroll-count=" + :reader 'transient-read-number-N+) + +(define-infix-argument magit-format-patch:--interdiff () + :description "Insert interdiff" + :class 'transient-option + :key "C-m d i" + :argument "--interdiff=" + :reader #'magit-transient-read-revision) + +(define-infix-argument magit-format-patch:--range-diff () + :description "Insert range-diff" + :class 'transient-option + :key "C-m d r" + :argument "--range-diff=" + :reader #'magit-format-patch-select-range-diff) + +(defun magit-format-patch-select-range-diff (prompt _initial-input _history) + (magit-read-range-or-commit prompt)) + +(define-infix-argument magit-format-patch:--subject-prefix () + :description "Subject Prefix" + :class 'transient-option + :key "C-m p " + :argument "--subject-prefix=") + +(define-infix-argument magit-format-patch:--cover-from-description () + :description "Use branch description" + :class 'transient-option + :key "C-m D " + :argument "--cover-from-description=" + :reader #'magit-format-patch-select-description-mode) + +(defun magit-format-patch-select-description-mode (&rest _ignore) + (magit-read-char-case "Use description as " t + (?m "[m]essage" "message") + (?s "[s]ubject" "subject") + (?a "[a]uto" "auto") + (?n "[n]othing" "none"))) + +(define-infix-argument magit-format-patch:--notes () + :description "Insert commentary from notes" + :class 'transient-option + :key "C-m n " + :argument "--notes=" + :reader #'magit-notes-read-ref) + +(define-infix-argument magit-format-patch:--from () + :description "From" + :class 'transient-option + :key "C-m C-f" + :argument "--from=" + :reader 'magit-transient-read-person) + +(define-infix-argument magit-format-patch:--to () + :description "To" + :class 'transient-option + :key "C-m C-t" + :argument "--to=" + :reader 'magit-transient-read-person) + +(define-infix-argument magit-format-patch:--cc () + :description "CC" + :class 'transient-option + :key "C-m C-c" + :argument "--cc=" + :reader 'magit-transient-read-person) + +(define-infix-argument magit-format-patch:--output-directory () + :description "Output directory" + :class 'transient-option + :key "C-m o " + :shortarg "-o" + :argument "--output-directory=" + :reader 'transient-read-existing-directory) + +;;;###autoload (autoload 'magit-patch-apply "magit-patch" nil t) +(define-transient-command magit-patch-apply (file &rest args) + "Apply the patch file FILE." + :man-page "git-apply" + ["Arguments" + ("-i" "Also apply to index" "--index") + ("-c" "Only apply to index" "--cached") + ("-3" "Fall back on 3way merge" ("-3" "--3way"))] + ["Actions" + ("a" "Apply patch" magit-patch-apply)] + (interactive + (if (not (eq current-transient-command 'magit-patch-apply)) + (list nil) + (list (expand-file-name + (read-file-name "Apply patch: " + default-directory nil nil + (when-let ((file (magit-file-at-point))) + (file-relative-name file)))) + (transient-args 'magit-patch-apply)))) + (if (not file) + (transient-setup 'magit-patch-apply) + (magit-run-git "apply" args "--" (magit-convert-filename-for-git file)))) + +;;;###autoload +(defun magit-patch-save (file &optional arg) + "Write current diff into patch FILE. + +What arguments are used to create the patch depends on the value +of `magit-patch-save-arguments' and whether a prefix argument is +used. + +If the value is the symbol `buffer', then use the same arguments +as the buffer. With a prefix argument use no arguments. + +If the value is a list beginning with the symbol `exclude', then +use the same arguments as the buffer except for those matched by +entries in the cdr of the list. The comparison is done using +`string-prefix-p'. With a prefix argument use the same arguments +as the buffer. + +If the value is a list of strings (including the empty list), +then use those arguments. With a prefix argument use the same +arguments as the buffer. + +Of course the arguments that are required to actually show the +same differences as those shown in the buffer are always used." + (interactive (list (read-file-name "Write patch file: " default-directory) + current-prefix-arg)) + (unless (derived-mode-p 'magit-diff-mode) + (user-error "Only diff buffers can be saved as patches")) + (let ((rev magit-buffer-range) + (typearg magit-buffer-typearg) + (args magit-buffer-diff-args) + (files magit-buffer-diff-files)) + (cond ((eq magit-patch-save-arguments 'buffer) + (when arg + (setq args nil))) + ((eq (car-safe magit-patch-save-arguments) 'exclude) + (unless arg + (setq args (-difference args (cdr magit-patch-save-arguments))))) + ((not arg) + (setq args magit-patch-save-arguments))) + (with-temp-file file + (magit-git-insert "diff" rev "-p" typearg args "--" files))) + (magit-refresh)) + +;;;###autoload +(defun magit-request-pull (url start end) + "Request upstream to pull from you public repository. + +URL is the url of your publicly accessible repository. +START is a commit that already is in the upstream repository. +END is the last commit, usually a branch name, which upstream +is asked to pull. START has to be reachable from that commit." + (interactive + (list (magit-get "remote" (magit-read-remote "Remote") "url") + (magit-read-branch-or-commit "Start" (magit-get-upstream-branch)) + (magit-read-branch-or-commit "End"))) + (let ((dir default-directory)) + ;; mu4e changes default-directory + (compose-mail) + (setq default-directory dir)) + (message-goto-body) + (magit-git-insert "request-pull" start url end) + (set-buffer-modified-p nil)) + +;;; _ +(provide 'magit-patch) +;;; magit-patch.el ends here diff --git a/elpa/magit-20200318.1224/magit-patch.elc b/elpa/magit-20200318.1224/magit-patch.elc new file mode 100644 index 00000000..1a71c880 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-patch.elc differ diff --git a/elpa/magit-20200318.1224/magit-pkg.el b/elpa/magit-20200318.1224/magit-pkg.el new file mode 100644 index 00000000..295d24b2 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-pkg.el @@ -0,0 +1,12 @@ +(define-package "magit" "20200318.1224" "A Git porcelain inside Emacs." + '((emacs "25.1") + (async "20180527") + (dash "20180910") + (git-commit "20181104") + (transient "20190812") + (with-editor "20181103")) + :keywords + '("git" "tools" "vc")) +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/magit-20200318.1224/magit-process.el b/elpa/magit-20200318.1224/magit-process.el new file mode 100644 index 00000000..c7780b07 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-process.el @@ -0,0 +1,1154 @@ +;;; magit-process.el --- process functionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements the tools used to run Git for side-effects. + +;; Note that the functions used to run Git and then consume its +;; output, are defined in `magit-git.el'. There's a bit of overlap +;; though. + +;;; Code: + +(require 'ansi-color) +(require 'cl-lib) +(require 'dash) + +(eval-when-compile + (require 'subr-x)) + +(require 'with-editor) +(require 'magit-utils) +(require 'magit-section) +(require 'magit-git) +(require 'magit-mode) + +(declare-function auth-source-search "auth-source" + (&rest spec &key max require create delete &allow-other-keys)) + +;;; Options + +(defcustom magit-process-connection-type (not (eq system-type 'cygwin)) + "Connection type used for the Git process. + +If nil, use pipes: this is usually more efficient, and works on Cygwin. +If t, use ptys: this enables Magit to prompt for passphrases when needed." + :group 'magit-process + :type '(choice (const :tag "pipe" nil) + (const :tag "pty" t))) + +(defcustom magit-need-cygwin-noglob + (and (eq system-type 'windows-nt) + (with-temp-buffer + (let ((process-environment + (append magit-git-environment process-environment))) + (condition-case e + (process-file magit-git-executable + nil (current-buffer) nil + "-c" "alias.echo=!echo" "echo" "x{0}") + (file-error + (lwarn 'magit-process :warning + "Could not run Git: %S" e)))) + (equal "x0\n" (buffer-string)))) + "Whether to use a workaround for Cygwin's globbing behavior. + +If non-nil, add environment variables to `process-environment' to +prevent the git.exe distributed by Cygwin and MSYS2 from +attempting to perform glob expansion when called from a native +Windows build of Emacs. See #2246." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom magit-process-popup-time -1 + "Popup the process buffer if a command takes longer than this many seconds." + :group 'magit-process + :type '(choice (const :tag "Never" -1) + (const :tag "Immediately" 0) + (integer :tag "After this many seconds"))) + +(defcustom magit-process-log-max 32 + "Maximum number of sections to keep in a process log buffer. +When adding a new section would go beyond the limit set here, +then the older half of the sections are remove. Sections that +belong to processes that are still running are never removed. +When this is nil, no sections are ever removed." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type '(choice (const :tag "Never remove old sections" nil) integer)) + +(defcustom magit-process-error-tooltip-max-lines 20 + "The number of lines for `magit-process-error-lines' to return. + +These are displayed in a tooltip for `mode-line-process' errors. + +If `magit-process-error-tooltip-max-lines' is nil, the tooltip +displays the text of `magit-process-error-summary' instead." + :package-version '(magit . "2.12.0") + :group 'magit-process + :type '(choice (const :tag "Use summary line" nil) + integer)) + +(defcustom magit-credential-cache-daemon-socket + (--some (pcase-let ((`(,prog . ,args) (split-string it))) + (if (and prog + (string-match-p + "\\`\\(?:\\(?:/.*/\\)?git-credential-\\)?cache\\'" prog)) + (or (cl-loop for (opt val) on args + if (string= opt "--socket") + return val) + (expand-file-name "~/.git-credential-cache/socket")))) + ;; Note: `magit-process-file' is not yet defined when + ;; evaluating this form, so we use `process-lines'. + (ignore-errors + (let ((process-environment + (append magit-git-environment process-environment))) + (process-lines magit-git-executable + "config" "--get-all" "credential.helper")))) + "If non-nil, start a credential cache daemon using this socket. + +When using Git's cache credential helper in the normal way, Emacs +sends a SIGHUP to the credential daemon after the git subprocess +has exited, causing the daemon to also quit. This can be avoided +by starting the `git-credential-cache--daemon' process directly +from Emacs. + +The function `magit-maybe-start-credential-cache-daemon' takes +care of starting the daemon if necessary, using the value of this +option as the socket. If this option is nil, then it does not +start any daemon. Likewise if another daemon is already running, +then it starts no new daemon. This function has to be a member +of the hook variable `magit-credential-hook' for this to work. +If an error occurs while starting the daemon, most likely because +the necessary executable is missing, then the function removes +itself from the hook, to avoid further futile attempts." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(choice (file :tag "Socket") + (const :tag "Don't start a cache daemon" nil))) + +(defcustom magit-process-yes-or-no-prompt-regexp + (concat " [\[(]" + "\\([Yy]\\(?:es\\)?\\)" + "[/|]" + "\\([Nn]o?\\)" + ;; OpenSSH v8 prints this. See #3969. + "\\(?:/\\[fingerprint\\]\\)?" + "[\])] ?[?:] ?$") + "Regexp matching Yes-or-No prompts of Git and its subprocesses." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type 'regexp) + +(defcustom magit-process-password-prompt-regexps + '("^\\(Enter \\)?[Pp]assphrase\\( for \\(RSA \\)?key '.*'\\)?: ?$" + ;; Match-group 99 is used to identify the "user@host" part. + "^\\(Enter \\)?[Pp]assword\\( for '?\\(https?://\\)?\\(?99:[^']*\\)'?\\)?: ?$" + "^.*'s password: ?$" + "^Yubikey for .*: ?$" + "^Enter PIN for .*: ?$") + "List of regexps matching password prompts of Git and its subprocesses. +Also see `magit-process-find-password-functions'." + :package-version '(magit . "2.8.0") + :group 'magit-process + :type '(repeat (regexp))) + +(defcustom magit-process-find-password-functions nil + "List of functions to try in sequence to get a password. + +These functions may be called when git asks for a password, which +is detected using `magit-process-password-prompt-regexps'. They +are called if and only if matching the prompt resulted in the +value of the 99th submatch to be non-nil. Therefore users can +control for which prompts these functions should be called by +putting the host name in the 99th submatch, or not. + +If the functions are called, then they are called in the order +given, with the host name as only argument, until one of them +returns non-nil. If they are not called or none of them returns +non-nil, then the password is read from the user instead." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type 'hook + :options '(magit-process-password-auth-source)) + +(defcustom magit-process-username-prompt-regexps + '("^Username for '.*': ?$") + "List of regexps matching username prompts of Git and its subprocesses." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type '(repeat (regexp))) + +(defcustom magit-process-prompt-functions nil + "List of functions used to forward arbitrary questions to the user. + +Magit has dedicated support for forwarding username and password +prompts and Yes-or-No questions asked by Git and its subprocesses +to the user. This can be customized using other options in the +`magit-process' customization group. + +If you encounter a new question that isn't handled by default, +then those options should be used instead of this hook. + +However subprocesses may also ask questions that differ too much +from what the code related to the above options assume, and this +hook allows users to deal with such questions explicitly. + +Each function is called with the process and the output string +as arguments until one of the functions returns non-nil. The +function is responsible for asking the user the appropriate +question using e.g. `read-char-choice' and then forwarding the +answer to the process using `process-send-string'. + +While functions such as `magit-process-yes-or-no-prompt' may not +be sufficient to handle some prompt, it may still be of benefit +to look at the implementations to gain some insights on how to +implement such functions." + :package-version '(magit . "3.0.0") + :group 'magit-process + :type 'hook) + +(defcustom magit-process-ensure-unix-line-ending t + "Whether Magit should ensure a unix coding system when talking to Git." + :package-version '(magit . "2.6.0") + :group 'magit-process + :type 'boolean) + +(defcustom magit-process-display-mode-line-error t + "Whether Magit should retain and highlight process errors in the mode line." + :package-version '(magit . "2.12.0") + :group 'magit-process + :type 'boolean) + +(defface magit-process-ok + '((t :inherit magit-section-heading :foreground "green")) + "Face for zero exit-status." + :group 'magit-faces) + +(defface magit-process-ng + '((t :inherit magit-section-heading :foreground "red")) + "Face for non-zero exit-status." + :group 'magit-faces) + +(defface magit-mode-line-process + '((t :inherit mode-line-emphasis)) + "Face for `mode-line-process' status when Git is running for side-effects." + :group 'magit-faces) + +(defface magit-mode-line-process-error + '((t :inherit error)) + "Face for `mode-line-process' error status. + +Used when `magit-process-display-mode-line-error' is non-nil." + :group 'magit-faces) + +;;; Process Mode + +(defvar magit-process-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + map) + "Keymap for `magit-process-mode'.") + +(define-derived-mode magit-process-mode magit-mode "Magit Process" + "Mode for looking at Git process output." + :group 'magit-process + (hack-dir-local-variables-non-file-buffer) + (setq imenu-prev-index-position-function + 'magit-imenu--process-prev-index-position-function) + (setq imenu-extract-index-name-function + 'magit-imenu--process-extract-index-name-function)) + +(defun magit-process-buffer (&optional nodisplay) + "Display the current repository's process buffer. + +If that buffer doesn't exist yet, then create it. +Non-interactively return the buffer and unless +optional NODISPLAY is non-nil also display it." + (interactive) + (let ((topdir (magit-toplevel))) + (unless topdir + (magit--with-safe-default-directory nil + (setq topdir default-directory) + (let (prev) + (while (not (equal topdir prev)) + (setq prev topdir) + (setq topdir (file-name-directory (directory-file-name topdir))))))) + (let ((buffer (or (--first (with-current-buffer it + (and (eq major-mode 'magit-process-mode) + (equal default-directory topdir))) + (buffer-list)) + (let ((default-directory topdir)) + (magit-generate-new-buffer 'magit-process-mode))))) + (with-current-buffer buffer + (if magit-root-section + (when magit-process-log-max + (magit-process-truncate-log)) + (magit-process-mode) + (let ((inhibit-read-only t) + (magit-insert-section--parent nil) + (magit-insert-section--oldroot nil)) + (make-local-variable 'text-property-default-nonsticky) + (magit-insert-section (processbuf) + (insert "\n"))))) + (unless nodisplay + (magit-display-buffer buffer)) + buffer))) + +(defun magit-process-kill () + "Kill the process at point." + (interactive) + (when-let ((process (magit-section-value-if 'process))) + (unless (eq (process-status process) 'run) + (user-error "Process isn't running")) + (magit-confirm 'kill-process) + (kill-process process))) + +;;; Synchronous Processes + +(defvar magit-process-raise-error nil) + +(defun magit-git (&rest args) + "Call Git synchronously in a separate process, for side-effects. + +Option `magit-git-executable' specifies the Git executable. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'. If Git exits with a non-zero status, +then raise an error." + (let ((magit-process-raise-error t)) + (magit-call-git args))) + +(defun magit-run-git (&rest args) + "Call Git synchronously in a separate process, and refresh. + +Option `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +After Git returns, the current buffer (if it is a Magit buffer) +as well as the current repository's status buffer are refreshed. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (let ((magit--refresh-cache (list (cons 0 0)))) + (magit-call-git args) + (when (member (car args) '("init" "clone")) + ;; Creating a new repository invalidates the cache. + (setq magit--refresh-cache nil)) + (magit-refresh))) + +(defvar magit-pre-call-git-hook nil) + +(defun magit-call-git (&rest args) + "Call Git synchronously in a separate process. + +Option `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (run-hooks 'magit-pre-call-git-hook) + (let ((default-process-coding-system (magit--process-coding-system))) + (apply #'magit-call-process magit-git-executable + (magit-process-git-arguments args)))) + +(defun magit-call-process (program &rest args) + "Call PROGRAM synchronously in a separate process. +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (pcase-let ((`(,process-buf . ,section) + (magit-process-setup program args))) + (magit-process-finish + (let ((inhibit-read-only t)) + (apply #'magit-process-file program nil process-buf nil args)) + process-buf (current-buffer) default-directory section))) + +(defun magit-process-file (process &optional infile buffer display &rest args) + "Process files synchronously in a separate process. +Identical to `process-file' but temporarily enable Cygwin's +\"noglob\" option during the call and ensure unix eol +conversion." + (let ((process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system))) + (apply #'process-file process infile buffer display args))) + +(defun magit-process-environment () + ;; The various w32 hacks are only applicable when running on the + ;; local machine. As of Emacs 25.1, a local binding of + ;; process-environment different from the top-level value affects + ;; the environment used in + ;; tramp-sh-handle-{start-file-process,process-file}. + (let ((local (not (file-remote-p default-directory)))) + (append magit-git-environment + (and local + (cdr (assoc magit-git-executable magit-git-w32-path-hack))) + (and local magit-need-cygwin-noglob + (mapcar (lambda (var) + (concat var "=" (--if-let (getenv var) + (concat it " noglob") + "noglob"))) + '("CYGWIN" "MSYS"))) + process-environment))) + +(defvar magit-this-process nil) + +(defun magit-run-git-with-input (&rest args) + "Call Git in a separate process. +ARGS is flattened and then used as arguments to Git. + +The current buffer's content is used as the process' standard +input. + +Option `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The remaining arguments ARGS specify arguments to Git, they are +flattened before use." + (when (eq system-type 'windows-nt) + ;; On w32, git expects UTF-8 encoded input, ignore any user + ;; configuration telling us otherwise (see #3250). + (encode-coding-region (point-min) (point-max) 'utf-8-unix)) + (if (file-remote-p default-directory) + ;; We lack `process-file-region', so fall back to asynch + + ;; waiting in remote case. + (progn + (magit-start-git (current-buffer) args) + (while (and magit-this-process + (eq (process-status magit-this-process) 'run)) + (sleep-for 0.005))) + (run-hooks 'magit-pre-call-git-hook) + (pcase-let* ((process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system)) + (flat-args (magit-process-git-arguments args)) + (`(,process-buf . ,section) + (magit-process-setup magit-git-executable flat-args)) + (inhibit-read-only t)) + (magit-process-finish + (apply #'call-process-region (point-min) (point-max) + magit-git-executable nil process-buf nil flat-args) + process-buf nil default-directory section)))) + +;;; Asynchronous Processes + +(defun magit-run-git-async (&rest args) + "Start Git, prepare for refresh, and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' for more information." + (message "Running %s %s" magit-git-executable + (let ((m (mapconcat #'identity (-flatten args) " "))) + (remove-list-of-text-properties 0 (length m) '(face) m) + m)) + (magit-start-git nil args)) + +(defun magit-run-git-with-editor (&rest args) + "Export GIT_EDITOR and start Git. +Also prepare for refresh and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' and `with-editor' for more information." + (magit--record-separated-gitdir) + (magit-with-editor (magit-run-git-async args))) + +(defun magit-run-git-sequencer (&rest args) + "Export GIT_EDITOR and start Git. +Also prepare for refresh and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. +If the sequence stops at a commit, make the section representing +that commit the current section by moving `point' there. + +See `magit-start-process' and `with-editor' for more information." + (apply #'magit-run-git-with-editor args) + (set-process-sentinel magit-this-process #'magit-sequencer-process-sentinel) + magit-this-process) + +(defvar magit-pre-start-git-hook nil) + +(defun magit-start-git (input &rest args) + "Start Git, prepare for refresh, and return the process object. + +If INPUT is non-nil, it has to be a buffer or the name of an +existing buffer. The buffer content becomes the processes +standard input. + +Option `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The remaining arguments ARGS specify arguments to Git, they are +flattened before use. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' for more information." + (run-hooks 'magit-pre-start-git-hook) + (let ((default-process-coding-system (magit--process-coding-system))) + (apply #'magit-start-process magit-git-executable input + (magit-process-git-arguments args)))) + +(defun magit-start-process (program &optional input &rest args) + "Start PROGRAM, prepare for refresh, and return the process object. + +If optional argument INPUT is non-nil, it has to be a buffer or +the name of an existing buffer. The buffer content becomes the +processes standard input. + +The process is started using `start-file-process' and then setup +to use the sentinel `magit-process-sentinel' and the filter +`magit-process-filter'. Information required by these functions +is stored in the process object. When this function returns the +process has not started to run yet so it is possible to override +the sentinel and filter. + +After the process returns, `magit-process-sentinel' refreshes the +buffer that was current when `magit-start-process' was called (if +it is a Magit buffer and still alive), as well as the respective +Magit status buffer." + (pcase-let* + ((`(,process-buf . ,section) + (magit-process-setup program args)) + (process + (let ((process-connection-type + ;; Don't use a pty, because it would set icrnl + ;; which would modify the input (issue #20). + (and (not input) magit-process-connection-type)) + (process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system))) + (apply #'start-file-process + (file-name-nondirectory program) + process-buf program args)))) + (with-editor-set-process-filter process #'magit-process-filter) + (set-process-sentinel process #'magit-process-sentinel) + (set-process-buffer process process-buf) + (when (eq system-type 'windows-nt) + ;; On w32, git expects UTF-8 encoded input, ignore any user + ;; configuration telling us otherwise. + (set-process-coding-system process 'utf-8-unix)) + (process-put process 'section section) + (process-put process 'command-buf (current-buffer)) + (process-put process 'default-dir default-directory) + (when inhibit-magit-refresh + (process-put process 'inhibit-refresh t)) + (oset section process process) + (with-current-buffer process-buf + (set-marker (process-mark process) (point))) + (when input + (with-current-buffer input + (process-send-region process (point-min) (point-max)) + (process-send-eof process))) + (setq magit-this-process process) + (oset section value process) + (magit-process-display-buffer process) + process)) + +(defun magit-parse-git-async (&rest args) + (setq args (magit-process-git-arguments args)) + (let ((command-buf (current-buffer)) + (process-buf (generate-new-buffer " *temp*")) + (toplevel (magit-toplevel))) + (with-current-buffer process-buf + (setq default-directory toplevel) + (let ((process + (let ((process-connection-type nil) + (process-environment (magit-process-environment)) + (default-process-coding-system + (magit--process-coding-system))) + (apply #'start-file-process "git" process-buf + magit-git-executable args)))) + (process-put process 'command-buf command-buf) + (process-put process 'parsed (point)) + (setq magit-this-process process) + process)))) + +;;; Process Internals + +(defun magit-process-setup (program args) + (magit-process-set-mode-line program args) + (let ((pwd default-directory) + (buf (magit-process-buffer t))) + (cons buf (with-current-buffer buf + (prog1 (magit-process-insert-section pwd program args nil nil) + (backward-char 1)))))) + +(defun magit-process-insert-section (pwd program args &optional errcode errlog) + (let ((inhibit-read-only t) + (magit-insert-section--parent magit-root-section) + (magit-insert-section--oldroot nil)) + (goto-char (1- (point-max))) + (magit-insert-section (process) + (insert (if errcode + (format "%3s " (propertize (number-to-string errcode) + 'font-lock-face 'magit-process-ng)) + "run ")) + (unless (equal (expand-file-name pwd) + (expand-file-name default-directory)) + (insert (file-relative-name pwd default-directory) ?\s)) + (cond + ((and args (equal program magit-git-executable)) + (setq args (-split-at (length magit-git-global-arguments) args)) + (insert (propertize (file-name-nondirectory program) + 'font-lock-face 'magit-section-heading) " ") + (insert (propertize (char-to-string magit-ellipsis) + 'font-lock-face 'magit-section-heading + 'help-echo (mapconcat #'identity (car args) " "))) + (insert " ") + (insert (propertize (mapconcat #'shell-quote-argument (cadr args) " ") + 'font-lock-face 'magit-section-heading))) + ((and args (equal program shell-file-name)) + (insert (propertize (cadr args) + 'font-lock-face 'magit-section-heading))) + (t + (insert (propertize (file-name-nondirectory program) + 'font-lock-face 'magit-section-heading) " ") + (insert (propertize (mapconcat #'shell-quote-argument args " ") + 'font-lock-face 'magit-section-heading)))) + (magit-insert-heading) + (when errlog + (if (bufferp errlog) + (insert (with-current-buffer errlog + (buffer-substring-no-properties (point-min) (point-max)))) + (insert-file-contents errlog) + (goto-char (1- (point-max))))) + (insert "\n")))) + +(defun magit-process-truncate-log () + (let* ((head nil) + (tail (oref magit-root-section children)) + (count (length tail))) + (when (> (1+ count) magit-process-log-max) + (while (and (cdr tail) + (> count (/ magit-process-log-max 2))) + (let* ((inhibit-read-only t) + (section (car tail)) + (process (oref section process))) + (cond ((not process)) + ((memq (process-status process) '(exit signal)) + (delete-region (oref section start) + (1+ (oref section end))) + (cl-decf count)) + (t + (push section head)))) + (pop tail)) + (oset magit-root-section children + (nconc (reverse head) tail))))) + +(defun magit-process-sentinel (process event) + "Default sentinel used by `magit-start-process'." + (when (memq (process-status process) '(exit signal)) + (setq event (substring event 0 -1)) + (when (string-match "^finished" event) + (message (concat (capitalize (process-name process)) " finished"))) + (magit-process-finish process) + (when (eq process magit-this-process) + (setq magit-this-process nil)) + (unless (process-get process 'inhibit-refresh) + (let ((command-buf (process-get process 'command-buf))) + (if (buffer-live-p command-buf) + (with-current-buffer command-buf + (magit-refresh)) + (with-temp-buffer + (setq default-directory (process-get process 'default-dir)) + (magit-refresh))))))) + +(defun magit-sequencer-process-sentinel (process event) + "Special sentinel used by `magit-run-git-sequencer'." + (when (memq (process-status process) '(exit signal)) + (magit-process-sentinel process event) + (when-let ((process-buf (process-buffer process))) + (when (buffer-live-p process-buf) + (when-let ((status-buf (with-current-buffer process-buf + (magit-get-mode-buffer 'magit-status-mode)))) + (with-current-buffer status-buf + (--when-let + (magit-get-section + `((commit . ,(magit-rev-parse "HEAD")) + (,(pcase (car (cadr (-split-at + (1+ (length magit-git-global-arguments)) + (process-command process)))) + ((or "rebase" "am") 'rebase-sequence) + ((or "cherry-pick" "revert") 'sequence))) + (status))) + (goto-char (oref it start)) + (magit-section-update-highlight)))))))) + +(defun magit-process-filter (proc string) + "Default filter used by `magit-start-process'." + (with-current-buffer (process-buffer proc) + (let ((inhibit-read-only t)) + (goto-char (process-mark proc)) + ;; Find last ^M in string. If one was found, ignore + ;; everything before it and delete the current line. + (when-let ((ret-pos (cl-position ?\r string :from-end t))) + (cl-callf substring string (1+ ret-pos)) + (delete-region (line-beginning-position) (point))) + (insert (propertize string 'magit-section + (process-get proc 'section))) + (set-marker (process-mark proc) (point)) + ;; Make sure prompts are matched after removing ^M. + (magit-process-yes-or-no-prompt proc string) + (magit-process-username-prompt proc string) + (magit-process-password-prompt proc string) + (run-hook-with-args-until-success 'magit-process-prompt-functions + proc string)))) + +(defmacro magit-process-kill-on-abort (proc &rest body) + (declare (indent 1) (debug (form body))) + (let ((map (cl-gensym))) + `(let ((,map (make-sparse-keymap))) + (set-keymap-parent ,map minibuffer-local-map) + (define-key ,map "\C-g" + (lambda () + (interactive) + (ignore-errors (kill-process ,proc)) + (abort-recursive-edit))) + (let ((minibuffer-local-map ,map)) + ,@body)))) + +(defun magit-process-yes-or-no-prompt (process string) + "Forward Yes-or-No prompts to the user." + (when-let ((beg (string-match magit-process-yes-or-no-prompt-regexp string))) + (let ((max-mini-window-height 30)) + (process-send-string + process + (downcase + (concat + (match-string + (if (save-match-data + (magit-process-kill-on-abort process + (yes-or-no-p (substring string 0 beg)))) 1 2) + string) + "\n")))))) + +(defun magit-process-password-auth-source (key) + "Use `auth-source-search' to get a password. +If found, return the password. Otherwise, return nil. + +To use this function add it to the appropriate hook + (add-hook 'magit-process-find-password-functions + 'magit-process-password-auth-source) + +KEY typically derives from a prompt such as: + Password for 'https://tarsius@bitbucket.org' +in which case it would be the string + tarsius@bitbucket.org +which matches the ~/.authinfo.gpg entry + machine bitbucket.org login tarsius password 12345 +or iff that is undefined, for backward compatibility + machine tarsius@bitbucket.org password 12345" + (require 'auth-source) + (and (string-match "\\`\\(.+\\)@\\([^@]+\\)\\'" key) + (let* ((user (match-string 1 key)) + (host (match-string 2 key)) + (secret + (plist-get + (car (or (auth-source-search :max 1 :host host :user user) + (auth-source-search :max 1 :host key))) + :secret))) + (if (functionp secret) + (funcall secret) + secret)))) + +(defun magit-process-password-prompt (process string) + "Find a password based on prompt STRING and send it to git. +Use `magit-process-password-prompt-regexps' to find a known +prompt. If and only if one is found, then call functions in +`magit-process-find-password-functions' until one of them returns +the password. If all function return nil, then read the password +from the user." + (when-let ((prompt (magit-process-match-prompt + magit-process-password-prompt-regexps string))) + (process-send-string + process (magit-process-kill-on-abort process + (concat (or (when-let ((key (match-string 99 string))) + (run-hook-with-args-until-success + 'magit-process-find-password-functions key)) + (read-passwd prompt)) + "\n"))))) + +(defun magit-process-username-prompt (process string) + "Forward username prompts to the user." + (--when-let (magit-process-match-prompt + magit-process-username-prompt-regexps string) + (process-send-string + process (magit-process-kill-on-abort process + (concat (read-string it nil nil (user-login-name)) "\n"))))) + +(defun magit-process-match-prompt (prompts string) + "Match STRING against PROMPTS and set match data. +Return the matched string suffixed with \": \", if needed." + (when (--any-p (string-match it string) prompts) + (let ((prompt (match-string 0 string))) + (cond ((string-suffix-p ": " prompt) prompt) + ((string-suffix-p ":" prompt) (concat prompt " ")) + (t (concat prompt ": ")))))) + +(defun magit--process-coding-system () + (let ((fro (or magit-git-output-coding-system + (car default-process-coding-system))) + (to (cdr default-process-coding-system))) + (if magit-process-ensure-unix-line-ending + (cons (coding-system-change-eol-conversion fro 'unix) + (coding-system-change-eol-conversion to 'unix)) + (cons fro to)))) + +(defvar magit-credential-hook nil + "Hook run before Git needs credentials.") + +(defvar magit-credential-cache-daemon-process nil) + +(defun magit-maybe-start-credential-cache-daemon () + "Maybe start a `git-credential-cache--daemon' process. + +If such a process is already running or if the value of option +`magit-credential-cache-daemon-socket' is nil, then do nothing. +Otherwise start the process passing the value of that options +as argument." + (unless (or (not magit-credential-cache-daemon-socket) + (process-live-p magit-credential-cache-daemon-process) + (memq magit-credential-cache-daemon-process + (list-system-processes))) + (setq magit-credential-cache-daemon-process + (or (--first (let* ((attr (process-attributes it)) + (comm (cdr (assq 'comm attr))) + (user (cdr (assq 'user attr)))) + (and (string= comm "git-credential-cache--daemon") + (string= user user-login-name))) + (list-system-processes)) + (condition-case nil + (start-process "git-credential-cache--daemon" + " *git-credential-cache--daemon*" + magit-git-executable + "credential-cache--daemon" + magit-credential-cache-daemon-socket) + ;; Some Git implementations (e.g. Windows) won't have + ;; this program; if we fail the first time, stop trying. + ((debug error) + (remove-hook 'magit-credential-hook + #'magit-maybe-start-credential-cache-daemon))))))) + +(add-hook 'magit-credential-hook #'magit-maybe-start-credential-cache-daemon) + +(defun tramp-sh-handle-start-file-process--magit-tramp-process-environment + (fn name buffer program &rest args) + (if magit-tramp-process-environment + (apply fn name buffer + (car magit-tramp-process-environment) + (append (cdr magit-tramp-process-environment) + (cons program args))) + (apply fn name buffer program args))) + +(advice-add 'tramp-sh-handle-start-file-process :around + 'tramp-sh-handle-start-file-process--magit-tramp-process-environment) + +(defun tramp-sh-handle-process-file--magit-tramp-process-environment + (fn program &optional infile destination display &rest args) + (if magit-tramp-process-environment + (apply fn "env" infile destination display + (append magit-tramp-process-environment + (cons program args))) + (apply fn program infile destination display args))) + +(advice-add 'tramp-sh-handle-process-file :around + 'tramp-sh-handle-process-file--magit-tramp-process-environment) + +(defvar magit-mode-line-process-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd " ") + 'magit-process-buffer) + map) + "Keymap for `mode-line-process'.") + +(defun magit-process-set-mode-line (program args) + "Display the git command (sans arguments) in the mode line." + (when (equal program magit-git-executable) + (setq args (nthcdr (length magit-git-global-arguments) args))) + (let ((str (concat " " (propertize + (concat (file-name-nondirectory program) + (and args (concat " " (car args)))) + 'mouse-face 'highlight + 'keymap magit-mode-line-process-map + 'help-echo "mouse-1: Show process buffer" + 'font-lock-face 'magit-mode-line-process)))) + (magit-repository-local-set 'mode-line-process str) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf + (setq mode-line-process str))) + (force-mode-line-update t))) + +(defun magit-process-set-mode-line-error-status (&optional error str) + "Apply an error face to the string set by `magit-process-set-mode-line'. + +If ERROR is supplied, include it in the `mode-line-process' tooltip. + +If STR is supplied, it replaces the `mode-line-process' text." + (setq str (or str (magit-repository-local-get 'mode-line-process))) + (when str + (setq error (format "%smouse-1: Show process buffer" + (if (stringp error) + (concat error "\n\n") + ""))) + (setq str (concat " " (propertize + (substring-no-properties str 1) + 'mouse-face 'highlight + 'keymap magit-mode-line-process-map + 'help-echo error + 'font-lock-face 'magit-mode-line-process-error))) + (magit-repository-local-set 'mode-line-process str) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf + (setq mode-line-process str))) + (force-mode-line-update t) + ;; We remove any error status from the mode line when a magit + ;; buffer is refreshed (see `magit-refresh-buffer'), but we must + ;; ensure that we ignore any refreshes during the remainder of the + ;; current command -- otherwise a newly-set error status would be + ;; removed before it was seen. We set a flag which prevents the + ;; status from being removed prior to the next command, so that + ;; the error status is guaranteed to remain visible until then. + (let ((repokey (magit-repository-local-repository))) + ;; The following closure captures the repokey value, and is + ;; added to `pre-command-hook'. + (cl-labels ((enable-magit-process-unset-mode-line + () ;; Remove ourself from the hook variable, so + ;; that we only run once. + (remove-hook 'pre-command-hook + #'enable-magit-process-unset-mode-line) + ;; Clear the inhibit flag for the repository in + ;; which we set it. + (magit-repository-local-set + 'inhibit-magit-process-unset-mode-line nil repokey))) + ;; Set the inhibit flag until the next command is invoked. + (magit-repository-local-set + 'inhibit-magit-process-unset-mode-line t repokey) + (add-hook 'pre-command-hook + #'enable-magit-process-unset-mode-line))))) + +(defun magit-process-unset-mode-line-error-status () + "Remove any current error status from the mode line." + (let ((status (or mode-line-process + (magit-repository-local-get 'mode-line-process)))) + (when (and status + (eq (get-text-property 1 'font-lock-face status) + 'magit-mode-line-process-error)) + (magit-process-unset-mode-line)))) + +(defun magit-process-unset-mode-line (&optional directory) + "Remove the git command from the mode line." + (let ((default-directory (or directory default-directory))) + (unless (magit-repository-local-get 'inhibit-magit-process-unset-mode-line) + (magit-repository-local-set 'mode-line-process nil) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf (setq mode-line-process nil))) + (force-mode-line-update t)))) + +(defvar magit-process-error-message-regexps + (list "^\\*ERROR\\*: Canceled by user$" + "^\\(?:error\\|fatal\\|git\\): \\(.*\\)$" + "^\\(Cannot rebase:.*\\)$")) + +(define-error 'magit-git-error "Git error") + +(defun magit-process-error-summary (process-buf section) + "A one-line error summary from the given SECTION." + (or (and (buffer-live-p process-buf) + (with-current-buffer process-buf + (and (oref section content) + (save-excursion + (goto-char (oref section end)) + (run-hook-wrapped + 'magit-process-error-message-regexps + (lambda (re) + (save-excursion + (and (re-search-backward + re (oref section start) t) + (or (match-string-no-properties 1) + (and (not magit-process-raise-error) + 'suppressed)))))))))) + "Git failed")) + +(defun magit-process-error-tooltip (process-buf section) + "Returns the text from SECTION of the PROCESS-BUF buffer. + +Limited by `magit-process-error-tooltip-max-lines'." + (and (integerp magit-process-error-tooltip-max-lines) + (> magit-process-error-tooltip-max-lines 0) + (buffer-live-p process-buf) + (with-current-buffer process-buf + (save-excursion + (goto-char (or (oref section content) + (oref section start))) + (buffer-substring-no-properties + (point) + (save-excursion + (forward-line magit-process-error-tooltip-max-lines) + (goto-char + (if (> (point) (oref section end)) + (oref section end) + (point))) + ;; Remove any trailing whitespace. + (when (re-search-backward "[^[:space:]\n]" + (oref section start) t) + (forward-char 1)) + (point))))))) + +(defvar-local magit-this-error nil) + +(defvar magit-process-finish-apply-ansi-colors nil) + +(defun magit-process-finish (arg &optional process-buf command-buf + default-dir section) + (unless (integerp arg) + (setq process-buf (process-buffer arg)) + (setq command-buf (process-get arg 'command-buf)) + (setq default-dir (process-get arg 'default-dir)) + (setq section (process-get arg 'section)) + (setq arg (process-exit-status arg))) + (when (fboundp 'dired-uncache) + (dired-uncache default-dir)) + (when (buffer-live-p process-buf) + (with-current-buffer process-buf + (let ((inhibit-read-only t) + (marker (oref section start))) + (goto-char marker) + (save-excursion + (delete-char 3) + (set-marker-insertion-type marker nil) + (insert (propertize (format "%3s" arg) + 'magit-section section + 'font-lock-face (if (= arg 0) + 'magit-process-ok + 'magit-process-ng))) + (set-marker-insertion-type marker t)) + (when magit-process-finish-apply-ansi-colors + (ansi-color-apply-on-region (oref section content) + (oref section end))) + (if (= (oref section end) + (+ (line-end-position) 2)) + (save-excursion + (goto-char (1+ (line-end-position))) + (delete-char -1) + (oset section content nil)) + (let ((buf (magit-process-buffer t))) + (when (and (= arg 0) + (not (--any-p (eq (window-buffer it) buf) + (window-list)))) + (magit-section-hide section))))))) + (if (= arg 0) + ;; Unset the `mode-line-process' value upon success. + (magit-process-unset-mode-line default-dir) + ;; Otherwise process the error. + (let ((msg (magit-process-error-summary process-buf section))) + ;; Change `mode-line-process' to an error face upon failure. + (if magit-process-display-mode-line-error + (magit-process-set-mode-line-error-status + (or (magit-process-error-tooltip process-buf section) + msg)) + (magit-process-unset-mode-line default-dir)) + ;; Either signal the error, or else display the error summary in + ;; the status buffer and with a message in the echo area. + (cond + (magit-process-raise-error + (signal 'magit-git-error (list (format "%s (in %s)" msg default-dir)))) + ((not (eq msg 'suppressed)) + (when (buffer-live-p process-buf) + (with-current-buffer process-buf + (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) + (with-current-buffer status-buf + (setq magit-this-error msg))))) + (message "%s ... [%s buffer %s for details]" msg + (if-let ((key (and (buffer-live-p command-buf) + (with-current-buffer command-buf + (car (where-is-internal + 'magit-process-buffer)))))) + (format "Hit %s to see" (key-description key)) + "See") + (buffer-name process-buf)))))) + arg) + +(defun magit-process-display-buffer (process) + (when (process-live-p process) + (let ((buf (process-buffer process))) + (cond ((not (buffer-live-p buf))) + ((= magit-process-popup-time 0) + (if (minibufferp) + (switch-to-buffer-other-window buf) + (pop-to-buffer buf))) + ((> magit-process-popup-time 0) + (run-with-timer magit-process-popup-time nil + (lambda (p) + (when (eq (process-status p) 'run) + (let ((buf (process-buffer p))) + (when (buffer-live-p buf) + (if (minibufferp) + (switch-to-buffer-other-window buf) + (pop-to-buffer buf)))))) + process)))))) + +(defun magit--log-action (summary line list) + (let (heading lines) + (if (cdr list) + (progn (setq heading (funcall summary list)) + (setq lines (mapcar line list))) + (setq heading (funcall line (car list)))) + (with-current-buffer (magit-process-buffer t) + (goto-char (1- (point-max))) + (let ((inhibit-read-only t)) + (magit-insert-section (message) + (magit-insert-heading (concat " * " heading)) + (when lines + (dolist (line lines) + (insert line "\n")) + (insert "\n")))) + (let ((inhibit-message t)) + (when heading + (setq lines (cons heading lines))) + (message (mapconcat #'identity lines "\n")))))) + +;;; _ +(provide 'magit-process) +;;; magit-process.el ends here diff --git a/elpa/magit-20200318.1224/magit-process.elc b/elpa/magit-20200318.1224/magit-process.elc new file mode 100644 index 00000000..18c4d6b0 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-process.elc differ diff --git a/elpa/magit-20200318.1224/magit-pull.el b/elpa/magit-20200318.1224/magit-pull.el new file mode 100644 index 00000000..33b2bf9f --- /dev/null +++ b/elpa/magit-20200318.1224/magit-pull.el @@ -0,0 +1,164 @@ +;;; magit-pull.el --- update local objects and refs -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements pull commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-pull-or-fetch nil + "Whether `magit-pull' also offers some fetch suffixes." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +;;; Commands + +;;;###autoload (autoload 'magit-pull "magit-pull" nil t) +(define-transient-command magit-pull () + "Pull from another repository." + :man-page "git-pull" + [:description + (lambda () (if magit-pull-or-fetch "Pull arguments" "Arguments")) + ("-r" "Rebase local commits" ("-r" "--rebase")) + ("-A" "Autostash" "--autostash" :level 7)] + [:description + (lambda () + (if-let ((branch (magit-get-current-branch))) + (concat + (propertize "Pull into " 'face 'transient-heading) + (propertize branch 'face 'magit-branch-local) + (propertize " from" 'face 'transient-heading)) + (propertize "Pull from" 'face 'transient-heading))) + ("p" magit-pull-from-pushremote) + ("u" magit-pull-from-upstream) + ("e" "elsewhere" magit-pull-branch)] + ["Fetch from" + :if-non-nil magit-pull-or-fetch + ("f" "remotes" magit-fetch-all-no-prune) + ("F" "remotes and prune" magit-fetch-all-prune)] + ["Fetch" + :if-non-nil magit-pull-or-fetch + ("o" "another branch" magit-fetch-branch) + ("s" "explicit refspec" magit-fetch-refspec) + ("m" "submodules" magit-fetch-modules)] + ["Configure" + ("r" magit-branch..rebase :if magit-get-current-branch) + ("C" "variables..." magit-branch-configure)] + (interactive) + (transient-setup 'magit-pull nil nil :scope (magit-get-current-branch))) + +(defun magit-pull-arguments () + (transient-args 'magit-pull)) + +;;;###autoload (autoload 'magit-pull-from-pushremote "magit-pull" nil t) +(define-suffix-command magit-pull-from-pushremote (args) + "Pull from the push-remote of the current branch. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :if 'magit-get-current-branch + :description 'magit-pull--pushbranch-description + (interactive (list (magit-pull-arguments))) + (pcase-let ((`(,branch ,remote) + (magit--select-push-remote "pull from there"))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "pull" args remote branch))) + +(defun magit-pull--pushbranch-description () + ;; Also used by `magit-rebase-onto-pushremote'. + (let* ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch t)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + (target) + ((member remote (magit-list-remotes)) + (format "%s, replacing non-existent" v)) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-pull-from-upstream "magit-pull" nil t) +(define-suffix-command magit-pull-from-upstream (args) + "Pull from the upstream of the current branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if 'magit-get-current-branch + :description 'magit-pull--upstream-description + (interactive (list (magit-pull-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (when (or current-prefix-arg + (not (or (magit-get-upstream-branch branch) + (magit--unnamed-upstream-p remote merge)))) + (magit-set-upstream-branch + branch (magit-read-upstream-branch + branch (format "Set upstream of %s and pull from there" branch))) + (setq remote (magit-get "branch" branch "remote")) + (setq merge (magit-get "branch" branch "merge"))) + (run-hooks 'magit-credential-hook) + (magit-run-git-with-editor "pull" args remote merge))) + +(defun magit-pull--upstream-description () + (when-let ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (format "%s of %s" + (magit--propertize-face merge 'magit-branch-remote) + (magit--propertize-face remote 'bold))) + ((magit--valid-upstream-p remote merge) + (concat u ", replacing non-existent")) + ((or remote merge) + (concat u ", replacing invalid")) + (t + (concat u ", setting that"))))))) + +;;;###autoload +(defun magit-pull-branch (source args) + "Pull from a branch read in the minibuffer." + (interactive (list (magit-read-remote-branch "Pull" nil nil nil t) + (magit-pull-arguments))) + (run-hooks 'magit-credential-hook) + (pcase-let ((`(,remote . ,branch) + (magit-get-tracked source))) + (magit-run-git-with-editor "pull" args remote branch))) + +;;; _ +(provide 'magit-pull) +;;; magit-pull.el ends here diff --git a/elpa/magit-20200318.1224/magit-pull.elc b/elpa/magit-20200318.1224/magit-pull.elc new file mode 100644 index 00000000..42663d63 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-pull.elc differ diff --git a/elpa/magit-20200318.1224/magit-push.el b/elpa/magit-20200318.1224/magit-push.el new file mode 100644 index 00000000..910c5141 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-push.el @@ -0,0 +1,331 @@ +;;; magit-push.el --- update remote objects and refs -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements push commands. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-push "magit-push" nil t) +(define-transient-command magit-push () + "Push to another repository." + :man-page "git-push" + ["Arguments" + ("-f" "Force with lease" (nil "--force-with-lease")) + ("-F" "Force" ("-f" "--force")) + ("-h" "Disable hooks" "--no-verify") + ("-n" "Dry run" ("-n" "--dry-run")) + (5 "-u" "Set upstream" "--set-upstream") + (7 "-t" "Follow tags" "--follow-tags")] + [:if magit-get-current-branch + :description (lambda () + (format (propertize "Push %s to" 'face 'transient-heading) + (propertize (magit-get-current-branch) + 'face 'magit-branch-local))) + ("p" magit-push-current-to-pushremote) + ("u" magit-push-current-to-upstream) + ("e" "elsewhere" magit-push-current)] + ["Push" + [("o" "another branch" magit-push-other) + ("r" "explicit refspecs" magit-push-refspecs) + ("m" "matching branches" magit-push-matching)] + [("T" "a tag" magit-push-tag) + ("t" "all tags" magit-push-tags) + (6 "n" "a note ref" magit-push-notes-ref)]] + ["Configure" + ("C" "Set variables..." magit-branch-configure)]) + +(defun magit-push-arguments () + (transient-args 'magit-push)) + +(defun magit-git-push (branch target args) + (run-hooks 'magit-credential-hook) + ;; If the remote branch already exists, then we do not have to + ;; qualify the target, which we prefer to avoid doing because + ;; using the default namespace is wrong in obscure cases. + (pcase-let ((namespace (if (magit-get-tracked target) "" "refs/heads/")) + (`(,remote . ,target) + (magit-split-branch-name target))) + (magit-run-git-async "push" "-v" args remote + (format "%s:%s%s" branch namespace target)))) + +;;;###autoload (autoload 'magit-push-current-to-pushremote "magit-push" nil t) +(define-suffix-command magit-push-current-to-pushremote (args) + "Push the current branch to its push-remote. + +When the push-remote is not configured, then read the push-remote +from the user, set it, and then push to it. With a prefix +argument the push-remote can be changed before pushed to it." + :if 'magit-get-current-branch + :description 'magit-push--pushbranch-description + (interactive (list (magit-push-arguments))) + (pcase-let ((`(,branch ,remote) + (magit--select-push-remote "push there"))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote + (format "refs/heads/%s:refs/heads/%s" + branch branch)))) ; see #3847 and #3872 + +(defun magit-push--pushbranch-description () + (let* ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch t)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + (target) + ((member remote (magit-list-remotes)) + (format "%s, creating it" + (magit--propertize-face (concat remote "/" branch) + 'magit-branch-remote))) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-push-current-to-upstream "magit-push" nil t) +(define-suffix-command magit-push-current-to-upstream (args) + "Push the current branch to its upstream branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if 'magit-get-current-branch + :description 'magit-push--upstream-description + (interactive (list (magit-push-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (when (or current-prefix-arg + (not (or (magit-get-upstream-branch branch) + (magit--unnamed-upstream-p remote merge) + (magit--valid-upstream-p remote merge)))) + (let* ((branches (-union (--map (concat it "/" branch) + (magit-list-remotes)) + (magit-list-remote-branch-names))) + (upstream (magit-completing-read + (format "Set upstream of %s and push there" branch) + branches nil nil nil 'magit-revision-history + (or (car (member (magit-remote-branch-at-point) branches)) + (car (member "origin/master" branches))))) + (upstream (or (magit-get-tracked upstream) + (magit-split-branch-name upstream)))) + (setq remote (car upstream)) + (setq merge (cdr upstream)) + (unless (string-prefix-p "refs/" merge) + ;; User selected a non-existent remote-tracking branch. + ;; It is very likely, but not certain, that this is the + ;; correct thing to do. It is even more likely that it + ;; is what the user wants to happen. + (setq merge (concat "refs/heads/" merge)))) + (cl-pushnew "--set-upstream" args :test #'equal)) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote (concat branch ":" merge)))) + +(defun magit-push--upstream-description () + (when-let ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (format "%s as %s" + (magit--propertize-face remote 'bold) + (magit--propertize-face merge 'magit-branch-remote))) + ((magit--valid-upstream-p remote merge) + (format "%s creating %s" + (magit--propertize-face remote 'magit-branch-remote) + (magit--propertize-face merge 'magit-branch-remote))) + ((or remote merge) + (concat u ", creating it and replacing invalid")) + (t + (concat u ", creating it"))))))) + +;;;###autoload +(defun magit-push-current (target args) + "Push the current branch to a branch read in the minibuffer." + (interactive + (--if-let (magit-get-current-branch) + (list (magit-read-remote-branch (format "Push %s to" it) + nil nil it 'confirm) + (magit-push-arguments)) + (user-error "No branch is checked out"))) + (magit-git-push (magit-get-current-branch) target args)) + +;;;###autoload +(defun magit-push-other (source target args) + "Push an arbitrary branch or commit somewhere. +Both the source and the target are read in the minibuffer." + (interactive + (let ((source (magit-read-local-branch-or-commit "Push"))) + (list source + (magit-read-remote-branch + (format "Push %s to" source) nil + (if (magit-local-branch-p source) + (or (magit-get-push-branch source) + (magit-get-upstream-branch source)) + (and (magit-rev-ancestor-p source "HEAD") + (or (magit-get-push-branch) + (magit-get-upstream-branch)))) + source 'confirm) + (magit-push-arguments)))) + (magit-git-push source target args)) + +(defvar magit-push-refspecs-history nil) + +;;;###autoload +(defun magit-push-refspecs (remote refspecs args) + "Push one or multiple REFSPECS to a REMOTE. +Both the REMOTE and the REFSPECS are read in the minibuffer. To +use multiple REFSPECS, separate them with commas. Completion is +only available for the part before the colon, or when no colon +is used." + (interactive + (list (magit-read-remote "Push to remote") + (split-string (magit-completing-read-multiple + "Push refspec,s" + (cons "HEAD" (magit-list-local-branch-names)) + nil nil 'magit-push-refspecs-history) + crm-default-separator t) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote refspecs)) + +;;;###autoload +(defun magit-push-matching (remote &optional args) + "Push all matching branches to another repository. +If multiple remotes exist, then read one from the user. +If just one exists, use that without requiring confirmation." + (interactive (list (magit-read-remote "Push matching branches to" nil t) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote ":")) + +;;;###autoload +(defun magit-push-tags (remote &optional args) + "Push all tags to another repository. +If only one remote exists, then push to that. Otherwise prompt +for a remote, offering the remote configured for the current +branch as default." + (interactive (list (magit-read-remote "Push tags to remote" nil t) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote "--tags" args)) + +;;;###autoload +(defun magit-push-tag (tag remote &optional args) + "Push a tag to another repository." + (interactive + (let ((tag (magit-read-tag "Push tag"))) + (list tag (magit-read-remote (format "Push %s to remote" tag) nil t) + (magit-push-arguments)))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote tag args)) + +;;;###autoload +(defun magit-push-notes-ref (ref remote &optional args) + "Push a notes ref to another repository." + (interactive + (let ((note (magit-notes-read-ref "Push notes" nil nil))) + (list note + (magit-read-remote (format "Push %s to remote" note) nil t) + (magit-push-arguments)))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote ref args)) + +;;;###autoload +(defun magit-push-implicitly (args) + "Push somewhere without using an explicit refspec. + +This command simply runs \"git push -v [ARGS]\". ARGS are the +arguments specified in the popup buffer. No explicit refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'. + +The function `magit-push-implicitly--desc' attempts to predict +what this command will do. The value it returns is displayed in +the popup buffer." + (interactive (list (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args)) + +(defun magit-push-implicitly--desc () + (let ((default (magit-get "push.default"))) + (unless (equal default "nothing") + (or (when-let ((remote (or (magit-get-remote) + (magit-remote-p "origin"))) + (refspec (magit-get "remote" remote "push"))) + (format "%s using %s" + (magit--propertize-face remote 'magit-branch-remote) + (magit--propertize-face refspec 'bold))) + (--when-let (and (not (magit-get-push-branch)) + (magit-get-upstream-branch)) + (format "%s aka %s\n" + (magit-branch-set-face it) + (magit--propertize-face "@{upstream}" 'bold))) + (--when-let (magit-get-push-branch) + (format "%s aka %s\n" + (magit-branch-set-face it) + (magit--propertize-face "pushRemote" 'bold))) + (--when-let (magit-get-@{push}-branch) + (format "%s aka %s\n" + (magit-branch-set-face it) + (magit--propertize-face "@{push}" 'bold))) + (format "using %s (%s is %s)\n" + (magit--propertize-face "git push" 'bold) + (magit--propertize-face "push.default" 'bold) + (magit--propertize-face default 'bold)))))) + +;;;###autoload +(defun magit-push-to-remote (remote args) + "Push to REMOTE without using an explicit refspec. +The REMOTE is read in the minibuffer. + +This command simply runs \"git push -v [ARGS] REMOTE\". ARGS +are the arguments specified in the popup buffer. No refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'." + (interactive (list (magit-read-remote "Push to remote") + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote)) + +(defun magit-push-to-remote--desc () + (format "using %s\n" (magit--propertize-face "git push " 'bold))) + +;;; _ +(provide 'magit-push) +;;; magit-push.el ends here diff --git a/elpa/magit-20200318.1224/magit-push.elc b/elpa/magit-20200318.1224/magit-push.elc new file mode 100644 index 00000000..a1b60bae Binary files /dev/null and b/elpa/magit-20200318.1224/magit-push.elc differ diff --git a/elpa/magit-20200318.1224/magit-reflog.el b/elpa/magit-20200318.1224/magit-reflog.el new file mode 100644 index 00000000..5576cdc9 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-reflog.el @@ -0,0 +1,213 @@ +;;; magit-reflog.el --- inspect ref history -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for looking at Git reflogs. + +;;; Code: + +(require 'magit-core) +(require 'magit-log) + +(eval-when-compile + (require 'subr-x)) + +;;; Options + +(defcustom magit-reflog-limit 256 + "Maximal number of entries initially shown in reflog buffers. +The limit in the current buffer can be changed using \"+\" +and \"-\"." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'number) + +(defcustom magit-reflog-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-reflog-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-reflog-mode)) + +;;; Faces + +(defface magit-reflog-commit '((t :foreground "green")) + "Face for commit commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-amend '((t :foreground "magenta")) + "Face for amend commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-merge '((t :foreground "green")) + "Face for merge, checkout and branch commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-checkout '((t :foreground "blue")) + "Face for checkout commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-reset '((t :foreground "red")) + "Face for reset commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-rebase '((t :foreground "magenta")) + "Face for rebase commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-cherry-pick '((t :foreground "green")) + "Face for cherry-pick commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-remote '((t :foreground "cyan")) + "Face for pull and clone commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-other '((t :foreground "cyan")) + "Face for other commands in reflogs." + :group 'magit-faces) + +;;; Commands + +;;;###autoload +(defun magit-reflog-current () + "Display the reflog of the current branch. +If `HEAD' is detached, then show the reflog for that instead." + (interactive) + (magit-reflog-setup-buffer (or (magit-get-current-branch) "HEAD"))) + +;;;###autoload +(defun magit-reflog-other (ref) + "Display the reflog of a branch or another ref." + (interactive (list (magit-read-local-branch-or-ref "Show reflog for"))) + (magit-reflog-setup-buffer ref)) + +;;;###autoload +(defun magit-reflog-head () + "Display the `HEAD' reflog." + (interactive) + (magit-reflog-setup-buffer "HEAD")) + +;;; Mode + +(defvar magit-reflog-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-log-mode-map) + (define-key map "\C-c\C-n" 'undefined) + (define-key map "L" 'magit-margin-settings) + map) + "Keymap for `magit-reflog-mode'.") + +(define-derived-mode magit-reflog-mode magit-mode "Magit Reflog" + "Mode for looking at Git reflog. + +This mode is documented in info node `(magit)Reflog'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-reflog-mode-map}" + :group 'magit-log + (hack-dir-local-variables-non-file-buffer)) + +(defun magit-reflog-setup-buffer (ref) + (require 'magit) + (magit-setup-buffer #'magit-reflog-mode nil + (magit-buffer-refname ref) + (magit-buffer-log-args (list (format "-n%s" magit-reflog-limit))))) + +(defun magit-reflog-refresh-buffer () + (magit-set-header-line-format (concat "Reflog for " magit-buffer-refname)) + (magit-insert-section (reflogbuf) + (magit-git-wash (apply-partially 'magit-log-wash-log 'reflog) + "reflog" "show" "--format=%h%x00%aN%x00%gd%x00%gs" "--date=raw" + magit-buffer-log-args magit-buffer-refname "--"))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-reflog-mode)) + magit-buffer-refname) + +(defvar magit-reflog-labels + '(("commit" . magit-reflog-commit) + ("amend" . magit-reflog-amend) + ("merge" . magit-reflog-merge) + ("checkout" . magit-reflog-checkout) + ("branch" . magit-reflog-checkout) + ("reset" . magit-reflog-reset) + ("rebase" . magit-reflog-rebase) + ("cherry-pick" . magit-reflog-cherry-pick) + ("initial" . magit-reflog-commit) + ("pull" . magit-reflog-remote) + ("clone" . magit-reflog-remote) + ("autosave" . magit-reflog-commit) + ("restart" . magit-reflog-reset))) + +(defun magit-reflog-format-subject (subject) + (let* ((match (string-match magit-reflog-subject-re subject)) + (command (and match (match-string 1 subject))) + (option (and match (match-string 2 subject))) + (type (and match (match-string 3 subject))) + (label (if (string= command "commit") + (or type command) + command)) + (text (if (string= command "commit") + label + (mapconcat #'identity + (delq nil (list command option type)) + " ")))) + (format "%-16s " + (magit--propertize-face + text (or (cdr (assoc label magit-reflog-labels)) + 'magit-reflog-other))))) + +;;; _ +(provide 'magit-reflog) +;;; magit-reflog.el ends here diff --git a/elpa/magit-20200318.1224/magit-reflog.elc b/elpa/magit-20200318.1224/magit-reflog.elc new file mode 100644 index 00000000..e65752fb Binary files /dev/null and b/elpa/magit-20200318.1224/magit-reflog.elc differ diff --git a/elpa/magit-20200318.1224/magit-refs.el b/elpa/magit-20200318.1224/magit-refs.el new file mode 100644 index 00000000..34304a65 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-refs.el @@ -0,0 +1,758 @@ +;;; magit-refs.el --- listing references -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for listing references in a buffer. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Options + +(defgroup magit-refs nil + "Inspect and manipulate Git branches and tags." + :link '(info-link "(magit)References Buffer") + :group 'magit-modes) + +(defcustom magit-refs-mode-hook nil + "Hook run after entering Magit-Refs mode." + :package-version '(magit . "2.1.0") + :group 'magit-refs + :type 'hook) + +(defcustom magit-refs-sections-hook + '(magit-insert-error-header + magit-insert-branch-description + magit-insert-local-branches + magit-insert-remote-branches + magit-insert-tags) + "Hook run to insert sections into a references buffer." + :package-version '(magit . "2.1.0") + :group 'magit-refs + :type 'hook) + +(defcustom magit-refs-show-commit-count nil + "Whether to show commit counts in Magit-Refs mode buffers. + +all Show counts for branches and tags. +branch Show counts for branches only. +nil Never show counts. + +To change the value in an existing buffer use the command +`magit-refs-show-commit-count'" + :package-version '(magit . "2.1.0") + :group 'magit-refs + :safe (lambda (val) (memq val '(all branch nil))) + :type '(choice (const all :tag "For branches and tags") + (const branch :tag "For branches only") + (const nil :tag "Never"))) +(put 'magit-refs-show-commit-count 'safe-local-variable 'symbolp) +(put 'magit-refs-show-commit-count 'permanent-local t) + +(defcustom magit-refs-pad-commit-counts nil + "Whether to pad all counts on all sides in `magit-refs-mode' buffers. + +If this is nil, then some commit counts are displayed right next +to one of the branches that appear next to the count, without any +space in between. This might look bad if the branch name faces +look too similar to `magit-dimmed'. + +If this is non-nil, then spaces are placed on both sides of all +commit counts." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'boolean) + +(defvar magit-refs-show-push-remote nil + "Whether to show the push-remotes of local branches. +Also show the commits that the local branch is ahead and behind +the push-target. Unfortunately there is a bug in Git that makes +this useless (the commits ahead and behind the upstream are +shown), so this isn't enabled yet.") + +(defcustom magit-refs-show-remote-prefix nil + "Whether to show the remote prefix in lists of remote branches. + +This is redundant because the name of the remote is already shown +in the heading preceding the list of its branches." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'boolean) + +(defcustom magit-refs-margin + (list nil + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-refs-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-margin + :safe (lambda (val) (memq val '(all branch nil))) + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-refs-mode)) + +(defcustom magit-refs-margin-for-tags nil + "Whether to show information about tags in the margin. + +This is disabled by default because it is slow if there are many +tags." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-margin + :type 'boolean) + +(defcustom magit-refs-primary-column-width (cons 16 32) + "Width of the focus column in `magit-refs-mode' buffers. + +The primary column is the column that contains the name of the +branch that the current row is about. + +If this is an integer, then the column is that many columns wide. +Otherwise it has to be a cons-cell of two integers. The first +specifies the minimal width, the second the maximal width. In that +case the actual width is determined using the length of the names +of the shown local branches. (Remote branches and tags are not +taken into account when calculating to optimal width.)" + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type '(choice (integer :tag "Constant wide") + (cons :tag "Wide constrains" + (integer :tag "Minimum") + (integer :tag "Maximum")))) + +(defcustom magit-refs-focus-column-width 5 + "Width of the focus column in `magit-refs-mode' buffers. + +The focus column is the first column, which marks one +branch (usually the current branch) as the focused branch using +\"*\" or \"@\". For each other reference, this column optionally +shows how many commits it is ahead of the focused branch and \"<\", or +if it isn't ahead then the commits it is behind and \">\", or if it +isn't behind either, then a \"=\". + +This column may also display only \"*\" or \"@\" for the focused +branch, in which case this option is ignored. Use \"L v\" to +change the verbosity of this column." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'integer) + +(defcustom magit-refs-filter-alist nil + "Alist controlling which refs are omitted from `magit-refs-mode' buffers. + +The purpose of this option is to forgo displaying certain refs +based on their name. If you want to not display any refs of a +certain type, then you should remove the appropriate function +from `magit-refs-sections-hook' instead. + +All keys are tried in order until one matches. Then its value +is used and subsequent elements are ignored. If the value is +non-nil, then the reference is displayed, otherwise it is not. +If no element matches, then the reference is displayed. + +A key can either be a regular expression that the refname has to +match, or a function that takes the refname as only argument and +returns a boolean. A remote branch such as \"origin/master\" is +displayed as just \"master\", however for this comparison the +former is used." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type '(alist :key-type (choice :tag "Key" regexp function) + :value-type (boolean :tag "Value" + :on "show (non-nil)" + :off "omit (nil)"))) + +(defcustom magit-visit-ref-behavior nil + "Control how `magit-visit-ref' behaves in `magit-refs-mode' buffers. + +By default `magit-visit-ref' behaves like `magit-show-commit', +in all buffers, including `magit-refs-mode' buffers. When the +type of the section at point is `commit' then \"RET\" is bound to +`magit-show-commit', and when the type is either `branch' or +`tag' then it is bound to `magit-visit-ref'. + +\"RET\" is one of Magit's most essential keys and at least by +default it should behave consistently across all of Magit, +especially because users quickly learn that it does something +very harmless; it shows more information about the thing at point +in another buffer. + +However \"RET\" used to behave differently in `magit-refs-mode' +buffers, doing surprising things, some of which cannot really be +described as \"visit this thing\". If you have grown accustomed +to such inconsistent, but to you useful, behavior, then you can +restore that by adding one or more of the below symbols to the +value of this option. But keep in mind that by doing so you +don't only introduce inconsistencies, you also lose some +functionality and might have to resort to `M-x magit-show-commit' +to get it back. + +`magit-visit-ref' looks for these symbols in the order in which +they are described here. If the presence of a symbol applies to +the current situation, then the symbols that follow do not affect +the outcome. + +`focus-on-ref' + + With a prefix argument update the buffer to show commit counts + and lists of cherry commits relative to the reference at point + instead of relative to the current buffer or `HEAD'. + + Instead of adding this symbol, consider pressing \"C-u y o RET\". + +`create-branch' + + If point is on a remote branch, then create a new local branch + with the same name, use the remote branch as its upstream, and + then check out the local branch. + + Instead of adding this symbol, consider pressing \"b c RET RET\", + like you would do in other buffers. + +`checkout-any' + + Check out the reference at point. If that reference is a tag + or a remote branch, then this results in a detached `HEAD'. + + Instead of adding this symbol, consider pressing \"b b RET\", + like you would do in other buffers. + +`checkout-branch' + + Check out the local branch at point. + + Instead of adding this symbol, consider pressing \"b b RET\", + like you would do in other buffers." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-commands + :options '(focus-on-ref create-branch checkout-any checkout-branch) + :type '(list :convert-widget custom-hook-convert-widget)) + +;;; Mode + +(defvar magit-refs-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + (define-key map "\C-y" 'magit-refs-set-show-commit-count) + (define-key map "L" 'magit-margin-settings) + map) + "Keymap for `magit-refs-mode'.") + +(define-derived-mode magit-refs-mode magit-mode "Magit Refs" + "Mode which lists and compares references. + +This mode is documented in info node `(magit)References Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit or branch at point. + +Type \\[magit-branch] to see available branch commands. +Type \\[magit-merge] to merge the branch or commit at point. +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-refs-mode-map}" + :group 'magit-refs + (hack-dir-local-variables-non-file-buffer) + (setq imenu-create-index-function + #'magit-imenu--refs-create-index-function)) + +(defun magit-refs-setup-buffer (ref args) + (magit-setup-buffer #'magit-refs-mode nil + (magit-buffer-upstream ref) + (magit-buffer-arguments args))) + +(defun magit-refs-refresh-buffer () + (setq magit-set-buffer-margin-refresh (not (magit-buffer-margin-p))) + (unless (magit-rev-verify magit-buffer-upstream) + (setq magit-refs-show-commit-count nil)) + (magit-set-header-line-format + (format "%s %s" magit-buffer-upstream + (mapconcat #'identity magit-buffer-arguments " "))) + (magit-insert-section (branchbuf) + (magit-run-section-hook 'magit-refs-sections-hook)) + (add-hook 'kill-buffer-hook 'magit-preserve-section-visibility-cache)) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-refs-mode)) + (cons magit-buffer-upstream magit-buffer-arguments)) + +;;; Commands + +;;;###autoload (autoload 'magit-show-refs "magit-refs" nil t) +(define-transient-command magit-show-refs (&optional transient) + "List and compare references in a dedicated buffer." + :man-page "git-branch" + :value (lambda () + (magit-show-refs-arguments magit-prefix-use-buffer-arguments)) + ["Arguments" + (magit-for-each-ref:--contains) + ("=m" "Merged" "--merged=" magit-transient-read-revision) + ("-m" "Merged to HEAD" "--merged") + ("-M" "Merged to master" "--merged=master") + ("=n" "Not merged" "--no-merged=" magit-transient-read-revision) + ("-n" "Not merged to HEAD" "--no-merged") + ("-N" "Not merged to master" "--no-merged=master") + (magit-for-each-ref:--sort)] + ["Actions" + ("y" "Show refs, comparing them with HEAD" magit-show-refs-head) + ("c" "Show refs, comparing them with current branch" magit-show-refs-current) + ("o" "Show refs, comparing them with other branch" magit-show-refs-other)] + (interactive (list (or (derived-mode-p 'magit-refs-mode) + current-prefix-arg))) + (if transient + (transient-setup 'magit-show-refs) + (magit-refs-setup-buffer "HEAD" (magit-show-refs-arguments)))) + +(defun magit-show-refs-arguments (&optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args) + (cond + ((eq current-transient-command 'magit-show-refs) + (setq args (transient-args 'magit-show-refs))) + ((eq major-mode 'magit-refs-mode) + (setq args magit-buffer-arguments)) + ((and (memq use-buffer-args '(always selected)) + (when-let ((buffer (magit-get-mode-buffer + 'magit-refs-mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-arguments buffer)) + t))) + (t + (setq args (alist-get 'magit-show-refs transient-values)))) + args)) + +(define-infix-argument magit-for-each-ref:--contains () + :description "Contains" + :class 'transient-option + :key "-c" + :argument "--contains=" + :reader 'magit-transient-read-revision) + +(define-infix-argument magit-for-each-ref:--sort () + :description "Sort" + :class 'transient-option + :key "-s" + :argument "--sort=" + :reader 'magit-read-ref-sort) + +(defun magit-read-ref-sort (prompt initial-input _history) + (magit-completing-read prompt + '("-committerdate" "-authordate" + "committerdate" "authordate") + nil nil initial-input)) + +;;;###autoload +(defun magit-show-refs-head (&optional args) + "List and compare references in a dedicated buffer. +Compared with `HEAD'." + (interactive (list (magit-show-refs-arguments))) + (magit-refs-setup-buffer "HEAD" args)) + +;;;###autoload +(defun magit-show-refs-current (&optional args) + "List and compare references in a dedicated buffer. +Compare with the current branch or `HEAD' if it is detached." + (interactive (list (magit-show-refs-arguments))) + (magit-refs-setup-buffer (magit-get-current-branch) args)) + +;;;###autoload +(defun magit-show-refs-other (&optional ref args) + "List and compare references in a dedicated buffer. +Compared with a branch read from the user." + (interactive (list (magit-read-other-branch "Compare with") + (magit-show-refs-arguments))) + (magit-refs-setup-buffer ref args)) + +(defun magit-refs-set-show-commit-count () + "Change for which refs the commit count is shown." + (interactive) + (setq-local magit-refs-show-commit-count + (magit-read-char-case "Show commit counts for " nil + (?a "[a]ll refs" 'all) + (?b "[b]ranches only" t) + (?n "[n]othing" nil))) + (magit-refresh)) + +(defun magit-visit-ref () + "Visit the reference or revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision. + +This command behaves just like `magit-show-commit', except if +point is on a reference in a `magit-refs-mode' buffer (a buffer +listing branches and tags), in which case the behavior may be +different, but only if you have customized the option +`magit-visit-ref-behavior' (which see)." + (interactive) + (if (and (derived-mode-p 'magit-refs-mode) + (magit-section-match '(branch tag))) + (let ((ref (oref (magit-current-section) value))) + (cond (current-prefix-arg + (cond ((memq 'focus-on-ref magit-visit-ref-behavior) + (magit-refs-setup-buffer ref (magit-show-refs-arguments))) + (magit-visit-ref-behavior + ;; Don't prompt for commit to visit. + (let ((current-prefix-arg nil)) + (call-interactively #'magit-show-commit))))) + ((and (memq 'create-branch magit-visit-ref-behavior) + (magit-section-match [branch remote])) + (let ((branch (cdr (magit-split-branch-name ref)))) + (if (magit-branch-p branch) + (if (magit-rev-eq branch ref) + (magit-call-git "checkout" branch) + (setq branch (propertize branch 'face 'magit-branch-local)) + (setq ref (propertize ref 'face 'magit-branch-remote)) + (pcase (prog1 (read-char-choice (format (propertize "\ +Branch %s already exists. + [c]heckout %s as-is + [r]reset %s to %s and checkout %s + [a]bort " 'face 'minibuffer-prompt) branch branch branch ref branch) + '(?c ?r ?a)) + (message "")) ; otherwise prompt sticks + (?c (magit-call-git "checkout" branch)) + (?r (magit-call-git "checkout" "-B" branch ref)) + (?a (user-error "Abort")))) + (magit-call-git "checkout" "-b" branch ref)) + (setq magit-buffer-upstream branch) + (magit-refresh))) + ((or (memq 'checkout-any magit-visit-ref-behavior) + (and (memq 'checkout-branch magit-visit-ref-behavior) + (magit-section-match [branch local]))) + (magit-call-git "checkout" ref) + (setq magit-buffer-upstream ref) + (magit-refresh)) + (t + (call-interactively #'magit-show-commit)))) + (call-interactively #'magit-show-commit))) + +;;; Sections + +(defvar magit-remote-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-delete-thing] 'magit-remote-remove) + (define-key map "R" 'magit-remote-rename) + map) + "Keymap for `remote' sections.") + +(defvar magit-branch-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-visit-ref) + (define-key map [remap magit-delete-thing] 'magit-branch-delete) + (define-key map "R" 'magit-branch-rename) + map) + "Keymap for `branch' sections.") + +(defvar magit-tag-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-visit-ref) + (define-key map [remap magit-delete-thing] 'magit-tag-delete) + map) + "Keymap for `tag' sections.") + +(defun magit-insert-branch-description () + "Insert header containing the description of the current branch. +Insert a header line with the name and description of the +current branch. The description is taken from the Git variable +`branch..description'; if that is undefined then no header +line is inserted at all." + (when-let ((branch (magit-get-current-branch)) + (desc (magit-get "branch" branch "description")) + (desc (split-string desc "\n"))) + (when (equal (car (last desc)) "") + (setq desc (butlast desc))) + (magit-insert-section (branchdesc branch t) + (magit-insert-heading branch ": " (car desc)) + (when (cdr desc) + (insert (mapconcat 'identity (cdr desc) "\n")) + (insert "\n\n"))))) + +(defun magit-insert-tags () + "Insert sections showing all tags." + (when-let ((tags (magit-git-lines "tag" "--list" "-n" magit-buffer-arguments))) + (let ((_head (magit-rev-parse "HEAD"))) + (magit-insert-section (tags) + (magit-insert-heading "Tags:") + (dolist (tag tags) + (string-match "^\\([^ \t]+\\)[ \t]+\\([^ \t\n].*\\)?" tag) + (let ((tag (match-string 1 tag)) + (msg (match-string 2 tag))) + (when (magit-refs--insert-refname-p tag) + (magit-insert-section (tag tag t) + (magit-insert-heading + (magit-refs--format-focus-column tag 'tag) + (propertize tag 'font-lock-face 'magit-tag) + (make-string (max 1 (- magit-refs-primary-column-width + (length tag))) + ?\s) + (and msg (magit-log-propertize-keywords nil msg))) + (when (and magit-refs-margin-for-tags (magit-buffer-margin-p)) + (magit-refs--format-margin tag)) + (magit-refs--insert-cherry-commits tag))))) + (insert ?\n) + (magit-make-margin-overlay nil t))))) + +(defun magit-insert-remote-branches () + "Insert sections showing all remote-tracking branches." + (dolist (remote (magit-list-remotes)) + (magit-insert-section (remote remote) + (magit-insert-heading + (let ((pull (magit-get "remote" remote "url")) + (push (magit-get "remote" remote "pushurl"))) + (format (propertize "Remote %s (%s):" + 'font-lock-face 'magit-section-heading) + (propertize remote 'font-lock-face 'magit-branch-remote) + (concat pull (and pull push ", ") push)))) + (let (head) + (dolist (line (magit-git-lines "for-each-ref" "--format=\ +%(symref:short)%00%(refname:short)%00%(refname)%00%(subject)" + (concat "refs/remotes/" remote) + magit-buffer-arguments)) + (pcase-let ((`(,head-branch ,branch ,ref ,msg) + (-replace "" nil (split-string line "\0")))) + (if head-branch + (progn (cl-assert (equal branch (concat remote "/HEAD"))) + (setq head head-branch)) + (when (magit-refs--insert-refname-p branch) + (magit-insert-section (branch branch t) + (let ((headp (equal branch head)) + (abbrev (if magit-refs-show-remote-prefix + branch + (substring branch (1+ (length remote)))))) + (magit-insert-heading + (magit-refs--format-focus-column branch) + (magit-refs--propertize-branch + abbrev ref (and headp 'magit-branch-remote-head)) + (make-string (max 1 (- magit-refs-primary-column-width + (length abbrev))) + ?\s) + (and msg (magit-log-propertize-keywords nil msg)))) + (when (magit-buffer-margin-p) + (magit-refs--format-margin branch)) + (magit-refs--insert-cherry-commits branch))))))) + (insert ?\n) + (magit-make-margin-overlay nil t)))) + +(defun magit-insert-local-branches () + "Insert sections showing all local branches." + (magit-insert-section (local nil) + (magit-insert-heading "Branches:") + (dolist (line (magit-refs--format-local-branches)) + (pcase-let ((`(,branch . ,strings) line)) + (magit-insert-section + ((eval (if branch 'branch 'commit)) + (or branch (magit-rev-parse "HEAD")) + t) + (apply #'magit-insert-heading strings) + (when (magit-buffer-margin-p) + (magit-refs--format-margin branch)) + (magit-refs--insert-cherry-commits branch)))) + (insert ?\n) + (magit-make-margin-overlay nil t))) + +(defun magit-refs--format-local-branches () + (let ((lines (-keep 'magit-refs--format-local-branch + (magit-git-lines + "for-each-ref" + (concat "--format=\ +%(HEAD)%00%(refname:short)%00%(refname)%00\ +%(upstream:short)%00%(upstream)%00%(upstream:track)%00" + (if magit-refs-show-push-remote "\ +%(push:remotename)%00%(push)%00%(push:track)%00%(subject)" + "%00%00%00%(subject)")) + "refs/heads" + magit-buffer-arguments)))) + (unless (magit-get-current-branch) + (push (magit-refs--format-local-branch + (concat "*\0\0\0\0\0\0\0\0" (magit-rev-format "%s"))) + lines)) + (setq-local magit-refs-primary-column-width + (let ((def (default-value 'magit-refs-primary-column-width))) + (if (atom def) + def + (pcase-let ((`(,min . ,max) def)) + (min max (apply #'max min (mapcar #'car lines))))))) + (mapcar (pcase-lambda (`(,_ ,branch ,focus ,branch-desc ,u:ahead ,p:ahead + ,u:behind ,upstream ,p:behind ,push ,msg)) + (list branch focus branch-desc u:ahead p:ahead + (make-string (max 1 (- magit-refs-primary-column-width + (length (concat branch-desc + u:ahead + p:ahead + u:behind)))) + ?\s) + u:behind upstream p:behind push + msg)) + lines))) + +(defun magit-refs--format-local-branch (line) + (pcase-let ((`(,head ,branch ,ref ,upstream ,u:ref ,u:track + ,push ,p:ref ,p:track ,msg) + (-replace "" nil (split-string line "\0")))) + (when (or (not branch) + (magit-refs--insert-refname-p branch)) + (let* ((headp (equal head "*")) + (pushp (and push + magit-refs-show-push-remote + (magit-rev-verify p:ref) + (not (equal p:ref u:ref)))) + (branch-desc + (if branch + (magit-refs--propertize-branch + branch ref (and headp 'magit-branch-current)) + (magit--propertize-face "(detached)" + 'font-lock-warning-face))) + (u:ahead (and u:track + (string-match "ahead \\([0-9]+\\)" u:track) + (magit--propertize-face + (concat (and magit-refs-pad-commit-counts " ") + (match-string 1 u:track) + ">") + 'magit-dimmed))) + (u:behind (and u:track + (string-match "behind \\([0-9]+\\)" u:track) + (magit--propertize-face + (concat "<" + (match-string 1 u:track) + (and magit-refs-pad-commit-counts " ")) + 'magit-dimmed))) + (p:ahead (and pushp p:track + (string-match "ahead \\([0-9]+\\)" p:track) + (magit--propertize-face + (concat (match-string 1 p:track) + ">" + (and magit-refs-pad-commit-counts " ")) + 'magit-branch-remote))) + (p:behind (and pushp p:track + (string-match "behind \\([0-9]+\\)" p:track) + (magit--propertize-face + (concat "<" + (match-string 1 p:track) + (and magit-refs-pad-commit-counts " ")) + 'magit-dimmed)))) + (list (1+ (length (concat branch-desc u:ahead p:ahead u:behind))) + branch + (magit-refs--format-focus-column branch headp) + branch-desc u:ahead p:ahead u:behind + (and upstream + (concat (if (equal u:track "[gone]") + (magit--propertize-face upstream 'error) + (magit-refs--propertize-branch upstream u:ref)) + " ")) + (and pushp + (concat p:behind + (magit--propertize-face + push 'magit-branch-remote) + " ")) + (and msg (magit-log-propertize-keywords nil msg))))))) + +(defun magit-refs--format-focus-column (ref &optional type) + (let ((focus magit-buffer-upstream) + (width (if magit-refs-show-commit-count + magit-refs-focus-column-width + 1))) + (format + (format "%%%ss " width) + (cond ((or (equal ref focus) + (and (eq type t) + (equal focus "HEAD"))) + (magit--propertize-face (concat (if (equal focus "HEAD") "@" "*") + (make-string (1- width) ?\s)) + 'magit-section-heading)) + ((if (eq type 'tag) + (eq magit-refs-show-commit-count 'all) + magit-refs-show-commit-count) + (pcase-let ((`(,behind ,ahead) + (magit-rev-diff-count magit-buffer-upstream ref))) + (magit--propertize-face + (cond ((> ahead 0) (concat "<" (number-to-string ahead))) + ((> behind 0) (concat (number-to-string behind) ">")) + (t "=")) + 'magit-dimmed))) + (t ""))))) + +(defun magit-refs--propertize-branch (branch ref &optional head-face) + (let ((face (cdr (cl-find-if (pcase-lambda (`(,re . ,_)) + (string-match-p re ref)) + magit-ref-namespaces)))) + (magit--propertize-face + branch (if head-face (list face head-face) face)))) + +(defun magit-refs--insert-refname-p (refname) + (--if-let (-first (pcase-lambda (`(,key . ,_)) + (if (functionp key) + (funcall key refname) + (string-match-p key refname))) + magit-refs-filter-alist) + (cdr it) + t)) + +(defun magit-refs--insert-cherry-commits (ref) + (magit-insert-section-body + (let ((start (point)) + (magit-insert-section--current nil)) + (magit-git-wash (apply-partially 'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) magit-buffer-upstream ref) + (if (= (point) start) + (message "No cherries for %s" ref) + (magit-make-margin-overlay nil t))))) + +(defun magit-refs--format-margin (commit) + (save-excursion + (goto-char (line-beginning-position 0)) + (let ((line (magit-rev-format "%ct%cN" commit))) + (magit-log-format-margin commit + (substring line 10) + (substring line 0 10))))) + +;;; _ +(provide 'magit-refs) +;;; magit-refs.el ends here diff --git a/elpa/magit-20200318.1224/magit-refs.elc b/elpa/magit-20200318.1224/magit-refs.elc new file mode 100644 index 00000000..dbea0e4d Binary files /dev/null and b/elpa/magit-20200318.1224/magit-refs.elc differ diff --git a/elpa/magit-20200318.1224/magit-remote.el b/elpa/magit-20200318.1224/magit-remote.el new file mode 100644 index 00000000..ab74ac81 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-remote.el @@ -0,0 +1,341 @@ +;;; magit-remote.el --- transfer Git commits -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements remote commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-remote-add-set-remote.pushDefault 'ask-if-unset + "Whether to set the value of `remote.pushDefault' after adding a remote. + +If `ask', then always ask. If `ask-if-unset', then ask, but only +if the variable isn't set already. If nil, then don't ever set. +If the value is a string, then set without asking, provided that +the name of the added remote is equal to that string and the +variable isn't already set." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(choice (const :tag "ask if unset" ask-if-unset) + (const :tag "always ask" ask) + (string :tag "set if named") + (const :tag "don't set"))) + +(defcustom magit-remote-direct-configure t + "Whether the command `magit-remote' shows Git variables. +When set to nil, no variables are displayed by this transient +command, instead the sub-transient `magit-remote-configure' +has to be used to view and change remote related variables." + :package-version '(magit . "2.12.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-prefer-push-default nil + "Whether to prefer `remote.pushDefault' over per-branch variables." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +;;; Commands + +;;;###autoload (autoload 'magit-remote "magit-remote" nil t) +(define-transient-command magit-remote (remote) + "Add, configure or remove a remote." + :man-page "git-remote" + :value '("-f") + ["Variables" + :if (lambda () + (and magit-remote-direct-configure + (oref transient--prefix scope))) + ("u" magit-remote..url) + ("U" magit-remote..fetch) + ("s" magit-remote..pushurl) + ("S" magit-remote..push) + ("O" magit-remote..tagopt)] + ["Arguments for add" + ("-f" "Fetch after add" "-f")] + ["Actions" + [("a" "Add" magit-remote-add) + ("r" "Rename" magit-remote-rename) + ("k" "Remove" magit-remote-remove)] + [("C" "Configure..." magit-remote-configure) + ("p" "Prune stale branches" magit-remote-prune) + ("P" "Prune stale refspecs" magit-remote-prune-refspecs)]] + (interactive (list (magit-get-current-remote))) + (transient-setup 'magit-remote nil nil :scope remote)) + +(defun magit-read-url (prompt &optional initial-input) + (let ((url (magit-read-string-ns prompt initial-input))) + (if (string-prefix-p "~" url) + (expand-file-name url) + url))) + +;;;###autoload +(defun magit-remote-add (remote url &optional args) + "Add a remote named REMOTE and fetch it." + (interactive (list (magit-read-string-ns "Remote name") + (magit-read-url "Remote url") + (transient-args 'magit-remote))) + (if (pcase (list magit-remote-add-set-remote.pushDefault + (magit-get "remote.pushDefault")) + (`(,(pred stringp) ,_) t) + ((or `(ask ,_) `(ask-if-unset nil)) + (y-or-n-p (format "Set `remote.pushDefault' to \"%s\"? " remote)))) + (progn (magit-call-git "remote" "add" args remote url) + (setf (magit-get "remote.pushDefault") remote) + (magit-refresh)) + (magit-run-git-async "remote" "add" args remote url))) + +;;;###autoload +(defun magit-remote-rename (old new) + "Rename the remote named OLD to NEW." + (interactive + (let ((remote (magit-read-remote "Rename remote"))) + (list remote (magit-read-string-ns (format "Rename %s to" remote))))) + (unless (string= old new) + (magit-call-git "remote" "rename" old new) + (magit-remote--cleanup-push-variables old new) + (magit-refresh))) + +;;;###autoload +(defun magit-remote-remove (remote) + "Delete the remote named REMOTE." + (interactive (list (magit-read-remote "Delete remote"))) + (magit-call-git "remote" "rm" remote) + (magit-remote--cleanup-push-variables remote) + (magit-refresh)) + +(defun magit-remote--cleanup-push-variables (remote &optional new-name) + (magit-with-toplevel + (when (equal (magit-get "remote.pushDefault") remote) + (magit-set new-name "remote.pushDefault")) + (dolist (var (magit-git-lines "config" "--name-only" + "--get-regexp" "^branch\.[^.]*\.pushRemote" + (format "^%s$" remote))) + (magit-call-git "config" (and (not new-name) "--unset") var new-name)))) + +(defconst magit--refspec-re "\\`\\(\\+\\)?\\([^:]+\\):\\(.*\\)\\'") + +;;;###autoload +(defun magit-remote-prune (remote) + "Remove stale remote-tracking branches for REMOTE." + (interactive (list (magit-read-remote "Prune stale branches of remote"))) + (magit-run-git-async "remote" "prune" remote)) + +;;;###autoload +(defun magit-remote-prune-refspecs (remote) + "Remove stale refspecs for REMOTE. + +A refspec is stale if there no longer exists at least one branch +on the remote that would be fetched due to that refspec. A stale +refspec is problematic because its existence causes Git to refuse +to fetch according to the remaining non-stale refspecs. + +If only stale refspecs remain, then offer to either delete the +remote or to replace the stale refspecs with the default refspec. + +Also remove the remote-tracking branches that were created due to +the now stale refspecs. Other stale branches are not removed." + (interactive (list (magit-read-remote "Prune refspecs of remote"))) + (let* ((tracking-refs (magit-list-remote-branches remote)) + (remote-refs (magit-remote-list-refs remote)) + (variable (format "remote.%s.fetch" remote)) + (refspecs (magit-get-all variable)) + stale) + (dolist (refspec refspecs) + (when (string-match magit--refspec-re refspec) + (let ((theirs (match-string 2 refspec)) + (ours (match-string 3 refspec))) + (unless (if (string-match "\\*" theirs) + (let ((re (replace-match ".*" t t theirs))) + (--some (string-match-p re it) remote-refs)) + (member theirs remote-refs)) + (push (cons refspec + (if (string-match "\\*" ours) + (let ((re (replace-match ".*" t t ours))) + (--filter (string-match-p re it) tracking-refs)) + (list (car (member ours tracking-refs))))) + stale))))) + (if (not stale) + (message "No stale refspecs for remote %S" remote) + (if (= (length stale) + (length refspecs)) + (magit-read-char-case + (format "All of %s's refspecs are stale. " remote) nil + (?s "replace with [d]efault refspec" + (magit-set-all + (list (format "+refs/heads/*:refs/remotes/%s/*" remote)) + variable)) + (?r "[r]emove remote" + (magit-call-git "remote" "rm" remote)) + (?a "or [a]abort" + (user-error "Abort"))) + (if (if (= (length stale) 1) + (pcase-let ((`(,refspec . ,refs) (car stale))) + (magit-confirm 'prune-stale-refspecs + (format "Prune stale refspec %s and branch %%s" refspec) + (format "Prune stale refspec %s and %%i branches" refspec) + nil refs)) + (magit-confirm 'prune-stale-refspecs nil + (format "Prune %%i stale refspecs and %i branches" + (length (cl-mapcan (lambda (s) (copy-sequence (cdr s))) + stale))) + nil + (mapcar (pcase-lambda (`(,refspec . ,refs)) + (concat refspec "\n" + (mapconcat (lambda (b) (concat " " b)) + refs "\n"))) + stale))) + (pcase-dolist (`(,refspec . ,refs) stale) + (magit-call-git "config" "--unset" variable + (regexp-quote refspec)) + (magit--log-action + (lambda (refs) + (format "Deleting %i branches" (length refs))) + (lambda (ref) + (format "Deleting branch %s (was %s)" ref + (magit-rev-parse "--short" ref))) + refs) + (dolist (ref refs) + (magit-call-git "update-ref" "-d" ref))) + (user-error "Abort"))) + (magit-refresh)))) + +;;;###autoload +(defun magit-remote-set-head (remote &optional branch) + "Set the local representation of REMOTE's default branch. +Query REMOTE and set the symbolic-ref refs/remotes//HEAD +accordingly. With a prefix argument query for the branch to be +used, which allows you to select an incorrect value if you fancy +doing that." + (interactive + (let ((remote (magit-read-remote "Set HEAD for remote"))) + (list remote + (and current-prefix-arg + (magit-read-remote-branch (format "Set %s/HEAD to" remote) + remote nil nil t))))) + (magit-run-git "remote" "set-head" remote (or branch "--auto"))) + +;;;###autoload +(defun magit-remote-unset-head (remote) + "Unset the local representation of REMOTE's default branch. +Delete the symbolic-ref \"refs/remotes//HEAD\"." + (interactive (list (magit-read-remote "Unset HEAD for remote"))) + (magit-run-git "remote" "set-head" remote "--delete")) + +;;; Configure + +;;;###autoload (autoload 'magit-remote-configure "magit-remote" nil t) +(define-transient-command magit-remote-configure (remote) + "Configure a remote." + :man-page "git-remote" + [:description + (lambda () + (concat + (propertize "Configure " 'face 'transient-heading) + (propertize (oref transient--prefix scope) 'face 'magit-branch-remote))) + ("u" magit-remote..url) + ("U" magit-remote..fetch) + ("s" magit-remote..pushurl) + ("S" magit-remote..push) + ("O" magit-remote..tagopt)] + (interactive + (list (or (and (not current-prefix-arg) + (not (and magit-remote-direct-configure + (eq current-transient-command 'magit-remote))) + (magit-get-current-remote)) + (magit--read-remote-scope)))) + (transient-setup 'magit-remote-configure nil nil :scope remote)) + +(defun magit--read-remote-scope (&optional obj) + (magit-read-remote + (if obj + (format "Set %s for remote" + (format (oref obj variable) "")) + "Configure remote"))) + +(define-infix-command magit-remote..url () + :class 'magit--git-variable:urls + :scope 'magit--read-remote-scope + :variable "remote.%s.url" + :multi-value t + :history-key 'magit-remote..*url) + +(define-infix-command magit-remote..fetch () + :class 'magit--git-variable + :scope 'magit--read-remote-scope + :variable "remote.%s.fetch" + :multi-value t) + +(define-infix-command magit-remote..pushurl () + :class 'magit--git-variable:urls + :scope 'magit--read-remote-scope + :variable "remote.%s.pushurl" + :multi-value t + :history-key 'magit-remote..*url + :seturl-arg "--push") + +(define-infix-command magit-remote..push () + :class 'magit--git-variable + :scope 'magit--read-remote-scope + :variable "remote.%s.push") + +(define-infix-command magit-remote..tagopt () + :class 'magit--git-variable:choices + :scope 'magit--read-remote-scope + :variable "remote.%s.tagOpt" + :choices '("--no-tags" "--tags")) + +;;; Transfer Utilities + +(defun magit--push-remote-variable (&optional branch short) + (unless branch + (setq branch (magit-get-current-branch))) + (magit--propertize-face + (if (or (not branch) magit-prefer-push-default) + (if short "pushDefault" "remote.pushDefault") + (if short "pushRemote" (format "branch.%s.pushRemote" branch))) + 'bold)) + +(defun magit--select-push-remote (prompt-suffix) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get-push-remote branch))) + (when (or current-prefix-arg + (not remote) + (not (member remote (magit-list-remotes)))) + (setq remote + (magit-read-remote (format "Set %s and %s" + (magit--push-remote-variable) + prompt-suffix))) + (setf (magit-get (magit--push-remote-variable branch)) remote)) + (list branch remote))) + +;;; _ +(provide 'magit-remote) +;;; magit-remote.el ends here diff --git a/elpa/magit-20200318.1224/magit-remote.elc b/elpa/magit-20200318.1224/magit-remote.elc new file mode 100644 index 00000000..dad6c58a Binary files /dev/null and b/elpa/magit-20200318.1224/magit-remote.elc differ diff --git a/elpa/magit-20200318.1224/magit-repos.el b/elpa/magit-20200318.1224/magit-repos.el new file mode 100644 index 00000000..b59de628 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-repos.el @@ -0,0 +1,338 @@ +;;; magit-repos.el --- listing repositories -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for listing repositories. This +;; includes getting a Lisp list of known repositories as well as a +;; mode for listing repositories in a buffer. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit-core) + +(declare-function magit-status-setup-buffer "magit-status" (directory)) + +(defvar x-stretch-cursor) + +;;; Options + +(defcustom magit-repository-directories nil + "List of directories that are or contain Git repositories. + +Each element has the form (DIRECTORY . DEPTH). DIRECTORY has +to be a directory or a directory file-name, a string. DEPTH, +an integer, specifies the maximum depth to look for Git +repositories. If it is 0, then only add DIRECTORY itself. + +This option controls which repositories are being listed by +`magit-list-repositories'. It also affects `magit-status' +\(which see) in potentially surprising ways." + :package-version '(magit . "3.0.0") + :group 'magit-essentials + :type '(repeat (cons directory (integer :tag "Depth")))) + +(defgroup magit-repolist nil + "List repositories in a buffer." + :link '(info-link "(magit)Repository List") + :group 'magit-modes) + +(defcustom magit-repolist-mode-hook '(hl-line-mode) + "Hook run after entering Magit-Repolist mode." + :package-version '(magit . "2.9.0") + :group 'magit-repolist + :type 'hook + :get 'magit-hook-custom-get + :options '(hl-line-mode)) + +(defcustom magit-repolist-columns + '(("Name" 25 magit-repolist-column-ident nil) + ("Version" 25 magit-repolist-column-version nil) + ("BU" 3 magit-repolist-column-unpushed-to-upstream + ((:right-align t) + (:help-echo "Local changes not in upstream"))) + ("Path" 99 magit-repolist-column-path nil)) + "List of columns displayed by `magit-list-repositories'. + +Each element has the form (HEADER WIDTH FORMAT PROPS). + +HEADER is the string displayed in the header. WIDTH is the width +of the column. FORMAT is a function that is called with one +argument, the repository identification (usually its basename), +and with `default-directory' bound to the toplevel of its working +tree. It has to return a string to be inserted or nil. PROPS is +an alist that supports the keys `:right-align' and `:pad-right'. +Some entries also use `:help-echo', but `tabulated-list' does not +actually support that yet." + :package-version '(magit . "2.12.0") + :group 'magit-repolist + :type `(repeat (list :tag "Column" + (string :tag "Header Label") + (integer :tag "Column Width") + (function :tag "Inserter Function") + (repeat :tag "Properties" + (list (choice :tag "Property" + (const :right-align) + (const :pad-right) + (symbol)) + (sexp :tag "Value")))))) + +(defcustom magit-repolist-column-flag-alist + '((magit-untracked-files . "N") + (magit-unstaged-files . "U") + (magit-staged-files . "S")) + "Association list of predicates and flags for `magit-repolist-column-flag'. + +Each element is of the form (FUNCTION . FLAG). Each FUNCTION is +called with no arguments, with `default-directory' bound to the +top level of a repository working tree, until one of them returns +a non-nil value. FLAG corresponding to that function is returned +as the value of `magit-repolist-column-flag'." + :package-version '(magit . "3.0.0") + :group 'magit-repolist + :type '(alist :key-type (function :tag "Predicate Function") + :value-type (string :tag "Flag"))) + +;;; List Repositories +;;;; Command +;;;###autoload +(defun magit-list-repositories () + "Display a list of repositories. + +Use the options `magit-repository-directories' to control which +repositories are displayed." + (interactive) + (if magit-repository-directories + (with-current-buffer (get-buffer-create "*Magit Repositories*") + (magit-repolist-mode) + (magit-repolist-refresh) + (tabulated-list-print) + (switch-to-buffer (current-buffer))) + (message "You need to customize `magit-repository-directories' %s" + "before you can list repositories"))) + +;;;; Mode + +(defvar magit-repolist-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map tabulated-list-mode-map) + (define-key map (kbd "C-m") 'magit-repolist-status) + map) + "Local keymap for Magit-Repolist mode buffers.") + +(defun magit-repolist-status (&optional _button) + "Show the status for the repository at point." + (interactive) + (--if-let (tabulated-list-get-id) + (magit-status-setup-buffer (expand-file-name it)) + (user-error "There is no repository at point"))) + +(define-derived-mode magit-repolist-mode tabulated-list-mode "Repos" + "Major mode for browsing a list of Git repositories." + (setq-local x-stretch-cursor nil) + (setq tabulated-list-padding 0) + (setq tabulated-list-sort-key (cons "Path" nil)) + (setq tabulated-list-format + (vconcat (mapcar (pcase-lambda (`(,title ,width ,_fn ,props)) + (nconc (list title width t) + (-flatten props))) + magit-repolist-columns))) + (tabulated-list-init-header) + (add-hook 'tabulated-list-revert-hook 'magit-repolist-refresh nil t) + (setq imenu-prev-index-position-function + 'magit-imenu--repolist-prev-index-position-function) + (setq imenu-extract-index-name-function + 'magit-imenu--repolist-extract-index-name-function)) + +(defun magit-repolist-refresh () + (setq tabulated-list-entries + (mapcar (pcase-lambda (`(,id . ,path)) + (let ((default-directory path)) + (list path + (vconcat (--map (or (funcall (nth 2 it) id) "") + magit-repolist-columns))))) + (magit-list-repos-uniquify + (--map (cons (file-name-nondirectory (directory-file-name it)) + it) + (magit-list-repos)))))) + +;;;; Columns + +(defun magit-repolist-column-ident (id) + "Insert the identification of the repository. +Usually this is just its basename." + id) + +(defun magit-repolist-column-path (_id) + "Insert the absolute path of the repository." + (abbreviate-file-name default-directory)) + +(defun magit-repolist-column-version (_id) + "Insert a description of the repository's `HEAD' revision." + (when-let ((v (or (magit-git-string "describe" "--tags" "--dirty") + ;; If there are no tags, use the date in MELPA format. + (magit-git-string "show" "--no-patch" "--format=%cd-g%h" + "--date=format:%Y%m%d.%H%M")))) + (save-match-data + (when (string-match "-dirty\\'" v) + (magit--put-face (1+ (match-beginning 0)) (length v) 'error v)) + (if (and v (string-match "\\`[0-9]" v)) + (concat " " v) + v)))) + +(defun magit-repolist-column-branch (_id) + "Insert the current branch." + (magit-get-current-branch)) + +(defun magit-repolist-column-upstream (_id) + "Insert the upstream branch of the current branch." + (magit-get-upstream-branch)) + +(defun magit-repolist-column-flag (_id) + "Insert a flag as specified by `magit-repolist-column-flag-alist'. + +By default this indicates whether there are uncommitted changes. +- N if there is at least one untracked file. +- U if there is at least one unstaged file. +- S if there is at least one staged file. +Only one letter is shown, the first that applies." + (-some (pcase-lambda (`(,fun . ,flag)) + (and (funcall fun) flag)) + magit-repolist-column-flag-alist)) + +(defun magit-repolist-column-unpulled-from-upstream (_id) + "Insert number of upstream commits not in the current branch." + (--when-let (magit-get-upstream-branch) + (let ((n (cadr (magit-rev-diff-count "HEAD" it)))) + (magit--propertize-face + (number-to-string n) (if (> n 0) 'bold 'shadow))))) + +(defun magit-repolist-column-unpulled-from-pushremote (_id) + "Insert number of commits in the push branch but not the current branch." + (--when-let (magit-get-push-branch nil t) + (let ((n (cadr (magit-rev-diff-count "HEAD" it)))) + (magit--propertize-face + (number-to-string n) (if (> n 0) 'bold 'shadow))))) + +(defun magit-repolist-column-unpushed-to-upstream (_id) + "Insert number of commits in the current branch but not its upstream." + (--when-let (magit-get-upstream-branch) + (let ((n (car (magit-rev-diff-count "HEAD" it)))) + (magit--propertize-face + (number-to-string n) (if (> n 0) 'bold 'shadow))))) + +(defun magit-repolist-column-unpushed-to-pushremote (_id) + "Insert number of commits in the current branch but not its push branch." + (--when-let (magit-get-push-branch nil t) + (let ((n (car (magit-rev-diff-count "HEAD" it)))) + (magit--propertize-face + (number-to-string n) (if (> n 0) 'bold 'shadow))))) + +(defun magit-repolist-column-branches (_id) + "Insert number of branches." + (let ((n (length (magit-list-local-branches)))) + (magit--propertize-face (number-to-string n) (if (> n 1) 'bold 'shadow)))) + +(defun magit-repolist-column-stashes (_id) + "Insert number of stashes." + (let ((n (length (magit-list-stashes)))) + (magit--propertize-face (number-to-string n) (if (> n 0) 'bold 'shadow)))) + +;;; Read Repository + +(defun magit-read-repository (&optional read-directory-name) + "Read a Git repository in the minibuffer, with completion. + +The completion choices are the basenames of top-levels of +repositories found in the directories specified by option +`magit-repository-directories'. In case of name conflicts +the basenames are prefixed with the name of the respective +parent directories. The returned value is the actual path +to the selected repository. + +If READ-DIRECTORY-NAME is non-nil or no repositories can be +found based on the value of `magit-repository-directories', +then read an arbitrary directory using `read-directory-name' +instead." + (if-let ((repos (and (not read-directory-name) + magit-repository-directories + (magit-repos-alist)))) + (let ((reply (magit-completing-read "Git repository" repos))) + (file-name-as-directory + (or (cdr (assoc reply repos)) + (if (file-directory-p reply) + (expand-file-name reply) + (user-error "Not a repository or a directory: %s" reply))))) + (file-name-as-directory + (read-directory-name "Git repository: " + (or (magit-toplevel) default-directory))))) + +(defun magit-list-repos () + (cl-mapcan (pcase-lambda (`(,dir . ,depth)) + (magit-list-repos-1 dir depth)) + magit-repository-directories)) + +(defun magit-list-repos-1 (directory depth) + (cond ((file-readable-p (expand-file-name ".git" directory)) + (list (file-name-as-directory directory))) + ((and (> depth 0) (magit-file-accessible-directory-p directory)) + (--mapcat (and (file-directory-p it) + (magit-list-repos-1 it (1- depth))) + (directory-files directory t + directory-files-no-dot-files-regexp t))))) + +(defun magit-list-repos-uniquify (alist) + (let (result (dict (make-hash-table :test 'equal))) + (dolist (a (delete-dups alist)) + (puthash (car a) (cons (cdr a) (gethash (car a) dict)) dict)) + (maphash + (lambda (key value) + (if (= (length value) 1) + (push (cons key (car value)) result) + (setq result + (append result + (magit-list-repos-uniquify + (--map (cons (concat + key "\\" + (file-name-nondirectory + (directory-file-name + (substring it 0 (- (1+ (length key))))))) + it) + value)))))) + dict) + result)) + +(defun magit-repos-alist () + (magit-list-repos-uniquify + (--map (cons (file-name-nondirectory (directory-file-name it)) it) + (magit-list-repos)))) + +;;; _ +(provide 'magit-repos) +;;; magit-repos.el ends here diff --git a/elpa/magit-20200318.1224/magit-repos.elc b/elpa/magit-20200318.1224/magit-repos.elc new file mode 100644 index 00000000..d699fec9 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-repos.elc differ diff --git a/elpa/magit-20200318.1224/magit-reset.el b/elpa/magit-20200318.1224/magit-reset.el new file mode 100644 index 00000000..823a6753 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-reset.el @@ -0,0 +1,127 @@ +;;; magit-reset.el --- reset fuctionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements reset commands. + +;;; Code: + +(require 'magit) + +;;;###autoload (autoload 'magit-reset "magit" nil t) +(define-transient-command magit-reset () + "Reset the `HEAD', index and/or worktree to a previous state." + :man-page "git-reset" + ["Reset" + ("m" "mixed (HEAD and index)" magit-reset-mixed) + ("s" "soft (HEAD only)" magit-reset-soft) + ("h" "hard (HEAD, index and files)" magit-reset-hard) + ("i" "index (only)" magit-reset-index) + ("w" "worktree (only)" magit-reset-worktree) + "" + ("f" "a file" magit-file-checkout)]) + +;;;###autoload +(defun magit-reset-mixed (commit) + "Reset the `HEAD' and index to COMMIT, but not the working tree. +\n(git reset --mixed COMMIT)" + (interactive (list (magit-reset-read-branch-or-commit "Reset %s to"))) + (magit-reset-internal "--mixed" commit)) + +;;;###autoload +(defun magit-reset-soft (commit) + "Reset the `HEAD' to COMMIT, but not the index and working tree. +\n(git reset --soft REVISION)" + (interactive (list (magit-reset-read-branch-or-commit "Soft reset %s to"))) + (magit-reset-internal "--soft" commit)) + +;;;###autoload +(defun magit-reset-hard (commit) + "Reset the `HEAD', index, and working tree to COMMIT. +\n(git reset --hard REVISION)" + (interactive (list (magit-reset-read-branch-or-commit + (concat (magit--propertize-face "Hard" 'bold) + " reset %s to")))) + (magit-reset-internal "--hard" commit)) + +;;;###autoload +(defun magit-reset-index (commit) + "Reset the index to COMMIT. +Keep the `HEAD' and working tree as-is, so if COMMIT refers to the +head this effectively unstages all changes. +\n(git reset COMMIT .)" + (interactive (list (magit-read-branch-or-commit "Reset index to"))) + (magit-reset-internal nil commit ".")) + +;;;###autoload +(defun magit-reset-worktree (commit) + "Reset the worktree to COMMIT. +Keep the `HEAD' and index as-is." + (interactive (list (magit-read-branch-or-commit "Reset worktree to"))) + (magit-wip-commit-before-change nil " before reset") + (magit-with-temp-index commit nil + (magit-call-git "checkout-index" "--all" "--force")) + (magit-wip-commit-after-apply nil " after reset") + (magit-refresh)) + +;;;###autoload +(defun magit-reset-quickly (commit &optional hard) + "Reset the `HEAD' and index to COMMIT, and possibly the working tree. +With a prefix argument reset the working tree otherwise don't. +\n(git reset --mixed|--hard COMMIT)" + (interactive (list (magit-reset-read-branch-or-commit + (if current-prefix-arg + (concat (magit--propertize-face "Hard" 'bold) + " reset %s to") + "Reset %s to")) + current-prefix-arg)) + (magit-reset-internal (if hard "--hard" "--mixed") commit)) + +(defun magit-reset-read-branch-or-commit (prompt) + "Prompt for and return a ref to reset HEAD to. + +PROMPT is a format string, where either the current branch name +or \"detached head\" will be substituted for %s." + (magit-read-branch-or-commit + (format prompt (or (magit-get-current-branch) "detached head")))) + +(defun magit-reset-internal (arg commit &optional path) + (when (and (not (member arg '("--hard" nil))) + (equal (magit-rev-parse commit) + (magit-rev-parse "HEAD~"))) + (with-temp-buffer + (magit-git-insert "show" "-s" "--format=%B" "HEAD") + (when git-commit-major-mode + (funcall git-commit-major-mode)) + (git-commit-setup-font-lock) + (git-commit-save-message))) + (let ((cmd (if (and (equal commit "HEAD") (not arg)) "unstage" "reset"))) + (magit-wip-commit-before-change nil (concat " before " cmd)) + (magit-run-git "reset" arg commit "--" path) + (when (equal cmd "unstage") + (magit-wip-commit-after-apply nil " after unstage")))) + +;;; _ +(provide 'magit-reset) +;;; magit-reset.el ends here diff --git a/elpa/magit-20200318.1224/magit-reset.elc b/elpa/magit-20200318.1224/magit-reset.elc new file mode 100644 index 00000000..bcf61ab8 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-reset.elc differ diff --git a/elpa/magit-20200318.1224/magit-section.el b/elpa/magit-20200318.1224/magit-section.el new file mode 100644 index 00000000..19efd96f --- /dev/null +++ b/elpa/magit-20200318.1224/magit-section.el @@ -0,0 +1,1733 @@ +;;; magit-section.el --- Sections for read-only buffers -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Package-Requires: ((emacs "25.1") (dash "20180910")) +;; Keywords: tools +;; Homepage: https://github.com/magit/magit + +;; Magit-Section 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, or (at your option) +;; any later version. +;; +;; Magit-Section 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This package implements the main user interface of Magit — the +;; collapsible sections that make up its buffers. This package used +;; to be distributed as part of Magit but now it can also be used by +;; other packages that have nothing to do with Magit or Git. + +;;; Code: + +(require 'cl-lib) +(require 'dash) +(require 'eieio) + +(eval-when-compile + (require 'benchmark) + (require 'subr-x)) + +;;; Hooks + +(defvar magit-section-movement-hook nil + "Hook run by `magit-section-goto'. +That function in turn is used by all section movement commands.") + +(defvar magit-section-highlight-hook + '(magit-section-highlight + magit-section-highlight-selection) + "Functions used to highlight the current section. +Each function is run with the current section as only argument +until one of them returns non-nil.") + +(defvar magit-section-unhighlight-hook nil + "Functions used to unhighlight the previously current section. +Each function is run with the current section as only argument +until one of them returns non-nil. Most sections are properly +unhighlighted without requiring a specialized unhighlighter, +diff-related sections being the only exception.") + +(defvar magit-section-set-visibility-hook + '(magit-section-cached-visibility) + "Hook used to set the initial visibility of a section. +Stop at the first function that returns non-nil. The returned +value should be `show', `hide' or nil. If no function returns +non-nil, determine the visibility as usual, i.e. use the +hardcoded section specific default (see `magit-insert-section').") + +(defvar magit-section-goto-successor-hook nil + "Hook used to go to the same section as was current before a refresh. +This is only used if the standard mechanism for doing so did not +succeed.") + +;;; Options + +(defgroup magit-section nil + "Expandable sections." + :link '(info-link "(magit)Sections") + :group 'extensions) + +(defcustom magit-section-show-child-count t + "Whether to append the number of children to section headings. +This only applies to sections for which doing so makes sense." + :package-version '(magit . "2.1.0") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-cache-visibility t + "Whether to cache visibility of sections. + +Sections always retain their visibility state when they are being +recreated during a refresh. But if a section disappears and then +later reappears again, then this option controls whether this is +the case. + +If t, then cache the visibility of all sections. If a list of +section types, then only do so for matching sections. If nil, +then don't do so for any sections." + :package-version '(magit . "2.12.0") + :group 'magit-section + :type '(choice (const :tag "Don't cache visibility" nil) + (const :tag "Cache visibility of all sections" t) + (repeat :tag "Cache visibility for section types" symbol))) + +(defcustom magit-section-initial-visibility-alist + '((stashes . hide)) + "Alist controlling the initial visibility of sections. + +Each element maps a section type or lineage to the initial +visibility state for such sections. The state has to be one of +`show' or `hide', or a function that returns one of these symbols. +A function is called with the section as the only argument. + +Use the command `magit-describe-section' to determine a section's +lineage or type. The vector in the output is the section lineage +and the type is the first element of that vector. Wildcards can +be used, see `magit-section-match'. + +Currently this option is only used to override hardcoded defaults, +but in the future it will also be used set the defaults. + +An entry whose key is `magit-status-initial-section' specifies +the visibility of the section `magit-status-goto-initial-section' +jumps to. This does not only override defaults, but also other +entries of this alist." + :package-version '(magit . "2.12.0") + :group 'magit-section + :type '(alist :key-type (sexp :tag "Section type/lineage") + :value-type (choice (const hide) + (const show) + function))) + +(defcustom magit-section-visibility-indicator + (if (window-system) + '(magit-fringe-bitmap> . magit-fringe-bitmapv) + '("…" . t)) + "Whether and how to indicate that a section can be expanded/collapsed. + +If nil, then don't show any indicators. +Otherwise the value has to have one of these two forms: + +\(EXPANDABLE-BITMAP . COLLAPSIBLE-BITMAP) + + Both values have to be variables whose values are fringe + bitmaps. In this case every section that can be expanded or + collapsed gets an indicator in the left fringe. + + To provide extra padding around the indicator, set + `left-fringe-width' in `magit-mode-hook'. + +\(STRING . BOOLEAN) + + In this case STRING (usually an ellipsis) is shown at the end + of the heading of every collapsed section. Expanded sections + get no indicator. The cdr controls whether the appearance of + these ellipsis take section highlighting into account. Doing + so might potentially have an impact on performance, while not + doing so is kinda ugly." + :package-version '(magit . "3.0.0") + :group 'magit-section + :type '(choice (const :tag "No indicators" nil) + (cons :tag "Use +- fringe indicators" + (const magit-fringe-bitmap+) + (const magit-fringe-bitmap-)) + (cons :tag "Use >v fringe indicators" + (const magit-fringe-bitmap>) + (const magit-fringe-bitmapv)) + (cons :tag "Use bold >v fringe indicators)" + (const magit-fringe-bitmap-bold>) + (const magit-fringe-bitmap-boldv)) + (cons :tag "Use custom fringe indicators" + (variable :tag "Expandable bitmap variable") + (variable :tag "Collapsible bitmap variable")) + (cons :tag "Use ellipses at end of headings" + (string :tag "Ellipsis" "…") + (choice :tag "Use face kludge" + (const :tag "Yes (potentially slow)" t) + (const :tag "No (kinda ugly)" nil))))) + +(defcustom magit-keep-region-overlay nil + "Whether to keep the region overlay when there is a valid selection. + +By default Magit removes the regular region overlay if, and only +if, that region constitutes a valid selection as understood by +Magit commands. Otherwise it does not remove that overlay, and +the region looks like it would in other buffers. + +There are two types of such valid selections: hunk-internal +regions and regions that select two or more sibling sections. +In such cases Magit removes the region overlay and instead +highlights a slightly larger range. All text (for hunk-internal +regions) or the headings of all sections (for sibling selections) +that are inside that range (not just inside the region) are acted +on by commands such as the staging command. This buffer range +begins at the beginning of the line on which the region begins +and ends at the end of the line on which the region ends. + +Because Magit acts on this larger range and not the region, it is +actually quite important to visualize that larger range. If we +don't do that, then one might think that these commands act on +the region instead. If you want to *also* visualize the region, +then set this option to t. But please note that when the region +does *not* constitute a valid selection, then the region is +*always* visualized as usual, and that it is usually under such +circumstances that you want to use a non-magit command to act on +the region. + +Besides keeping the region overlay, setting this option to t also +causes all face properties, except for `:foreground', to be +ignored for the faces used to highlight headings of selected +sections. This avoids the worst conflicts that result from +displaying the region and the selection overlays at the same +time. We are not interested in dealing with other conflicts. +In fact we *already* provide a way to avoid all of these +conflicts: *not* changing the value of this option. + +It should be clear by now that we consider it a mistake to set +this to display the region when the Magit selection is also +visualized, but since it has been requested a few times and +because it doesn't cost much to offer this option we do so. +However that might change. If the existence of this option +starts complicating other things, then it will be removed." + :package-version '(magit . "2.3.0") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-disable-line-numbers t + "In Magit buffers, whether to disable modes that display line numbers. + +Some users who turn on `global-display-line-numbers-mode' (or +`global-nlinum-mode' or `global-linum-mode') expect line numbers +to be displayed everywhere except in Magit buffers. Other users +do not expect Magit buffers to be treated differently. At least +in theory users in the first group should not use the global mode, +but that ship has sailed, thus this option." + :package-version '(magit . "3.0.0") + :group 'magit-section + :type 'boolean) + +;;; Faces + +(defgroup magit-section-faces nil + "Faces used by Magit-Section." + :group 'magit-section + :group 'faces) + +(defface magit-section-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey95") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey20")) + "Face for highlighting the current section." + :group 'magit-section-faces) + +(defface magit-section-heading + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "DarkGoldenrod4" + :weight bold) + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "LightGoldenrod2" + :weight bold)) + "Face for section headings." + :group 'magit-section-faces) + +(defface magit-section-secondary-heading + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :weight bold)) + "Face for section headings of some secondary headings." + :group 'magit-section-faces) + +(defface magit-section-heading-selection + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "salmon4") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "LightSalmon3")) + "Face for selected section headings." + :group 'magit-section-faces) + +;;; Classes + +(defvar magit--current-section-hook nil + "Internal variable used for `magit-describe-section'.") + +(defvar magit--section-type-alist nil) + +(defclass magit-section () + ((keymap :initform nil :allocation :class) + (type :initform nil :initarg :type) + (value :initform nil :initarg :value) + (start :initform nil :initarg :start) + (content :initform nil) + (end :initform nil) + (hidden :initform nil) + (washer :initform nil) + (process :initform nil) + (heading-highlight-face :initform nil) + (inserter :initform (symbol-value 'magit--current-section-hook)) + (parent :initform nil :initarg :parent) + (children :initform nil))) + +;;; Mode + +(defvar symbol-overlay-inhibit-map) + +(defvar magit-section-mode-map + (let ((map (make-keymap))) + (suppress-keymap map t) + (define-key map (kbd "C-i") 'magit-section-toggle) + (define-key map [C-tab] 'magit-section-cycle) + (define-key map [M-tab] 'magit-section-cycle) + ;; [backtab] is the most portable binding for Shift+Tab. + (define-key map [backtab] 'magit-section-cycle-global) + (define-key map (kbd "^") 'magit-section-up) + (define-key map (kbd "p") 'magit-section-backward) + (define-key map (kbd "n") 'magit-section-forward) + (define-key map (kbd "M-p") 'magit-section-backward-sibling) + (define-key map (kbd "M-n") 'magit-section-forward-sibling) + (define-key map "1" 'magit-section-show-level-1) + (define-key map "2" 'magit-section-show-level-2) + (define-key map "3" 'magit-section-show-level-3) + (define-key map "4" 'magit-section-show-level-4) + (define-key map (kbd "M-1") 'magit-section-show-level-1-all) + (define-key map (kbd "M-2") 'magit-section-show-level-2-all) + (define-key map (kbd "M-3") 'magit-section-show-level-3-all) + (define-key map (kbd "M-4") 'magit-section-show-level-4-all) + map)) + +(define-derived-mode magit-section-mode special-mode "Magit-Sections" + "Parent major mode from which major modes with Magit-like sections inherit. + +Magit-Section is documented in info node `(magit-section)'." + :group 'magit-section + (buffer-disable-undo) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq-local line-move-visual t) ; see #1771 + ;; Turn off syntactic font locking, but not by setting + ;; `font-lock-defaults' because that would enable font locking, and + ;; not all magit plugins may be ready for that (see #3950). + (setq-local font-lock-syntactic-face-function #'ignore) + (setq show-trailing-whitespace nil) + (setq-local symbol-overlay-inhibit-map t) + (setq list-buffers-directory (abbreviate-file-name default-directory)) + ;; (hack-dir-local-variables-non-file-buffer) + (make-local-variable 'text-property-default-nonsticky) + (push (cons 'keymap t) text-property-default-nonsticky) + (add-hook 'post-command-hook #'magit-section-update-highlight t t) + (add-hook 'deactivate-mark-hook #'magit-section-update-highlight t t) + (setq-local redisplay-highlight-region-function + 'magit-section--highlight-region) + (setq-local redisplay-unhighlight-region-function + 'magit-section--unhighlight-region) + (when magit-section-disable-line-numbers + (when (bound-and-true-p global-linum-mode) + (linum-mode -1)) + (when (and (fboundp 'nlinum-mode) + (bound-and-true-p global-nlinum-mode)) + (nlinum-mode -1)) + (when (and (fboundp 'display-line-numbers-mode) + (bound-and-true-p global-display-line-numbers-mode)) + (display-line-numbers-mode -1))) + (when (fboundp 'magit-preserve-section-visibility-cache) + (add-hook 'kill-buffer-hook #'magit-preserve-section-visibility-cache))) + +;;; Core + +(defvar-local magit-root-section nil + "The root section in the current buffer. +All other sections are descendants of this section. The value +of this variable is set by `magit-insert-section' and you should +never modify it.") +(put 'magit-root-section 'permanent-local t) + +(defun magit-current-section () + "Return the section at point." + (or (get-text-property (point) 'magit-section) magit-root-section)) + +(defun magit-section-ident (section) + "Return an unique identifier for SECTION. +The return value has the form ((TYPE . VALUE)...)." + (with-slots (type value parent) section + (cons (cons type + (cond ((eieio-object-p value) + (magit-section-ident-value value)) + ((not (memq type '(unpulled unpushed))) value) + ((string-match-p "@{upstream}" value) value) + ;; Unfortunately Git chokes on "@{push}" when + ;; the value of `push.default' does not allow a + ;; 1:1 mapping. Arbitrary commands may consult + ;; the section value so we cannot use "@{push}". + ;; But `unpushed' and `unpulled' sections should + ;; keep their identity when switching branches + ;; so we have to use another value here. + ((string-match-p "\\`\\.\\." value) "..@{push}") + (t "@{push}.."))) + (and parent + (magit-section-ident parent))))) + +(cl-defgeneric magit-section-ident-value (value) + "Return a constant representation of VALUE. +VALUE is the value of a `magit-section' object. If that is an +object itself, then that is not suitable to be used to identify +the section because two objects may represent the same thing but +not be equal. If possible a method should be added for such +objects, which returns a value that is equal. Otherwise the +catch-all method is used, which just returns the argument +itself.") + +(cl-defmethod magit-section-ident-value (arg) arg) + +(defun magit-get-section (ident &optional root) + "Return the section identified by IDENT. +IDENT has to be a list as returned by `magit-section-ident'. +If optional ROOT is non-nil, then search in that section tree +instead of in the one whose root `magit-root-section' is." + (setq ident (reverse ident)) + (let ((section (or root magit-root-section))) + (when (eq (car (pop ident)) + (oref section type)) + (while (and ident + (pcase-let* ((`(,type . ,value) (car ident)) + (value (magit-section-ident-value value))) + (setq section + (cl-find-if (lambda (section) + (and (eq (oref section type) type) + (equal (magit-section-ident-value + (oref section value)) + value))) + (oref section children))))) + (pop ident)) + section))) + +(defun magit-section-lineage (section) + "Return the lineage of SECTION. +The return value has the form (TYPE...)." + (cons (oref section type) + (when-let ((parent (oref section parent))) + (magit-section-lineage parent)))) + +(defvar magit-insert-section--current nil "For internal use only.") +(defvar magit-insert-section--parent nil "For internal use only.") +(defvar magit-insert-section--oldroot nil "For internal use only.") + +;;; Commands +;;;; Movement + +(defun magit-section-forward () + "Move to the beginning of the next visible section." + (interactive) + (if (eobp) + (user-error "No next section") + (let ((section (magit-current-section))) + (if (oref section parent) + (let ((next (and (not (oref section hidden)) + (not (= (oref section end) + (1+ (point)))) + (car (oref section children))))) + (while (and section (not next)) + (unless (setq next (car (magit-section-siblings section 'next))) + (setq section (oref section parent)))) + (if next + (magit-section-goto next) + (user-error "No next section"))) + (magit-section-goto 1))))) + +(defun magit-section-backward () + "Move to the beginning of the current or the previous visible section. +When point is at the beginning of a section then move to the +beginning of the previous visible section. Otherwise move to +the beginning of the current section." + (interactive) + (if (bobp) + (user-error "No previous section") + (let ((section (magit-current-section)) children) + (cond + ((and (= (point) + (1- (oref section end))) + (setq children (oref section children))) + (magit-section-goto (car (last children)))) + ((and (oref section parent) + (not (= (point) + (oref section start)))) + (magit-section-goto section)) + (t + (let ((prev (car (magit-section-siblings section 'prev)))) + (if prev + (while (and (not (oref prev hidden)) + (setq children (oref prev children))) + (setq prev (car (last children)))) + (setq prev (oref section parent))) + (cond (prev + (magit-section-goto prev)) + ((oref section parent) + (user-error "No previous section")) + ;; Eob special cases. + ((not (get-text-property (1- (point)) 'invisible)) + (magit-section-goto -1)) + (t + (goto-char (previous-single-property-change + (1- (point)) 'invisible)) + (forward-line -1) + (magit-section-goto (magit-current-section)))))))))) + +(defun magit-section-up () + "Move to the beginning of the parent section." + (interactive) + (--if-let (oref (magit-current-section) parent) + (magit-section-goto it) + (user-error "No parent section"))) + +(defun magit-section-forward-sibling () + "Move to the beginning of the next sibling section. +If there is no next sibling section, then move to the parent." + (interactive) + (let ((current (magit-current-section))) + (if (oref current parent) + (--if-let (car (magit-section-siblings current 'next)) + (magit-section-goto it) + (magit-section-forward)) + (magit-section-goto 1)))) + +(defun magit-section-backward-sibling () + "Move to the beginning of the previous sibling section. +If there is no previous sibling section, then move to the parent." + (interactive) + (let ((current (magit-current-section))) + (if (oref current parent) + (--if-let (car (magit-section-siblings current 'prev)) + (magit-section-goto it) + (magit-section-backward)) + (magit-section-goto -1)))) + +(defun magit-section-goto (arg) + (if (integerp arg) + (progn (forward-line arg) + (setq arg (magit-current-section))) + (goto-char (oref arg start))) + (run-hook-with-args 'magit-section-movement-hook arg)) + +(defun magit-section-set-window-start (section) + "Ensure the beginning of SECTION is visible." + (unless (pos-visible-in-window-p (oref section end)) + (set-window-start (selected-window) (oref section start)))) + +(defmacro magit-define-section-jumper (name heading type &optional value) + "Define an interactive function to go some section. +Together TYPE and VALUE identify the section. +HEADING is the displayed heading of the section." + (declare (indent defun)) + `(defun ,name (&optional expand) ,(format "\ +Jump to the section \"%s\". +With a prefix argument also expand it." heading) + (interactive "P") + (--if-let (magit-get-section + (cons (cons ',type ,value) + (magit-section-ident magit-root-section))) + (progn (goto-char (oref it start)) + (when expand + (with-local-quit (magit-section-show it)) + (recenter 0))) + (message ,(format "Section \"%s\" wasn't found" heading))))) + +;;;; Visibility + +(defun magit-section-show (section) + "Show the body of the current section." + (interactive (list (magit-current-section))) + (oset section hidden nil) + (magit-section--maybe-wash section) + (when-let ((beg (oref section content))) + (remove-overlays beg (oref section end) 'invisible t)) + (magit-section-maybe-update-visibility-indicator section) + (magit-section-maybe-cache-visibility section) + (dolist (child (oref section children)) + (if (oref child hidden) + (magit-section-hide child) + (magit-section-show child)))) + +(defun magit-section--maybe-wash (section) + (when-let ((washer (oref section washer))) + (oset section washer nil) + (let ((inhibit-read-only t) + (magit-insert-section--parent section) + (content (oref section content))) + (save-excursion + (if (and content (< content (oref section end))) + (funcall washer section) ; already partially washed (hunk) + (goto-char (oref section end)) + (oset section content (point-marker)) + (funcall washer) + (oset section end (point-marker))))) + (magit-section-update-highlight))) + +(defun magit-section-hide (section) + "Hide the body of the current section." + (interactive (list (magit-current-section))) + (if (eq section magit-root-section) + (user-error "Cannot hide root section") + (oset section hidden t) + (when-let ((beg (oref section content))) + (let ((end (oref section end))) + (remove-overlays beg end 'invisible t) + (let ((o (make-overlay beg end))) + (overlay-put o 'evaporate t) + (overlay-put o 'invisible t)))) + (magit-section-maybe-update-visibility-indicator section) + (magit-section-maybe-cache-visibility section))) + +(defun magit-section-toggle (section) + "Toggle visibility of the body of the current section." + (interactive (list (magit-current-section))) + (if (eq section magit-root-section) + (user-error "Cannot hide root section") + (goto-char (oref section start)) + (if (oref section hidden) + (magit-section-show section) + (magit-section-hide section)))) + +(defun magit-section-toggle-children (section) + "Toggle visibility of bodies of children of the current section." + (interactive (list (magit-current-section))) + (goto-char (oref section start)) + (let* ((children (oref section children)) + (show (--any-p (oref it hidden) children))) + (dolist (c children) + (oset c hidden show))) + (magit-section-show section)) + +(defun magit-section-show-children (section &optional depth) + "Recursively show the bodies of children of the current section. +With a prefix argument show children that deep and hide deeper +children." + (interactive (list (magit-current-section))) + (magit-section-show-children-1 section depth) + (magit-section-show section)) + +(defun magit-section-show-children-1 (section &optional depth) + (dolist (child (oref section children)) + (oset child hidden nil) + (if depth + (if (> depth 0) + (magit-section-show-children-1 child (1- depth)) + (magit-section-hide child)) + (magit-section-show-children-1 child)))) + +(defun magit-section-hide-children (section) + "Recursively hide the bodies of children of the current section." + (interactive (list (magit-current-section))) + (mapc 'magit-section-hide (oref section children))) + +(defun magit-section-show-headings (section) + "Recursively show headings of children of the current section. +Only show the headings, previously shown text-only bodies are +hidden." + (interactive (list (magit-current-section))) + (magit-section-show-headings-1 section) + (magit-section-show section)) + +(defun magit-section-show-headings-1 (section) + (dolist (child (oref section children)) + (oset child hidden nil) + (when (or (oref child children) + (not (oref child content))) + (magit-section-show-headings-1 child)))) + +(defun magit-section-cycle (section) + "Cycle visibility of current section and its children." + (interactive (list (magit-current-section))) + (goto-char (oref section start)) + (if (oref section hidden) + (progn (magit-section-show section) + (magit-section-hide-children section)) + (let ((children (oref section children))) + (cond ((and (--any-p (oref it hidden) children) + (--any-p (oref it children) children)) + (magit-section-show-headings section)) + ((-any-p 'magit-section-hidden-body children) + (magit-section-show-children section)) + (t + (magit-section-hide section)))))) + +(defun magit-section-cycle-global () + "Cycle visibility of all sections in the current buffer." + (interactive) + (let ((children (oref magit-root-section children))) + (cond ((and (--any-p (oref it hidden) children) + (--any-p (oref it children) children)) + (magit-section-show-headings magit-root-section)) + ((-any-p 'magit-section-hidden-body children) + (magit-section-show-children magit-root-section)) + (t + (mapc 'magit-section-hide children))))) + +(defun magit-section-hidden-body (section &optional pred) + (--if-let (oref section children) + (funcall (or pred '-any-p) 'magit-section-hidden-body it) + (and (oref section content) + (oref section hidden)))) + +(defun magit-section-invisible-p (section) + "Return t if the SECTION's body is invisible. +When the body of an ancestor of SECTION is collapsed then +SECTION's body (and heading) obviously cannot be visible." + (or (oref section hidden) + (--when-let (oref section parent) + (magit-section-invisible-p it)))) + +(defun magit-section-show-level (level) + "Show surrounding sections up to LEVEL. +If LEVEL is negative, show up to the absolute value. +Sections at higher levels are hidden." + (if (< level 0) + (let ((s (magit-current-section))) + (setq level (- level)) + (while (> (1- (length (magit-section-ident s))) level) + (setq s (oref s parent)) + (goto-char (oref s start))) + (magit-section-show-children magit-root-section (1- level))) + (cl-do* ((s (magit-current-section) + (oref s parent)) + (i (1- (length (magit-section-ident s))) + (cl-decf i))) + ((cond ((< i level) (magit-section-show-children s (- level i 1)) t) + ((= i level) (magit-section-hide s) t)) + (magit-section-goto s))))) + +(defun magit-section-show-level-1 () + "Show surrounding sections on first level." + (interactive) + (magit-section-show-level 1)) + +(defun magit-section-show-level-1-all () + "Show all sections on first level." + (interactive) + (magit-section-show-level -1)) + +(defun magit-section-show-level-2 () + "Show surrounding sections up to second level." + (interactive) + (magit-section-show-level 2)) + +(defun magit-section-show-level-2-all () + "Show all sections up to second level." + (interactive) + (magit-section-show-level -2)) + +(defun magit-section-show-level-3 () + "Show surrounding sections up to third level." + (interactive) + (magit-section-show-level 3)) + +(defun magit-section-show-level-3-all () + "Show all sections up to third level." + (interactive) + (magit-section-show-level -3)) + +(defun magit-section-show-level-4 () + "Show surrounding sections up to fourth level." + (interactive) + (magit-section-show-level 4)) + +(defun magit-section-show-level-4-all () + "Show all sections up to fourth level." + (interactive) + (magit-section-show-level -4)) + +;;;; Auxiliary + +(defun magit-describe-section-briefly (section &optional ident) + "Show information about the section at point. +With a prefix argument show the section identity instead of the +section lineage. This command is intended for debugging purposes." + (interactive (list (magit-current-section) current-prefix-arg)) + (let ((str (format "#<%s %S %S %s-%s>" + (eieio-object-class section) + (let ((val (oref section value))) + (cond ((stringp val) + (substring-no-properties val)) + ((and (eieio-object-p val) + (fboundp 'cl-prin1-to-string)) + (cl-prin1-to-string val)) + (t + val))) + (if ident + (magit-section-ident section) + (apply #'vector (magit-section-lineage section))) + (when-let ((m (oref section start))) + (marker-position m)) + (when-let ((m (oref section end))) + (marker-position m))))) + (if (called-interactively-p 'any) + (message "%s" str) + str))) + +(cl-defmethod cl-print-object ((section magit-section) stream) + "Print `magit-describe-section' result of SECTION." + ;; Used by debug and edebug as of Emacs 26. + (princ (magit-describe-section-briefly section) stream)) + +(defun magit-describe-section (section &optional interactive-p) + "Show information about the section at point." + (interactive (list (magit-current-section) t)) + (let ((inserter-section section)) + (while (and inserter-section (not (oref inserter-section inserter))) + (setq inserter-section (oref inserter-section parent))) + (when (and inserter-section (oref inserter-section inserter)) + (setq section inserter-section))) + (pcase (oref section inserter) + (`((,hook ,fun) . ,src-src) + (help-setup-xref `(magit-describe-section ,section) interactive-p) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert (format-message + "%s\n is inserted by `%s'\n from `%s'" + (magit-describe-section-briefly section) + (make-text-button (symbol-name fun) nil + :type 'help-function + 'help-args (list fun)) + (make-text-button (symbol-name hook) nil + :type 'help-variable + 'help-args (list hook)))) + (pcase-dolist (`(,hook ,fun) src-src) + (insert (format-message + ",\n called by `%s'\n from `%s'" + (make-text-button (symbol-name fun) nil + :type 'help-function + 'help-args (list fun)) + (make-text-button (symbol-name hook) nil + :type 'help-variable + 'help-args (list hook))))) + (insert ".\n\n") + (insert + (format-message + "`%s' is " + (make-text-button (symbol-name fun) nil + :type 'help-function 'help-args (list fun)))) + (describe-function-1 fun)))) + (_ (message "%s, inserter unknown" + (magit-describe-section-briefly section))))) + +;;; Match + +(cl-defun magit-section-match + (condition &optional (section (magit-current-section))) + "Return t if SECTION matches CONDITION. + +SECTION defaults to the section at point. If SECTION is not +specified and there also is no section at point, then return +nil. + +CONDITION can take the following forms: + (CONDITION...) matches if any of the CONDITIONs matches. + [CLASS...] matches if the section's class is the same + as the first CLASS or a subclass of that; + the section's parent class matches the + second CLASS; and so on. + [* CLASS...] matches sections that match [CLASS...] and + also recursively all their child sections. + CLASS matches if the section's class is the same + as CLASS or a subclass of that; regardless + of the classes of the parent sections. + +Each CLASS should be a class symbol, identifying a class that +derives from `magit-section'. For backward compatibility CLASS +can also be a \"type symbol\". A section matches such a symbol +if the value of its `type' slot is `eq'. If a type symbol has +an entry in `magit--section-type-alist', then a section also +matches that type if its class is a subclass of the class that +corresponds to the type as per that alist. + +Note that it is not necessary to specify the complete section +lineage as printed by `magit-describe-section-briefly', unless +of course you want to be that precise." + (and section (magit-section-match-1 condition section))) + +(defun magit-section-match-1 (condition section) + (cl-assert condition) + (and section + (if (listp condition) + (--first (magit-section-match-1 it section) condition) + (magit-section-match-2 (if (symbolp condition) + (list condition) + (cl-coerce condition 'list)) + section)))) + +(defun magit-section-match-2 (condition section) + (if (eq (car condition) '*) + (or (magit-section-match-2 (cdr condition) section) + (when-let ((parent (oref section parent))) + (magit-section-match-2 condition parent))) + (and (let ((c (car condition))) + (if (class-p c) + (cl-typep section c) + (if-let ((class (cdr (assq c magit--section-type-alist)))) + (cl-typep section class) + (eq (oref section type) c)))) + (or (not (setq condition (cdr condition))) + (when-let ((parent (oref section parent))) + (magit-section-match-2 condition parent)))))) + +(defun magit-section-value-if (condition &optional section) + "If the section at point matches CONDITION, then return its value. + +If optional SECTION is non-nil then test whether that matches +instead. If there is no section at point and SECTION is nil, +then return nil. If the section does not match, then return +nil. + +See `magit-section-match' for the forms CONDITION can take." + (when-let ((section (or section (magit-current-section)))) + (and (magit-section-match condition section) + (oref section value)))) + +(defmacro magit-section-when (condition &rest body) + "If the section at point matches CONDITION, evaluate BODY. + +If the section matches, then evaluate BODY forms sequentially +with `it' bound to the section and return the value of the last +form. If there are no BODY forms, then return the value of the +section. If the section does not match or if there is no section +at point, then return nil. + +See `magit-section-match' for the forms CONDITION can take." + (declare (obsolete + "instead use `magit-section-match' or `magit-section-value-if'." + "Magit 2.90.0") + (indent 1) + (debug (sexp body))) + `(--when-let (magit-current-section) + ;; Quoting CONDITION here often leads to double-quotes, which + ;; isn't an issue because `magit-section-match-1' implicitly + ;; deals with that. We shouldn't force users of this function + ;; to not quote CONDITION because that would needlessly break + ;; backward compatibility. + (when (magit-section-match ',condition it) + ,@(or body '((oref it value)))))) + +(defmacro magit-section-case (&rest clauses) + "Choose among clauses on the type of the section at point. + +Each clause looks like (CONDITION BODY...). The type of the +section is compared against each CONDITION; the BODY forms of the +first match are evaluated sequentially and the value of the last +form is returned. Inside BODY the symbol `it' is bound to the +section at point. If no clause succeeds or if there is no +section at point, return nil. + +See `magit-section-match' for the forms CONDITION can take. +Additionally a CONDITION of t is allowed in the final clause, and +matches if no other CONDITION match, even if there is no section +at point." + (declare (indent 0) + (debug (&rest (sexp body)))) + `(let* ((it (magit-current-section))) + (cond ,@(mapcar (lambda (clause) + `(,(or (eq (car clause) t) + `(and it + (magit-section-match-1 ',(car clause) it))) + ,@(cdr clause))) + clauses)))) + +(defun magit-section-match-assoc (section alist) + "Return the value associated with SECTION's type or lineage in ALIST." + (-some (pcase-lambda (`(,key . ,val)) + (and (magit-section-match-1 key section) val)) + alist)) + +;;; Create + +(defvar magit-insert-section-hook nil + "Hook run after `magit-insert-section's BODY. +Avoid using this hook and only ever do so if you know +what you are doing and are sure there is no other way.") + +(defmacro magit-insert-section (&rest args) + "Insert a section at point. + +TYPE is the section type, a symbol which is prefixed with the +name of the package. (For historic reasons the types used by +Magit and Forge do not use a package prefix.) Many commands +that act on the current section behave differently depending +on its type. + +Optional VALUE is the value of the section, usually a string +that is required when acting on the section. + +When optional HIDE is non-nil collapse the section body by +default, i.e. when first creating the section, but not when +refreshing the buffer. Else expand it by default. This can be +overwritten using `magit-section-set-visibility-hook'. When a +section is recreated during a refresh, then the visibility of +predecessor is inherited and HIDE is ignored (but the hook is +still honored). + +BODY is any number of forms that actually insert the section's +heading and body. Optional NAME, if specified, has to be a +symbol, which is then bound to the object of the section being +inserted. + +Before BODY is evaluated the `start' of the section object is set +to the value of `point' and after BODY was evaluated its `end' is +set to the new value of `point'; BODY is responsible for moving +`point' forward. + +If it turns out inside BODY that the section is empty, then +`magit-cancel-section' can be used to abort and remove all traces +of the partially inserted section. This can happen when creating +a section by washing Git's output and Git didn't actually output +anything this time around. + +For historic reasons, if a variable `magit-TYPE-section-map' +or `forge-TYPE-section-map' exists, then use that as the +text-property `keymap' of all text belonging to the section (but +this may be overwritten in subsections). TYPE can also have the +form `(eval FORM)' in which case FORM is evaluated at runtime. + +\(fn [NAME] (TYPE &optional VALUE HIDE) &rest BODY)" + (declare (indent defun) + (debug ([&optional symbolp] + (&or [("eval" symbolp) &optional form form] + [symbolp &optional form form]) + body))) + (let ((tp (cl-gensym "type")) + (s* (and (symbolp (car args)) + (pop args))) + (s (cl-gensym "section"))) + `(let* ((,tp ,(let ((type (nth 0 (car args)))) + (if (eq (car-safe type) 'eval) + (cadr type) + `',type))) + (,s (funcall (if (class-p ,tp) + ,tp + (or (cdr (assq ,tp magit--section-type-alist)) + 'magit-section)) + :type + (if (class-p ,tp) + (or (car (rassq ,tp magit--section-type-alist)) + (error "BUG: No entry for %s in %s" ,tp + 'magit--section-type-alist)) + ,tp) + :value ,(nth 1 (car args)) + :start (point-marker) + :parent magit-insert-section--parent))) + (oset ,s hidden + (if-let ((value (run-hook-with-args-until-success + 'magit-section-set-visibility-hook ,s))) + (eq value 'hide) + (if-let ((incarnation (and magit-insert-section--oldroot + (magit-get-section + (magit-section-ident ,s) + magit-insert-section--oldroot)))) + (oref incarnation hidden) + (if-let ((value (magit-section-match-assoc + ,s magit-section-initial-visibility-alist))) + (progn + (when (functionp value) + (setq value (funcall value ,s))) + (eq value 'hide)) + ,(nth 2 (car args)))))) + (let ((magit-insert-section--current ,s) + (magit-insert-section--parent ,s) + (magit-insert-section--oldroot + (or magit-insert-section--oldroot + (unless magit-insert-section--parent + (prog1 magit-root-section + (setq magit-root-section ,s)))))) + (catch 'cancel-section + ,@(if s* + `((let ((,s* ,s)) + ,@(cdr args))) + (cdr args)) + ;; `magit-insert-section-hook' should *not* be run with + ;; `magit-run-section-hook' because it's a hook that runs + ;; on section insertion, not a section inserting hook. + (run-hooks 'magit-insert-section-hook) + (magit-insert-child-count ,s) + (set-marker-insertion-type (oref ,s start) t) + (let* ((end (oset ,s end (point-marker))) + (class-map (oref-default ,s keymap)) + (magit-map (intern (format "magit-%s-section-map" + (oref ,s type)))) + (forge-map (intern (format "forge-%s-section-map" + (oref ,s type)))) + (map (or (and class-map (symbol-value class-map)) + (and (boundp magit-map) (symbol-value magit-map)) + (and (boundp forge-map) (symbol-value forge-map))))) + (save-excursion + (goto-char (oref ,s start)) + (while (< (point) end) + (let ((next (or (next-single-property-change + (point) 'magit-section) + end))) + (unless (get-text-property (point) 'magit-section) + (put-text-property (point) next 'magit-section ,s) + (when map + (put-text-property (point) next 'keymap map))) + (goto-char next))))) + (if (eq ,s magit-root-section) + (let ((magit-section-cache-visibility nil)) + (magit-section-show ,s)) + (oset (oref ,s parent) children + (nconc (oref (oref ,s parent) children) + (list ,s))))) + ,s)))) + +(defun magit-cancel-section () + "Cancel inserting the section that is currently being inserted. +Remove all traces of that section." + (when magit-insert-section--current + (if (not (oref magit-insert-section--current parent)) + (insert "(empty)\n") + (delete-region (oref magit-insert-section--current start) + (point)) + (setq magit-insert-section--current nil) + (throw 'cancel-section nil)))) + +(defun magit-insert-heading (&rest args) + "Insert the heading for the section currently being inserted. + +This function should only be used inside `magit-insert-section'. + +When called without any arguments, then just set the `content' +slot of the object representing the section being inserted to +a marker at `point'. The section should only contain a single +line when this function is used like this. + +When called with arguments ARGS, which have to be strings, or +nil, then insert those strings at point. The section should not +contain any text before this happens and afterwards it should +again only contain a single line. If the `face' property is set +anywhere inside any of these strings, then insert all of them +unchanged. Otherwise use the `magit-section-heading' face for +all inserted text. + +The `content' property of the section object is the end of the +heading (which lasts from `start' to `content') and the beginning +of the the body (which lasts from `content' to `end'). If the +value of `content' is nil, then the section has no heading and +its body cannot be collapsed. If a section does have a heading, +then its height must be exactly one line, including a trailing +newline character. This isn't enforced, you are responsible for +getting it right. The only exception is that this function does +insert a newline character if necessary." + (declare (indent defun)) + (when args + (let ((heading (apply #'concat args))) + (insert (if (or (text-property-not-all 0 (length heading) + 'font-lock-face nil heading) + (text-property-not-all 0 (length heading) + 'face nil heading)) + heading + (propertize heading 'font-lock-face 'magit-section-heading))))) + (unless (bolp) + (insert ?\n)) + (when (fboundp 'magit-maybe-make-margin-overlay) + (magit-maybe-make-margin-overlay)) + (oset magit-insert-section--current content (point-marker))) + +(defmacro magit-insert-section-body (&rest body) + "Use BODY to insert the section body, once the section is expanded. +If the section is expanded when it is created, then this is +like `progn'. Otherwise BODY isn't evaluated until the section +is explicitly expanded." + (declare (indent 0)) + (let ((f (cl-gensym)) + (s (cl-gensym))) + `(let ((,f (lambda () ,@body)) + (,s magit-insert-section--current)) + (if (oref ,s hidden) + (oset ,s washer + (lambda () + (funcall ,f) + (magit-section-maybe-remove-visibility-indicator ,s))) + (funcall ,f))))) + +(defun magit-insert-headers (hook) + (let* ((header-sections nil) + (magit-insert-section-hook + (cons (lambda () + (push magit-insert-section--current + header-sections)) + (if (listp magit-insert-section-hook) + magit-insert-section-hook + (list magit-insert-section-hook))))) + (magit-run-section-hook hook) + (when header-sections + (insert "\n") + ;; Make the first header into the parent of the rest. + (when (cdr header-sections) + (cl-callf nreverse header-sections) + (let* ((1st-header (pop header-sections)) + (header-parent (oref 1st-header parent))) + (oset header-parent children (list 1st-header)) + (oset 1st-header children header-sections) + (oset 1st-header content (oref (car header-sections) start)) + (oset 1st-header end (oref (car (last header-sections)) end)) + (dolist (sub-header header-sections) + (oset sub-header parent 1st-header))))))) + +(defun magit-insert-child-count (section) + "Modify SECTION's heading to contain number of child sections. + +If `magit-section-show-child-count' is non-nil and the SECTION +has children and its heading ends with \":\", then replace that +with \" (N)\", where N is the number of child sections. + +This function is called by `magit-insert-section' after that has +evaluated its BODY. Admittedly that's a bit of a hack." + ;; This has to be fast, not pretty! + (let (content count) + (when (and magit-section-show-child-count + (setq count (length (oref section children))) + (> count 0) + (setq content (oref section content)) + (eq (char-before (1- content)) ?:)) + (save-excursion + (goto-char (- content 2)) + (insert (format " (%s)" count)) + (delete-char 1))))) + +;;; Highlight + +(defvar-local magit-section-highlight-overlays nil) +(defvar-local magit-section-highlighted-section nil) +(defvar-local magit-section-highlighted-sections nil) +(defvar-local magit-section-unhighlight-sections nil) +(defun magit-section-update-highlight () + (let ((section (magit-current-section))) + (unless (eq section magit-section-highlighted-section) + (let ((inhibit-read-only t) + (deactivate-mark nil) + (selection (magit-region-sections))) + (mapc #'delete-overlay magit-section-highlight-overlays) + (setq magit-section-highlight-overlays nil) + (setq magit-section-unhighlight-sections + magit-section-highlighted-sections) + (setq magit-section-highlighted-sections nil) + (unless (eq section magit-root-section) + (run-hook-with-args-until-success + 'magit-section-highlight-hook section selection)) + (dolist (s magit-section-unhighlight-sections) + (run-hook-with-args-until-success + 'magit-section-unhighlight-hook s selection)) + (restore-buffer-modified-p nil) + (unless (eq magit-section-highlighted-section section) + (setq magit-section-highlighted-section + (and (not (oref section hidden)) + section))))) + (magit-section-maybe-paint-visibility-ellipses))) + +(defun magit-section-highlight (section selection) + "Highlight SECTION and if non-nil all sections in SELECTION. +This function works for any section but produces undesirable +effects for diff related sections, which by default are +highlighted using `magit-diff-highlight'. Return t." + (when-let ((face (oref section heading-highlight-face))) + (dolist (section (or selection (list section))) + (magit-section-make-overlay + (oref section start) + (or (oref section content) + (oref section end)) + face))) + (cond (selection + (magit-section-make-overlay (oref (car selection) start) + (oref (car (last selection)) end) + 'magit-section-highlight) + (magit-section-highlight-selection nil selection)) + (t + (magit-section-make-overlay (oref section start) + (oref section end) + 'magit-section-highlight))) + t) + +(defun magit-section-highlight-selection (_ selection) + "Highlight the section-selection region. +If SELECTION is non-nil, then it is a list of sections selected by +the region. The headings of these sections are then highlighted. + +This is a fallback for people who don't want to highlight the +current section and therefore removed `magit-section-highlight' +from `magit-section-highlight-hook'. + +This function is necessary to ensure that a representation of +such a region is visible. If neither of these functions were +part of the hook variable, then such a region would be +invisible." + (when (and selection + (not (and (eq this-command 'mouse-drag-region)))) + (dolist (section selection) + (magit-section-make-overlay (oref section start) + (or (oref section content) + (oref section end)) + 'magit-section-heading-selection)) + t)) + +(defun magit-section-make-overlay (start end face) + ;; Yes, this doesn't belong here. But the alternative of + ;; spreading this hack across the code base is even worse. + (when (and magit-keep-region-overlay + (memq face '(magit-section-heading-selection + magit-diff-file-heading-selection + magit-diff-hunk-heading-selection))) + (setq face (list :foreground (face-foreground face)))) + (let ((ov (make-overlay start end nil t))) + (overlay-put ov 'font-lock-face face) + (overlay-put ov 'evaporate t) + (push ov magit-section-highlight-overlays) + ov)) + +(defun magit-section-goto-successor (section line char arg) + (let ((ident (magit-section-ident section))) + (--if-let (magit-get-section ident) + (let ((start (oref it start))) + (goto-char start) + (unless (eq it magit-root-section) + (ignore-errors + (forward-line line) + (forward-char char)) + (unless (eq (magit-current-section) it) + (goto-char start)))) + (or (run-hook-with-args-until-success + 'magit-section-goto-successor-hook section arg) + (goto-char (--if-let (magit-section-goto-successor-1 section) + (if (eq (oref it type) 'button) + (point-min) + (oref it start)) + (point-min))))))) + +(defun magit-section-goto-successor-1 (section) + (or (--when-let (pcase (oref section type) + (`staged 'unstaged) + (`unstaged 'staged) + (`unpushed 'unpulled) + (`unpulled 'unpushed)) + (magit-get-section `((,it) (status)))) + (--when-let (car (magit-section-siblings section 'next)) + (magit-get-section (magit-section-ident it))) + (--when-let (car (magit-section-siblings section 'prev)) + (magit-get-section (magit-section-ident it))) + (--when-let (oref section parent) + (or (magit-get-section (magit-section-ident it)) + (magit-section-goto-successor-1 it))))) + +;;; Region + +(defvar-local magit-section--region-overlays nil) + +(defun magit-section--delete-region-overlays () + (mapc #'delete-overlay magit-section--region-overlays) + (setq magit-section--region-overlays nil)) + +(defun magit-section--highlight-region (start end window rol) + (magit-section--delete-region-overlays) + (if (and (not magit-keep-region-overlay) + (or (magit-region-sections) + (run-hook-with-args-until-success 'magit-region-highlight-hook + (magit-current-section))) + (not (= (line-number-at-pos start) + (line-number-at-pos end))) + ;; (not (eq (car-safe last-command-event) 'mouse-movement)) + ) + (funcall (default-value 'redisplay-unhighlight-region-function) rol) + (funcall (default-value 'redisplay-highlight-region-function) + start end window rol))) + +(defun magit-section--unhighlight-region (rol) + (setq magit-section-highlighted-section nil) + (magit-section--delete-region-overlays) + (funcall (default-value 'redisplay-unhighlight-region-function) rol)) + +;;; Visibility + +(defvar-local magit-section-visibility-cache nil) +(put 'magit-section-visibility-cache 'permanent-local t) + +(defun magit-section-cached-visibility (section) + "Set SECTION's visibility to the cached value." + (cdr (assoc (magit-section-ident section) + magit-section-visibility-cache))) + +(cl-defun magit-section-cache-visibility + (&optional (section magit-insert-section--current)) + ;; Emacs 25's `alist-get' lacks TESTFN. + (let* ((id (magit-section-ident section)) + (elt (assoc id magit-section-visibility-cache)) + (val (if (oref section hidden) 'hide 'show))) + (if elt + (setcdr elt val) + (push (cons id val) magit-section-visibility-cache)))) + +(cl-defun magit-section-maybe-cache-visibility + (&optional (section magit-insert-section--current)) + (when (or (eq magit-section-cache-visibility t) + (memq (oref section type) + magit-section-cache-visibility)) + (magit-section-cache-visibility section))) + +(defun magit-section-maybe-update-visibility-indicator (section) + (when magit-section-visibility-indicator + (let ((beg (oref section start)) + (cnt (oref section content)) + (end (oref section end))) + (when (and cnt (or (not (= cnt end)) (oref section washer))) + (let ((eoh (save-excursion + (goto-char beg) + (line-end-position)))) + (cond + ((symbolp (car-safe magit-section-visibility-indicator)) + ;; It would make more sense to put the overlay only on the + ;; location we actually don't put it on, but then inserting + ;; before that location (while taking care not to mess with + ;; the overlay) would cause the fringe bitmap to disappear + ;; (but not other effects of the overlay). + (let ((ov (magit--overlay-at (1+ beg) 'magit-vis-indicator 'fringe))) + (unless ov + (setq ov (make-overlay (1+ beg) eoh)) + (overlay-put ov 'evaporate t) + (overlay-put ov 'magit-vis-indicator 'fringe)) + (overlay-put + ov 'before-string + (propertize "fringe" 'display + (list 'left-fringe + (if (oref section hidden) + (car magit-section-visibility-indicator) + (cdr magit-section-visibility-indicator)) + (face-foreground 'fringe)))))) + ((stringp (car-safe magit-section-visibility-indicator)) + (let ((ov (magit--overlay-at (1- eoh) 'magit-vis-indicator 'eoh))) + (cond ((oref section hidden) + (unless ov + (setq ov (make-overlay (1- eoh) eoh)) + (overlay-put ov 'evaporate t) + (overlay-put ov 'magit-vis-indicator 'eoh)) + (overlay-put ov 'after-string + (car magit-section-visibility-indicator))) + (ov + (delete-overlay ov))))))))))) + +(defvar-local magit--ellipses-sections nil) + +(defun magit-section-maybe-paint-visibility-ellipses () + ;; This is needed because we hide the body instead of "the body + ;; except the final newline and additionally the newline before + ;; the body"; otherwise we could use `buffer-invisibility-spec'. + (when (stringp (car-safe magit-section-visibility-indicator)) + (let* ((sections (append magit--ellipses-sections + (setq magit--ellipses-sections + (or (magit-region-sections) + (list (magit-current-section)))))) + (beg (--map (oref it start) sections)) + (end (--map (oref it end) sections))) + (when (region-active-p) + ;; This ensures that the region face is removed from ellipses + ;; when the region becomes inactive, but fails to ensure that + ;; all ellipses within the active region use the region face, + ;; because the respective overlay has not yet been updated at + ;; this time. The magit-selection face is always applied. + (push (region-beginning) beg) + (push (region-end) end)) + (setq beg (apply #'min beg)) + (setq end (apply #'max end)) + (dolist (ov (overlays-in beg end)) + (when (eq (overlay-get ov 'magit-vis-indicator) 'eoh) + (overlay-put + ov 'after-string + (propertize + (car magit-section-visibility-indicator) 'font-lock-face + (let ((pos (overlay-start ov))) + (delq nil (nconc (--map (overlay-get it 'font-lock-face) + (overlays-at pos)) + (list (get-char-property + pos 'font-lock-face)))))))))))) + +(defun magit-section-maybe-remove-visibility-indicator (section) + (when (and magit-section-visibility-indicator + (= (oref section content) + (oref section end))) + (dolist (o (overlays-in (oref section start) + (save-excursion + (goto-char (oref section start)) + (1+ (line-end-position))))) + (when (overlay-get o 'magit-vis-indicator) + (delete-overlay o))))) + +;;; Utilities + +(cl-defun magit-section-selected-p (section &optional (selection nil sselection)) + (and (not (eq section magit-root-section)) + (or (eq section (magit-current-section)) + (memq section (if sselection + selection + (setq selection (magit-region-sections)))) + (--when-let (oref section parent) + (magit-section-selected-p it selection))))) + +(defun magit-section-parent-value (section) + (when-let ((parent (oref section parent))) + (oref parent value))) + +(defun magit-section-siblings (section &optional direction) + "Return a list of the sibling sections of SECTION. + +If optional DIRECTION is `prev', then return siblings that come +before SECTION. If it is `next', then return siblings that come +after SECTION. For all other values, return all siblings +excluding SECTION itself." + (when-let ((parent (oref section parent))) + (let ((siblings (oref parent children))) + (pcase direction + (`prev (cdr (member section (reverse siblings)))) + (`next (cdr (member section siblings))) + (_ (remq section siblings)))))) + +(defun magit-region-values (&optional condition multiple) + "Return a list of the values of the selected sections. + +Return the values that themselves would be returned by +`magit-region-sections' (which see)." + (--map (oref it value) + (magit-region-sections condition multiple))) + +(defun magit-region-sections (&optional condition multiple) + "Return a list of the selected sections. + +When the region is active and constitutes a valid section +selection, then return a list of all selected sections. This is +the case when the region begins in the heading of a section and +ends in the heading of the same section or in that of a sibling +section. If optional MULTIPLE is non-nil, then the region cannot +begin and end in the same section. + +When the selection is not valid, then return nil. In this case, +most commands that can act on the selected sections will instead +act on the section at point. + +When the region looks like it would in any other buffer then +the selection is invalid. When the selection is valid then the +region uses the `magit-section-highlight' face. This does not +apply to diffs where things get a bit more complicated, but even +here if the region looks like it usually does, then that's not +a valid selection as far as this function is concerned. + +If optional CONDITION is non-nil, then the selection not only +has to be valid; all selected sections additionally have to match +CONDITION, or nil is returned. See `magit-section-match' for the +forms CONDITION can take." + (when (region-active-p) + (let* ((rbeg (region-beginning)) + (rend (region-end)) + (sbeg (get-text-property rbeg 'magit-section)) + (send (get-text-property rend 'magit-section))) + (when (and send + (not (eq send magit-root-section)) + (not (and multiple (eq send sbeg)))) + (let ((siblings (cons sbeg (magit-section-siblings sbeg 'next))) + sections) + (when (and (memq send siblings) + (magit-section-position-in-heading-p sbeg rbeg) + (magit-section-position-in-heading-p send rend)) + (while siblings + (push (car siblings) sections) + (when (eq (pop siblings) send) + (setq siblings nil))) + (setq sections (nreverse sections)) + (when (or (not condition) + (--all-p (magit-section-match condition it) sections)) + sections))))))) + +(defun magit-section-position-in-heading-p (&optional section pos) + "Return t if POSITION is inside the heading of SECTION. +POSITION defaults to point and SECTION defaults to the +current section." + (unless section + (setq section (magit-current-section))) + (unless pos + (setq pos (point))) + (and section + (>= pos (oref section start)) + (< pos (or (oref section content) + (oref section end))) + t)) + +(defun magit-section-internal-region-p (&optional section) + "Return t if the region is active and inside SECTION's body. +If optional SECTION is nil, use the current section." + (and (region-active-p) + (or section (setq section (magit-current-section))) + (let ((beg (get-text-property (region-beginning) 'magit-section))) + (and (eq beg (get-text-property (region-end) 'magit-section)) + (eq beg section))) + (not (or (magit-section-position-in-heading-p section (region-beginning)) + (magit-section-position-in-heading-p section (region-end)))) + t)) + +(defun magit-section--backward-protected () + "Move to the beginning of the current or the previous visible section. +Same as `magit-section-backward' but for non-interactive use. +Suppress `magit-section-movement-hook', and return a boolean to +indicate whether a section was found, instead of raising an error +if not." + (condition-case nil + (let ((magit-section-movement-hook nil)) + (magit-section-backward) + t) + (user-error nil))) + +(defun magit-section--backward-find (predicate) + "Move to the first previous section satisfying PREDICATE. +PREDICATE does not take any parameter and should not move +point." + (let (found) + (while (and (setq found (magit-section--backward-protected)) + (not (funcall predicate)))) + found)) + +(defun magit-wash-sequence (function) + "Repeatedly call FUNCTION until it returns nil or eob is reached. +FUNCTION has to move point forward or return nil." + (while (and (not (eobp)) (funcall function)))) + +(defun magit-add-section-hook (hook function &optional at append local) + "Add to the value of section hook HOOK the function FUNCTION. + +Add FUNCTION at the beginning of the hook list unless optional +APPEND is non-nil, in which case FUNCTION is added at the end. +If FUNCTION already is a member, then move it to the new location. + +If optional AT is non-nil and a member of the hook list, then +add FUNCTION next to that instead. Add before or after AT, or +replace AT with FUNCTION depending on APPEND. If APPEND is the +symbol `replace', then replace AT with FUNCTION. For any other +non-nil value place FUNCTION right after AT. If nil, then place +FUNCTION right before AT. If FUNCTION already is a member of the +list but AT is not, then leave FUNCTION where ever it already is. + +If optional LOCAL is non-nil, then modify the hook's buffer-local +value rather than its global value. This makes the hook local by +copying the default value. That copy is then modified. + +HOOK should be a symbol. If HOOK is void, it is first set to nil. +HOOK's value must not be a single hook function. FUNCTION should +be a function that takes no arguments and inserts one or multiple +sections at point, moving point forward. FUNCTION may choose not +to insert its section(s), when doing so would not make sense. It +should not be abused for other side-effects. To remove FUNCTION +again use `remove-hook'." + (unless (boundp hook) + (error "Cannot add function to undefined hook variable %s" hook)) + (unless (default-boundp hook) + (set-default hook nil)) + (let ((value (if local + (if (local-variable-p hook) + (symbol-value hook) + (unless (local-variable-if-set-p hook) + (make-local-variable hook)) + (copy-sequence (default-value hook))) + (default-value hook)))) + (if at + (when (setq at (member at value)) + (setq value (delq function value)) + (cond ((eq append 'replace) + (setcar at function)) + (append + (push function (cdr at))) + (t + (push (car at) (cdr at)) + (setcar at function)))) + (setq value (delq function value))) + (unless (member function value) + (setq value (if append + (append value (list function)) + (cons function value)))) + (when (eq append 'replace) + (setq value (delq at value))) + (if local + (set hook value) + (set-default hook value)))) + +(defvar-local magit-disabled-section-inserters nil) + +(defun magit-disable-section-inserter (fn) + "Disable the section inserter FN in the current repository. +It is only intended for use in \".dir-locals.el\" and +\".dir-locals-2.el\". Also see info node `(magit)Per-Repository +Configuration'." + (cl-pushnew fn magit-disabled-section-inserters)) + +(put 'magit-disable-section-inserter 'safe-local-eval-function t) + +(defun magit-run-section-hook (hook &rest args) + "Run HOOK with ARGS, warning about invalid entries." + (let ((entries (symbol-value hook))) + (unless (listp entries) + (setq entries (list entries))) + (--when-let (-remove #'functionp entries) + (message "`%s' contains entries that are no longer valid. +%s\nUsing standard value instead. Please re-configure hook variable." + hook + (mapconcat (lambda (sym) (format " `%s'" sym)) it "\n")) + (sit-for 5) + (setq entries (eval (car (get hook 'standard-value))))) + (dolist (entry entries) + (let ((magit--current-section-hook (cons (list hook entry) + magit--current-section-hook))) + (unless (memq entry magit-disabled-section-inserters) + (if (bound-and-true-p magit-refresh-verbose) + (message " %-50s %s" entry + (benchmark-elapse (apply entry args))) + (apply entry args))))))) + +(cl-defun magit--overlay-at (pos prop &optional (val nil sval) testfn) + (cl-find-if (lambda (o) + (let ((p (overlay-properties o))) + (and (plist-member p prop) + (or (not sval) + (funcall (or testfn #'eql) + (plist-get p prop) + val))))) + (overlays-at pos t))) + +;;; _ +(provide 'magit-section) +;;; magit-section.el ends here diff --git a/elpa/magit-20200318.1224/magit-section.elc b/elpa/magit-20200318.1224/magit-section.elc new file mode 100644 index 00000000..48c150e7 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-section.elc differ diff --git a/elpa/magit-20200318.1224/magit-sequence.el b/elpa/magit-20200318.1224/magit-sequence.el new file mode 100644 index 00000000..d0275665 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-sequence.el @@ -0,0 +1,1041 @@ +;;; magit-sequence.el --- history manipulation in Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Support for Git commands that replay commits and help the user make +;; changes along the way. Supports `cherry-pick', `revert', `rebase', +;; `rebase--interactive' and `am'. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;; For `magit-rebase--todo'. +(declare-function git-rebase-current-line "git-rebase" ()) +(eval-when-compile + (cl-pushnew 'action-type eieio--known-slot-names) + (cl-pushnew 'action eieio--known-slot-names) + (cl-pushnew 'action-options eieio--known-slot-names) + (cl-pushnew 'target eieio--known-slot-names)) + +;;; Options +;;;; Faces + +(defface magit-sequence-pick + '((t :inherit default)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-stop + '((((class color) (background light)) :foreground "DarkOliveGreen4") + (((class color) (background dark)) :foreground "DarkSeaGreen2")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-part + '((((class color) (background light)) :foreground "Goldenrod4") + (((class color) (background dark)) :foreground "LightGoldenrod2")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-head + '((((class color) (background light)) :foreground "SkyBlue4") + (((class color) (background dark)) :foreground "LightSkyBlue1")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-drop + '((((class color) (background light)) :foreground "IndianRed") + (((class color) (background dark)) :foreground "IndianRed")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-done + '((t :inherit magit-hash)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-onto + '((t :inherit magit-sequence-done)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-exec + '((t :inherit magit-hash)) + "Face used in sequence sections." + :group 'magit-faces) + +;;; Common + +;;;###autoload +(defun magit-sequencer-continue () + "Resume the current cherry-pick or revert sequence." + (interactive) + (if (magit-sequencer-in-progress-p) + (if (magit-anything-unstaged-p t) + (user-error "Cannot continue due to unstaged changes") + (magit-run-git-sequencer + (if (magit-revert-in-progress-p) "revert" "cherry-pick") "--continue")) + (user-error "No cherry-pick or revert in progress"))) + +;;;###autoload +(defun magit-sequencer-skip () + "Skip the stopped at commit during a cherry-pick or revert sequence." + (interactive) + (if (magit-sequencer-in-progress-p) + (progn (magit-call-git "reset" "--hard") + (magit-sequencer-continue)) + (user-error "No cherry-pick or revert in progress"))) + +;;;###autoload +(defun magit-sequencer-abort () + "Abort the current cherry-pick or revert sequence. +This discards all changes made since the sequence started." + (interactive) + (if (magit-sequencer-in-progress-p) + (magit-run-git-sequencer + (if (magit-revert-in-progress-p) "revert" "cherry-pick") "--abort") + (user-error "No cherry-pick or revert in progress"))) + +(defun magit-sequencer-in-progress-p () + (or (magit-cherry-pick-in-progress-p) + (magit-revert-in-progress-p))) + +;;; Cherry-Pick + +(defvar magit-perl-executable "perl" + "The Perl executable.") + +;;;###autoload (autoload 'magit-cherry-pick "magit-sequence" nil t) +(define-transient-command magit-cherry-pick () + "Apply or transplant commits." + :man-page "git-cherry-pick" + :value '("--ff") + :incompatible '(("--ff" "-x")) + ["Arguments" + :if-not magit-sequencer-in-progress-p + (magit-cherry-pick:--mainline) + ("=s" magit-merge:--strategy) + ("-F" "Attempt fast-forward" "--ff") + ("-x" "Reference cherry in commit message" "-x") + ("-e" "Edit commit messages" ("-e" "--edit")) + ("-s" "Add Signed-off-by lines" ("-s" "--signoff")) + (5 magit:--gpg-sign)] + [:if-not magit-sequencer-in-progress-p + ["Apply here" + ("A" "Pick" magit-cherry-copy) + ("a" "Apply" magit-cherry-apply) + ("h" "Harvest" magit-cherry-harvest)] + ["Apply elsewhere" + ("d" "Donate" magit-cherry-donate) + ("n" "Spinout" magit-cherry-spinout) + ("s" "Spinoff" magit-cherry-spinoff)]] + ["Actions" + :if magit-sequencer-in-progress-p + ("A" "Continue" magit-sequencer-continue) + ("s" "Skip" magit-sequencer-skip) + ("a" "Abort" magit-sequencer-abort)]) + +(define-infix-argument magit-cherry-pick:--mainline () + :description "Replay merge relative to parent" + :class 'transient-option + :shortarg "-m" + :argument "--mainline=" + :reader 'transient-read-number-N+) + +(defun magit-cherry-pick-read-args (prompt) + (list (or (nreverse (magit-region-values 'commit)) + (magit-read-other-branch-or-commit prompt)) + (transient-args 'magit-cherry-pick))) + +(defun magit--cherry-move-read-args (verb away fn) + (declare (indent defun)) + (let ((commits (or (nreverse (magit-region-values 'commit)) + (list (funcall (if away + 'magit-read-branch-or-commit + 'magit-read-other-branch-or-commit) + (format "%s cherry" (capitalize verb)))))) + (current (magit-get-current-branch))) + (unless current + (user-error "Cannot %s cherries while HEAD is detached" verb)) + (let ((reachable (magit-rev-ancestor-p (car commits) current)) + (msg "Cannot %s cherries that %s reachable from HEAD")) + (pcase (list away reachable) + (`(nil t) (user-error msg verb "are")) + (`(t nil) (user-error msg verb "are not")))) + `(,commits + ,@(funcall fn commits) + ,(transient-args 'magit-cherry-pick)))) + +(defun magit--cherry-spinoff-read-args (verb) + (magit--cherry-move-read-args verb t + (lambda (commits) + (magit-branch-read-args + (format "Create branch from %s cherries" (length commits)) + (magit-get-upstream-branch))))) + +;;;###autoload +(defun magit-cherry-copy (commits &optional args) + "Copy COMMITS from another branch onto the current branch. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then pick all of them, +without prompting." + (interactive (magit-cherry-pick-read-args "Cherry-pick")) + (magit--cherry-pick commits args)) + +;;;###autoload +(defun magit-cherry-apply (commits &optional args) + "Apply the changes in COMMITS but do not commit them. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then apply all of them, +without prompting." + (interactive (magit-cherry-pick-read-args "Apply changes from commit")) + (magit--cherry-pick commits (cons "--no-commit" (remove "--ff" args)))) + +;;;###autoload +(defun magit-cherry-harvest (commits branch &optional args) + "Move COMMITS from another BRANCH onto the current branch. +Remove the COMMITS from BRANCH and stay on the current branch. +If a conflict occurs, then you have to fix that and finish the +process manually." + (interactive + (magit--cherry-move-read-args "harvest" nil + (lambda (commits) + (list (let ((branches (magit-list-containing-branches (car commits)))) + (pcase (length branches) + (0 nil) + (1 (car branches)) + (_ (magit-completing-read + (format "Remove %s cherries from branch" (length commits)) + branches nil t)))))))) + (magit--cherry-move commits branch (magit-get-current-branch) args nil t)) + +;;;###autoload +(defun magit-cherry-donate (commits branch &optional args) + "Move COMMITS from the current branch onto another existing BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually." + (interactive + (magit--cherry-move-read-args "donate" t + (lambda (commits) + (list (magit-read-other-branch (format "Move %s cherries to branch" + (length commits))))))) + (magit--cherry-move commits (magit-get-current-branch) branch args)) + +;;;###autoload +(defun magit-cherry-spinout (commits branch start-point &optional args) + "Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually." + (interactive (magit--cherry-spinoff-read-args "spinout")) + (magit--cherry-move commits (magit-get-current-branch) branch args + start-point)) + +;;;###autoload +(defun magit-cherry-spinoff (commits branch start-point &optional args) + "Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and checkout BRANCH. +If a conflict occurs, then you have to fix that and finish +the process manually." + (interactive (magit--cherry-spinoff-read-args "spinoff")) + (magit--cherry-move commits (magit-get-current-branch) branch args + start-point t)) + +(defun magit--cherry-move (commits src dst args + &optional start-point checkout-dst) + (let ((current (magit-get-current-branch))) + (unless (magit-branch-p dst) + (let ((magit-process-raise-error t)) + (magit-call-git "branch" dst start-point)) + (--when-let (magit-get-indirect-upstream-branch start-point) + (magit-call-git "branch" "--set-upstream-to" it dst))) + (unless (equal dst current) + (let ((magit-process-raise-error t)) + (magit-call-git "checkout" dst))) + (if (not src) ; harvest only + (magit--cherry-pick commits args) + (let ((tip (car (last commits))) + (keep (concat (car commits) "^"))) + (magit--cherry-pick commits args) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (cond + ((magit-rev-equal tip src) + (magit-call-git "update-ref" + "-m" (format "reset: moving to %s" keep) + (magit-ref-fullname src) + keep tip) + (if (not checkout-dst) + (magit-run-git "checkout" src) + (magit-refresh))) + (t + (magit-git "checkout" src) + (let ((process-environment process-environment)) + (push (format "%s=%s -i -ne '/^pick (%s)/ or print'" + "GIT_SEQUENCE_EDITOR" + magit-perl-executable + (mapconcat #'magit-rev-abbrev commits "|")) + process-environment) + (magit-run-git-sequencer "rebase" "-i" keep)) + (when checkout-dst + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-run-git "checkout" dst)))))))))))))))) + +(defun magit--cherry-pick (commits args &optional revert) + (let ((command (if revert "revert" "cherry-pick"))) + (when (stringp commits) + (setq commits (if (string-match-p "\\.\\." commits) + (split-string commits "\\.\\.") + (list commits)))) + (magit-run-git-sequencer + (if revert "revert" "cherry-pick") + (pcase-let ((`(,merge ,non-merge) + (-separate 'magit-merge-commit-p commits))) + (cond + ((not merge) + (--remove (string-prefix-p "--mainline=" it) args)) + (non-merge + (user-error "Cannot %s merge and non-merge commits at once" + command)) + ((--first (string-prefix-p "--mainline=" it) args) + args) + (t + (cons (format "--mainline=%s" + (read-number "Replay merges relative to parent: ")) + args)))) + commits))) + +(defun magit-cherry-pick-in-progress-p () + ;; .git/sequencer/todo does not exist when there is only one commit left. + (file-exists-p (magit-git-dir "CHERRY_PICK_HEAD"))) + +;;; Revert + +;;;###autoload (autoload 'magit-revert "magit-sequence" nil t) +(define-transient-command magit-revert () + "Revert existing commits, with or without creating new commits." + :man-page "git-revert" + :value '("--edit") + ["Arguments" + :if-not magit-sequencer-in-progress-p + (magit-cherry-pick:--mainline) + ("-e" "Edit commit message" ("-e" "--edit")) + ("-E" "Don't edit commit message" "--no-edit") + ("=s" magit-merge:--strategy) + ("-s" "Add Signed-off-by lines" ("-s" "--signoff")) + (5 magit:--gpg-sign)] + ["Actions" + :if-not magit-sequencer-in-progress-p + ("V" "Revert commit(s)" magit-revert-and-commit) + ("v" "Revert changes" magit-revert-no-commit)] + ["Actions" + :if magit-sequencer-in-progress-p + ("V" "Continue" magit-sequencer-continue) + ("s" "Skip" magit-sequencer-skip) + ("a" "Abort" magit-sequencer-abort)]) + +(defun magit-revert-read-args (prompt) + (list (or (magit-region-values 'commit) + (magit-read-branch-or-commit prompt)) + (transient-args 'magit-revert))) + +;;;###autoload +(defun magit-revert-and-commit (commit &optional args) + "Revert COMMIT by creating a new commit. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting." + (interactive (magit-revert-read-args "Revert commit")) + (magit--cherry-pick commit args t)) + +;;;###autoload +(defun magit-revert-no-commit (commit &optional args) + "Revert COMMIT by applying it in reverse to the worktree. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting." + (interactive (magit-revert-read-args "Revert changes")) + (magit--cherry-pick commit (cons "--no-commit" args) t)) + +(defun magit-revert-in-progress-p () + ;; .git/sequencer/todo does not exist when there is only one commit left. + (file-exists-p (magit-git-dir "REVERT_HEAD"))) + +;;; Patch + +;;;###autoload (autoload 'magit-am "magit-sequence" nil t) +(define-transient-command magit-am () + "Apply patches received by email." + :man-page "git-am" + :value '("--3way") + ["Arguments" + :if-not magit-am-in-progress-p + ("-3" "Fall back on 3way merge" ("-3" "--3way")) + (magit-apply:-p) + ("-c" "Remove text before scissors line" ("-c" "--scissors")) + ("-k" "Inhibit removal of email cruft" ("-k" "--keep")) + ("-b" "Limit removal of email cruft" "--keep-non-patch") + ("-d" "Use author date as committer date" "--committer-date-is-author-date") + ("-D" "Use committer date as author date" "--ignore-date") + ("-s" "Add Signed-off-by lines" ("-s" "--signoff")) + (5 magit:--gpg-sign)] + ["Apply" + :if-not magit-am-in-progress-p + ("m" "maildir" magit-am-apply-maildir) + ("w" "patches" magit-am-apply-patches) + ("a" "plain patch" magit-patch-apply)] + ["Actions" + :if magit-am-in-progress-p + ("w" "Continue" magit-am-continue) + ("s" "Skip" magit-am-skip) + ("a" "Abort" magit-am-abort)]) + +(defun magit-am-arguments () + (transient-args 'magit-am)) + +(define-infix-argument magit-apply:-p () + :description "Remove leading slashes from paths" + :class 'transient-option + :argument "-p" + :reader 'transient-read-number-N+) + +;;;###autoload +(defun magit-am-apply-patches (&optional files args) + "Apply the patches FILES." + (interactive (list (or (magit-region-values 'file) + (list (let ((default (magit-file-at-point))) + (read-file-name + (if default + (format "Apply patch (%s): " default) + "Apply patch: ") + nil default)))) + (magit-am-arguments))) + (magit-run-git-sequencer "am" args "--" + (--map (magit-convert-filename-for-git + (expand-file-name it)) + files))) + +;;;###autoload +(defun magit-am-apply-maildir (&optional maildir args) + "Apply the patches from MAILDIR." + (interactive (list (read-file-name "Apply mbox or Maildir: ") + (magit-am-arguments))) + (magit-run-git-sequencer "am" args (magit-convert-filename-for-git + (expand-file-name maildir)))) + +;;;###autoload +(defun magit-am-continue () + "Resume the current patch applying sequence." + (interactive) + (if (magit-am-in-progress-p) + (if (magit-anything-unstaged-p t) + (error "Cannot continue due to unstaged changes") + (magit-run-git-sequencer "am" "--continue")) + (user-error "Not applying any patches"))) + +;;;###autoload +(defun magit-am-skip () + "Skip the stopped at patch during a patch applying sequence." + (interactive) + (if (magit-am-in-progress-p) + (magit-run-git-sequencer "am" "--skip") + (user-error "Not applying any patches"))) + +;;;###autoload +(defun magit-am-abort () + "Abort the current patch applying sequence. +This discards all changes made since the sequence started." + (interactive) + (if (magit-am-in-progress-p) + (magit-run-git "am" "--abort") + (user-error "Not applying any patches"))) + +(defun magit-am-in-progress-p () + (file-exists-p (magit-git-dir "rebase-apply/applying"))) + +;;; Rebase + +;;;###autoload (autoload 'magit-rebase "magit-sequence" nil t) +(define-transient-command magit-rebase () + "Transplant commits and/or modify existing commits." + :man-page "git-rebase" + ["Arguments" + :if-not magit-rebase-in-progress-p + ("-k" "Keep empty commits" "--keep-empty") + ("-p" "Preserve merges" ("-p" "--preserve-merges")) + (7 magit-merge:--strategy) + ("-d" "Lie about committer date" "--committer-date-is-author-date") + ("-a" "Autosquash" "--autosquash") + ("-A" "Autostash" "--autostash") + ("-i" "Interactive" ("-i" "--interactive")) + ("-h" "Disable hooks" "--no-verify") + (7 magit-rebase:--exec) + (5 magit:--gpg-sign) + (5 "-r" "Rebase merges" "--rebase-merges=" magit-rebase-merges-select-mode)] + [:if-not magit-rebase-in-progress-p + :description (lambda () + (format (propertize "Rebase %s onto" 'face 'transient-heading) + (propertize (or (magit-get-current-branch) "HEAD") + 'face 'magit-branch-local))) + ("p" magit-rebase-onto-pushremote) + ("u" magit-rebase-onto-upstream) + ("e" "elsewhere" magit-rebase-branch)] + ["Rebase" + :if-not magit-rebase-in-progress-p + [("i" "interactively" magit-rebase-interactive) + ("s" "a subset" magit-rebase-subset)] + [("m" "to modify a commit" magit-rebase-edit-commit) + ("w" "to reword a commit" magit-rebase-reword-commit) + ("k" "to remove a commit" magit-rebase-remove-commit) + ("f" "to autosquash" magit-rebase-autosquash) + (6 "t" "to change dates" magit-reshelve-since)]] + ["Actions" + :if magit-rebase-in-progress-p + ("r" "Continue" magit-rebase-continue) + ("s" "Skip" magit-rebase-skip) + ("e" "Edit" magit-rebase-edit) + ("a" "Abort" magit-rebase-abort)]) + +(define-infix-argument magit-rebase:--exec () + :description "Run command after commits" + :class 'transient-option + :shortarg "-x" + :argument "--exec=" + :reader #'read-shell-command) + +(defun magit-rebase-merges-select-mode (&rest _ignore) + (magit-read-char-case nil t + (?n "[n]o-rebase-cousins" "no-rebase-cousins") + (?r "[r]ebase-cousins" "rebase-cousins"))) + +(defun magit-rebase-arguments () + (transient-args 'magit-rebase)) + +(defun magit-git-rebase (target args) + (magit-run-git-sequencer "rebase" args target)) + +;;;###autoload (autoload 'magit-rebase-onto-pushremote "magit-sequence" nil t) +(define-suffix-command magit-rebase-onto-pushremote (args) + "Rebase the current branch onto its push-remote branch. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :if 'magit-get-current-branch + :description 'magit-pull--pushbranch-description + (interactive (list (magit-rebase-arguments))) + (pcase-let ((`(,branch ,remote) + (magit--select-push-remote "rebase onto that"))) + (magit-git-rebase (concat remote "/" branch) args))) + +;;;###autoload (autoload 'magit-rebase-onto-upstream "magit-sequence" nil t) +(define-suffix-command magit-rebase-onto-upstream (args) + "Rebase the current branch onto its upstream branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if 'magit-get-current-branch + :description 'magit-rebase--upstream-description + (interactive (list (magit-rebase-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (upstream (magit-get-upstream-branch branch))) + (when (or current-prefix-arg (not upstream)) + (setq upstream + (magit-read-upstream-branch + branch (format "Set upstream of %s and rebase onto that" branch))) + (magit-set-upstream-branch branch upstream)) + (magit-git-rebase upstream args))) + +(defun magit-rebase--upstream-description () + (when-let ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (concat u ", replacing unnamed")) + ((magit--valid-upstream-p remote merge) + (concat u ", replacing non-existent")) + ((or remote merge) + (concat u ", replacing invalid")) + (t + (concat u ", setting that"))))))) + +;;;###autoload +(defun magit-rebase-branch (target args) + "Rebase the current branch onto a branch read in the minibuffer. +All commits that are reachable from `HEAD' but not from the +selected branch TARGET are being rebased." + (interactive (list (magit-read-other-branch-or-commit "Rebase onto") + (magit-rebase-arguments))) + (message "Rebasing...") + (magit-git-rebase target args) + (message "Rebasing...done")) + +;;;###autoload +(defun magit-rebase-subset (newbase start args) + "Rebase a subset of the current branch's history onto a new base. +Rebase commits from START to `HEAD' onto NEWBASE. +START has to be selected from a list of recent commits." + (interactive (list (magit-read-other-branch-or-commit + "Rebase subset onto" nil + (magit-get-upstream-branch)) + nil + (magit-rebase-arguments))) + (if start + (progn (message "Rebasing...") + (magit-run-git-sequencer "rebase" "--onto" newbase start args) + (message "Rebasing...done")) + (magit-log-select + `(lambda (commit) + (magit-rebase-subset ,newbase (concat commit "^") (list ,@args))) + (concat "Type %p on a commit to rebase it " + "and commits above it onto " newbase ",")))) + +(defvar magit-rebase-interactive-include-selected t) + +(defun magit-rebase-interactive-1 + (commit args message &optional editor delay-edit-confirm noassert confirm) + (declare (indent 2)) + (when commit + (if (eq commit :merge-base) + (setq commit (--if-let (magit-get-upstream-branch) + (magit-git-string "merge-base" it "HEAD") + nil)) + (unless (magit-rev-ancestor-p commit "HEAD") + (user-error "%s isn't an ancestor of HEAD" commit)) + (if (magit-commit-parents commit) + (when (or (not (eq this-command 'magit-rebase-interactive)) + magit-rebase-interactive-include-selected) + (setq commit (concat commit "^"))) + (setq args (cons "--root" args))))) + (when (and commit (not noassert)) + (setq commit (magit-rebase-interactive-assert + commit delay-edit-confirm + (--some (string-prefix-p "--rebase-merges" it) args)))) + (if (and commit (not confirm)) + (let ((process-environment process-environment)) + (when editor + (push (concat "GIT_SEQUENCE_EDITOR=" + (if (functionp editor) + (funcall editor commit) + editor)) + process-environment)) + (magit-run-git-sequencer "rebase" "-i" args + (unless (member "--root" args) commit))) + (magit-log-select + `(lambda (commit) + (magit-rebase-interactive-1 commit (list ,@args) + ,message ,editor ,delay-edit-confirm ,noassert)) + message))) + +(defvar magit--rebase-published-symbol nil) +(defvar magit--rebase-public-edit-confirmed nil) + +(defun magit-rebase-interactive-assert + (since &optional delay-edit-confirm rebase-merges) + (let* ((commit (magit-rebase--target-commit since)) + (branches (magit-list-publishing-branches commit))) + (setq magit--rebase-public-edit-confirmed + (delete (magit-toplevel) magit--rebase-public-edit-confirmed)) + (when (and branches + (or (not delay-edit-confirm) + ;; The user might have stopped at a published commit + ;; merely to add new commits *after* it. Try not to + ;; ask users whether they really want to edit public + ;; commits, when they don't actually intend to do so. + (not (--all-p (magit-rev-equal it commit) branches)))) + (let ((m1 "Some of these commits have already been published to ") + (m2 ".\nDo you really want to modify them")) + (magit-confirm (or magit--rebase-published-symbol 'rebase-published) + (concat m1 "%s" m2) + (concat m1 "%i public branches" m2) + nil branches)) + (push (magit-toplevel) magit--rebase-public-edit-confirmed))) + (if (and (magit-git-lines "rev-list" "--merges" (concat since "..HEAD")) + (not rebase-merges)) + (magit-read-char-case "Proceed despite merge in rebase range? " nil + (?c "[c]ontinue" since) + (?s "[s]elect other" nil) + (?a "[a]bort" (user-error "Quit"))) + since)) + +(defun magit-rebase--target-commit (since) + (if (string-suffix-p "^" since) + ;; If SINCE is "REV^", then the user selected + ;; "REV", which is the first commit that will + ;; be replaced. (from^..to] <=> [from..to] + (substring since 0 -1) + ;; The "--root" argument is being used. + since)) + +;;;###autoload +(defun magit-rebase-interactive (commit args) + "Start an interactive rebase sequence." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to rebase it and all commits above it," + nil t)) + +;;;###autoload +(defun magit-rebase-autosquash (args) + "Combine squash and fixup commits with their intended targets." + (interactive (list (magit-rebase-arguments))) + (magit-rebase-interactive-1 :merge-base + (nconc (list "--autosquash" "--keep-empty") args) + "Type %p on a commit to squash into it and then rebase as necessary," + "true" nil t)) + +;;;###autoload +(defun magit-rebase-edit-commit (commit args) + "Edit a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to edit it," + (apply-partially #'magit-rebase--perl-editor 'edit) + t)) + +;;;###autoload +(defun magit-rebase-reword-commit (commit args) + "Reword a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to reword its message," + (apply-partially #'magit-rebase--perl-editor 'reword))) + +;;;###autoload +(defun magit-rebase-remove-commit (commit args) + "Remove a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to remove it," + (apply-partially #'magit-rebase--perl-editor 'remove) + nil nil t)) + +(defun magit-rebase--perl-editor (action since) + (let ((commit (magit-rev-abbrev (magit-rebase--target-commit since)))) + (format "%s -i -p -e '++$x if not $x and s/^pick %s/%s %s/'" + magit-perl-executable + commit + (cl-case action + (edit "edit") + (remove "# pick") + (reword "reword") + (t (error "unknown action: %s" action))) + commit))) + +;;;###autoload +(defun magit-rebase-continue (&optional noedit) + "Restart the current rebasing operation. +In some cases this pops up a commit message buffer for you do +edit. With a prefix argument the old message is reused as-is." + (interactive "P") + (if (magit-rebase-in-progress-p) + (if (magit-anything-unstaged-p t) + (user-error "Cannot continue rebase with unstaged changes") + (when (and (magit-anything-staged-p) + (file-exists-p (magit-git-dir "rebase-merge")) + (not (member (magit-toplevel) + magit--rebase-public-edit-confirmed))) + (magit-commit-amend-assert)) + (if noedit + (let ((process-environment process-environment)) + (push "GIT_EDITOR=true" process-environment) + (magit-run-git-async (magit--rebase-resume-command) "--continue") + (set-process-sentinel magit-this-process + #'magit-sequencer-process-sentinel) + magit-this-process) + (magit-run-git-sequencer (magit--rebase-resume-command) "--continue"))) + (user-error "No rebase in progress"))) + +;;;###autoload +(defun magit-rebase-skip () + "Skip the current commit and restart the current rebase operation." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-run-git-sequencer (magit--rebase-resume-command) "--skip")) + +;;;###autoload +(defun magit-rebase-edit () + "Edit the todo list of the current rebase operation." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-run-git-sequencer "rebase" "--edit-todo")) + +;;;###autoload +(defun magit-rebase-abort () + "Abort the current rebase operation, restoring the original branch." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-confirm 'abort-rebase "Abort this rebase") + (magit-run-git (magit--rebase-resume-command) "--abort")) + +(defun magit-rebase-in-progress-p () + "Return t if a rebase is in progress." + (or (file-exists-p (magit-git-dir "rebase-merge")) + (file-exists-p (magit-git-dir "rebase-apply/onto")))) + +(defun magit--rebase-resume-command () + (if (file-exists-p (magit-git-dir "rebase-recursive")) "rbr" "rebase")) + +;;; Sections + +(defun magit-insert-sequencer-sequence () + "Insert section for the on-going cherry-pick or revert sequence. +If no such sequence is in progress, do nothing." + (let ((picking (magit-cherry-pick-in-progress-p))) + (when (or picking (magit-revert-in-progress-p)) + (magit-insert-section (sequence) + (magit-insert-heading (if picking "Cherry Picking" "Reverting")) + (when-let ((lines + (cdr (magit-file-lines (magit-git-dir "sequencer/todo"))))) + (dolist (line (nreverse lines)) + (when (string-match + "^\\(pick\\|revert\\) \\([^ ]+\\) \\(.*\\)$" line) + (magit-bind-match-strings (cmd hash msg) line + (magit-insert-section (commit hash) + (insert (propertize cmd 'font-lock-face 'magit-sequence-pick) + " " (propertize hash 'font-lock-face 'magit-hash) + " " msg "\n")))))) + (magit-sequence-insert-sequence + (magit-file-line (magit-git-dir (if picking + "CHERRY_PICK_HEAD" + "REVERT_HEAD"))) + (magit-file-line (magit-git-dir "sequencer/head"))) + (insert "\n"))))) + +(defun magit-insert-am-sequence () + "Insert section for the on-going patch applying sequence. +If no such sequence is in progress, do nothing." + (when (magit-am-in-progress-p) + (magit-insert-section (rebase-sequence) + (magit-insert-heading "Applying patches") + (let ((patches (nreverse (magit-rebase-patches))) + patch commit) + (while patches + (setq patch (pop patches)) + (setq commit (magit-commit-p + (cadr (split-string (magit-file-line patch))))) + (cond ((and commit patches) + (magit-sequence-insert-commit + "pick" commit 'magit-sequence-pick)) + (patches + (magit-sequence-insert-am-patch + "pick" patch 'magit-sequence-pick)) + (commit + (magit-sequence-insert-sequence commit "ORIG_HEAD")) + (t + (magit-sequence-insert-am-patch + "stop" patch 'magit-sequence-stop) + (magit-sequence-insert-sequence nil "ORIG_HEAD"))))) + (insert ?\n)))) + +(defun magit-sequence-insert-am-patch (type patch face) + (magit-insert-section (file patch) + (let ((title + (with-temp-buffer + (insert-file-contents patch nil nil 4096) + (unless (re-search-forward "^Subject: " nil t) + (goto-char (point-min))) + (buffer-substring (point) (line-end-position))))) + (insert (propertize type 'font-lock-face face) + ?\s (propertize (file-name-nondirectory patch) + 'font-lock-face 'magit-hash) + ?\s title + ?\n)))) + +(defun magit-insert-rebase-sequence () + "Insert section for the on-going rebase sequence. +If no such sequence is in progress, do nothing." + (when (magit-rebase-in-progress-p) + (let* ((interactive (file-directory-p (magit-git-dir "rebase-merge"))) + (dir (if interactive "rebase-merge/" "rebase-apply/")) + (name (-> (concat dir "head-name") magit-git-dir magit-file-line)) + (onto (-> (concat dir "onto") magit-git-dir magit-file-line)) + (onto (or (magit-rev-name onto name) + (magit-rev-name onto "refs/heads/*") onto)) + (name (or (magit-rev-name name "refs/heads/*") name))) + (magit-insert-section (rebase-sequence) + (magit-insert-heading (format "Rebasing %s onto %s" name onto)) + (if interactive + (magit-rebase-insert-merge-sequence onto) + (magit-rebase-insert-apply-sequence onto)) + (insert ?\n))))) + +(defun magit-rebase--todo () + "Return `git-rebase-action' instances for remaining rebase actions. +These are ordered in that the same way they'll be sorted in the +status buffer (i.e. the reverse of how they will be applied)." + (let ((comment-start (or (magit-get "core.commentChar") "#")) + lines) + (with-temp-buffer + (insert-file-contents (magit-git-dir "rebase-merge/git-rebase-todo")) + (while (not (eobp)) + (let ((ln (git-rebase-current-line))) + (when (oref ln action-type) + (push ln lines))) + (forward-line))) + lines)) + +(defun magit-rebase-insert-merge-sequence (onto) + (dolist (line (magit-rebase--todo)) + (with-slots (action-type action action-options target) line + (pcase action-type + (`commit + (magit-sequence-insert-commit action target 'magit-sequence-pick)) + ((or (or `exec `label) + (and `merge (guard (not action-options)))) + (insert (propertize action 'font-lock-face 'magit-sequence-onto) "\s" + (propertize target 'font-lock-face 'git-rebase-label) "\n")) + (`merge + (if-let ((hash (and (string-match "-[cC] \\([^ ]+\\)" action-options) + (match-string 1 action-options)))) + (magit-insert-section (commit hash) + (magit-insert-heading + (propertize "merge" 'font-lock-face 'magit-sequence-pick) + "\s" + (magit-format-rev-summary hash) "\n")) + (error "failed to parse merge message hash")))))) + (magit-sequence-insert-sequence + (magit-file-line (magit-git-dir "rebase-merge/stopped-sha")) + onto + (--when-let (magit-file-lines (magit-git-dir "rebase-merge/done")) + (cadr (split-string (car (last it))))))) + +(defun magit-rebase-insert-apply-sequence (onto) + (let ((rewritten + (--map (car (split-string it)) + (magit-file-lines (magit-git-dir "rebase-apply/rewritten")))) + (stop (magit-file-line (magit-git-dir "rebase-apply/original-commit")))) + (dolist (patch (nreverse (cdr (magit-rebase-patches)))) + (let ((hash (cadr (split-string (magit-file-line patch))))) + (unless (or (member hash rewritten) + (equal hash stop)) + (magit-sequence-insert-commit "pick" hash 'magit-sequence-pick))))) + (magit-sequence-insert-sequence + (magit-file-line (magit-git-dir "rebase-apply/original-commit")) + onto)) + +(defun magit-rebase-patches () + (directory-files (magit-git-dir "rebase-apply") t "^[0-9]\\{4\\}$")) + +(defun magit-sequence-insert-sequence (stop onto &optional orig) + (let ((head (magit-rev-parse "HEAD")) done) + (setq onto (if onto (magit-rev-parse onto) head)) + (setq done (magit-git-lines "log" "--format=%H" (concat onto "..HEAD"))) + (when (and stop (not (member (magit-rev-parse stop) done))) + (let ((id (magit-patch-id stop))) + (--if-let (--first (equal (magit-patch-id it) id) done) + (setq stop it) + (cond + ((--first (magit-rev-equal it stop) done) + ;; The commit's testament has been executed. + (magit-sequence-insert-commit "void" stop 'magit-sequence-drop)) + ;; The faith of the commit is still undecided... + ((magit-anything-unmerged-p) + ;; ...and time travel isn't for the faint of heart. + (magit-sequence-insert-commit "join" stop 'magit-sequence-part)) + ((magit-anything-modified-p t) + ;; ...and the dust hasn't settled yet... + (magit-sequence-insert-commit + (let* ((magit--refresh-cache nil) + (staged (magit-commit-tree "oO" nil "HEAD")) + (unstaged (magit-commit-worktree "oO" "--reset"))) + (cond + ;; ...but we could end up at the same tree just by committing. + ((or (magit-rev-equal staged stop) + (magit-rev-equal unstaged stop)) "goal") + ;; ...but the changes are still there, untainted. + ((or (equal (magit-patch-id staged) id) + (equal (magit-patch-id unstaged) id)) "same") + ;; ...and some changes are gone and/or others were added. + (t "work"))) + stop 'magit-sequence-part)) + ;; The commit is definitely gone... + ((--first (magit-rev-equal it stop) done) + ;; ...but all of its changes are still in effect. + (magit-sequence-insert-commit "poof" stop 'magit-sequence-drop)) + (t + ;; ...and some changes are gone and/or other changes were added. + (magit-sequence-insert-commit "gone" stop 'magit-sequence-drop))) + (setq stop nil)))) + (dolist (rev done) + (apply 'magit-sequence-insert-commit + (cond ((equal rev stop) + ;; ...but its reincarnation lives on. + ;; Or it didn't die in the first place. + (list (if (and (equal rev head) + (equal (magit-patch-id rev) + (magit-patch-id orig))) + "stop" ; We haven't done anything yet. + "like") ; There are new commits. + rev (if (equal rev head) + 'magit-sequence-head + 'magit-sequence-stop))) + ((equal rev head) + (list "done" rev 'magit-sequence-head)) + (t + (list "done" rev 'magit-sequence-done))))) + (magit-sequence-insert-commit "onto" onto + (if (equal onto head) + 'magit-sequence-head + 'magit-sequence-onto)))) + +(defun magit-sequence-insert-commit (type hash face) + (magit-insert-section (commit hash) + (magit-insert-heading + (propertize type 'font-lock-face face) "\s" + (magit-format-rev-summary hash) "\n"))) + +;;; _ +(provide 'magit-sequence) +;;; magit-sequence.el ends here diff --git a/elpa/magit-20200318.1224/magit-sequence.elc b/elpa/magit-20200318.1224/magit-sequence.elc new file mode 100644 index 00000000..db49f77f Binary files /dev/null and b/elpa/magit-20200318.1224/magit-sequence.elc differ diff --git a/elpa/magit-20200318.1224/magit-stash.el b/elpa/magit-20200318.1224/magit-stash.el new file mode 100644 index 00000000..7ac1b29c --- /dev/null +++ b/elpa/magit-20200318.1224/magit-stash.el @@ -0,0 +1,546 @@ +;;; magit-stash.el --- stash support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Support for Git stashes. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) +(require 'magit-reflog) + +;;; Options + +(defgroup magit-stash nil + "List stashes and show stash diffs." + :group 'magit-modes) + +;;;; Diff options + +(defcustom magit-stash-sections-hook + '(magit-insert-stash-notes + magit-insert-stash-worktree + magit-insert-stash-index + magit-insert-stash-untracked) + "Hook run to insert sections into stash diff buffers." + :package-version '(magit . "2.1.0") + :group 'magit-stash + :type 'hook) + +;;;; Log options + +(defcustom magit-stashes-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-stashes-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-stash + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-stashes-mode)) + +;;; Commands + +;;;###autoload (autoload 'magit-stash "magit-stash" nil t) +(define-transient-command magit-stash () + "Stash uncommitted changes." + :man-page "git-stash" + ["Arguments" + ("-u" "Also save untracked files" ("-u" "--include-untracked")) + ("-a" "Also save untracked and ignored files" ("-a" "--all"))] + [["Stash" + ("z" "both" magit-stash-both) + ("i" "index" magit-stash-index) + ("w" "worktree" magit-stash-worktree) + ("x" "keeping index" magit-stash-keep-index)] + ["Snapshot" + ("Z" "both" magit-snapshot-both) + ("I" "index" magit-snapshot-index) + ("W" "worktree" magit-snapshot-worktree) + ("r" "to wip ref" magit-wip-commit)] + ["Use" + ("a" "Apply" magit-stash-apply) + ("p" "Pop" magit-stash-pop) + ("k" "Drop" magit-stash-drop)] + ["Inspect" + ("l" "List" magit-stash-list) + ("v" "Show" magit-stash-show)] + ["Transform" + ("b" "Branch" magit-stash-branch) + ("B" "Branch here" magit-stash-branch-here) + ("f" "Format patch" magit-stash-format-patch)]]) + +(defun magit-stash-arguments () + (transient-args 'magit-stash)) + +;;;###autoload +(defun magit-stash-both (message &optional include-untracked) + "Create a stash of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-stash-read-args)) + (magit-stash-save message t t include-untracked t)) + +;;;###autoload +(defun magit-stash-index (message) + "Create a stash of the index only. +Unstaged and untracked changes are not stashed. The stashed +changes are applied in reverse to both the index and the +worktree. This command can fail when the worktree is not clean. +Applying the resulting stash has the inverse effect." + (interactive (list (magit-stash-read-message))) + (magit-stash-save message t nil nil t 'worktree)) + +;;;###autoload +(defun magit-stash-worktree (message &optional include-untracked) + "Create a stash of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-stash-read-args)) + (magit-stash-save message nil t include-untracked t 'index)) + +;;;###autoload +(defun magit-stash-keep-index (message &optional include-untracked) + "Create a stash of the index and working tree, keeping index intact. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-stash-read-args)) + (magit-stash-save message t t include-untracked t 'index)) + +(defun magit-stash-read-args () + (list (magit-stash-read-message) + (magit-stash-read-untracked))) + +(defun magit-stash-read-untracked () + (let ((prefix (prefix-numeric-value current-prefix-arg)) + (args (magit-stash-arguments))) + (cond ((or (= prefix 16) (member "--all" args)) 'all) + ((or (= prefix 4) (member "--include-untracked" args)) t)))) + +(defun magit-stash-read-message () + (let* ((default (format "On %s: " + (or (magit-get-current-branch) "(no branch)"))) + (input (magit-read-string "Stash message" default))) + (if (equal input default) + (concat default (magit-rev-format "%h %s")) + input))) + +;;;###autoload +(defun magit-snapshot-both (&optional include-untracked) + "Create a snapshot of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-snapshot-read-args)) + (magit-snapshot-save t t include-untracked t)) + +;;;###autoload +(defun magit-snapshot-index () + "Create a snapshot of the index only. +Unstaged and untracked changes are not stashed." + (interactive) + (magit-snapshot-save t nil nil t)) + +;;;###autoload +(defun magit-snapshot-worktree (&optional include-untracked) + "Create a snapshot of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-snapshot-read-args)) + (magit-snapshot-save nil t include-untracked t)) + +(defun magit-snapshot-read-args () + (list (magit-stash-read-untracked))) + +(defun magit-snapshot-save (index worktree untracked &optional refresh) + (magit-stash-save (concat "WIP on " (magit-stash-summary)) + index worktree untracked refresh t)) + +;;;###autoload +(defun magit-stash-apply (stash) + "Apply a stash to the working tree. +Try to preserve the stash index. If that fails because there +are staged changes, apply without preserving the stash index." + (interactive (list (magit-read-stash "Apply stash"))) + (if (= (magit-call-git "stash" "apply" "--index" stash) 0) + (magit-refresh) + (magit-run-git "stash" "apply" stash))) + +(defun magit-stash-pop (stash) + "Apply a stash to the working tree and remove it from stash list. +Try to preserve the stash index. If that fails because there +are staged changes, apply without preserving the stash index +and forgo removing the stash." + (interactive (list (magit-read-stash "Pop stash"))) + (if (= (magit-call-git "stash" "apply" "--index" stash) 0) + (magit-stash-drop stash) + (magit-run-git "stash" "apply" stash))) + +;;;###autoload +(defun magit-stash-drop (stash) + "Remove a stash from the stash list. +When the region is active offer to drop all contained stashes." + (interactive + (list (--if-let (magit-region-values 'stash) + (magit-confirm 'drop-stashes nil "Drop %i stashes" nil it) + (magit-read-stash "Drop stash")))) + (dolist (stash (if (listp stash) + (nreverse (prog1 stash (setq stash (car stash)))) + (list stash))) + (message "Deleted refs/%s (was %s)" stash + (magit-rev-parse "--short" stash)) + (magit-call-git "rev-parse" stash) + (magit-call-git "reflog" "delete" "--updateref" "--rewrite" stash)) + (when-let ((ref (and (string-match "\\(.+\\)@{[0-9]+}$" stash) + (match-string 1 stash)))) + (unless (string-match "^refs/" ref) + (setq ref (concat "refs/" ref))) + (unless (magit-rev-verify (concat ref "@{0}")) + (magit-run-git "update-ref" "-d" ref))) + (magit-refresh)) + +;;;###autoload +(defun magit-stash-clear (ref) + "Remove all stashes saved in REF's reflog by deleting REF." + (interactive (let ((ref (or (magit-section-value-if 'stashes) "refs/stash"))) + (magit-confirm t (format "Drop all stashes in %s" ref)) + (list ref))) + (magit-run-git "update-ref" "-d" ref)) + +;;;###autoload +(defun magit-stash-branch (stash branch) + "Create and checkout a new BRANCH from STASH." + (interactive (list (magit-read-stash "Branch stash") + (magit-read-string-ns "Branch name"))) + (magit-run-git "stash" "branch" branch stash)) + +;;;###autoload +(defun magit-stash-branch-here (stash branch) + "Create and checkout a new BRANCH and apply STASH. +The branch is created using `magit-branch-and-checkout', using the +current branch or `HEAD' as the start-point." + (interactive (list (magit-read-stash "Branch stash") + (magit-read-string-ns "Branch name"))) + (let ((inhibit-magit-refresh t)) + (magit-branch-and-checkout branch (or (magit-get-current-branch) "HEAD"))) + (magit-stash-apply stash)) + +;;;###autoload +(defun magit-stash-format-patch (stash) + "Create a patch from STASH" + (interactive (list (magit-read-stash "Create patch from stash"))) + (with-temp-file (magit-rev-format "0001-%f.patch" stash) + (magit-git-insert "stash" "show" "-p" stash)) + (magit-refresh)) + +;;; Plumbing + +(defun magit-stash-save (message index worktree untracked + &optional refresh keep noerror ref) + (if (or (and index (magit-staged-files t)) + (and worktree (magit-unstaged-files t)) + (and untracked (magit-untracked-files (eq untracked 'all)))) + (magit-with-toplevel + (magit-stash-store message (or ref "refs/stash") + (magit-stash-create message index worktree untracked)) + (if (eq keep 'worktree) + (with-temp-buffer + (magit-git-insert "diff" "--cached") + (magit-run-git-with-input + "apply" "--reverse" "--cached" "--ignore-space-change" "-") + (magit-run-git-with-input + "apply" "--reverse" "--ignore-space-change" "-")) + (unless (eq keep t) + (if (eq keep 'index) + (magit-call-git "checkout" "--" ".") + (magit-call-git "reset" "--hard" "HEAD" "--")) + (when untracked + (magit-call-git "clean" "--force" "-d" + (and (eq untracked 'all) "-x"))))) + (when refresh + (magit-refresh))) + (unless noerror + (user-error "No %s changes to save" (cond ((not index) "unstaged") + ((not worktree) "staged") + (t "local")))))) + +(defun magit-stash-store (message ref commit) + (magit-update-ref ref message commit t)) + +(defun magit-stash-create (message index worktree untracked) + (unless (magit-rev-parse "--verify" "HEAD") + (error "You do not have the initial commit yet")) + (let ((magit-git-global-arguments (nconc (list "-c" "commit.gpgsign=false") + magit-git-global-arguments)) + (default-directory (magit-toplevel)) + (summary (magit-stash-summary)) + (head "HEAD")) + (when (and worktree (not index)) + (setq head (or (magit-commit-tree "pre-stash index" nil "HEAD") + (error "Cannot save the current index state")))) + (or (setq index (magit-commit-tree (concat "index on " summary) nil head)) + (error "Cannot save the current index state")) + (and untracked + (setq untracked (magit-untracked-files (eq untracked 'all))) + (setq untracked (magit-with-temp-index nil nil + (or (and (magit-update-files untracked) + (magit-commit-tree + (concat "untracked files on " summary))) + (error "Cannot save the untracked files"))))) + (magit-with-temp-index index "-m" + (when worktree + (or (magit-update-files (magit-git-items "diff" "-z" "--name-only" head)) + (error "Cannot save the current worktree state"))) + (or (magit-commit-tree message nil head index untracked) + (error "Cannot save the current worktree state"))))) + +(defun magit-stash-summary () + (concat (or (magit-get-current-branch) "(no branch)") + ": " (magit-rev-format "%h %s"))) + +;;; Sections + +(defvar magit-stashes-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-delete-thing] 'magit-stash-clear) + map) + "Keymap for `stashes' section.") + +(defvar magit-stash-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-stash-show) + (define-key map [remap magit-delete-thing] 'magit-stash-drop) + (define-key map "a" 'magit-stash-apply) + (define-key map "A" 'magit-stash-pop) + map) + "Keymap for `stash' sections.") + +(magit-define-section-jumper magit-jump-to-stashes + "Stashes" stashes "refs/stash") + +(cl-defun magit-insert-stashes (&optional (ref "refs/stash") + (heading "Stashes:")) + "Insert `stashes' section showing reflog for \"refs/stash\". +If optional REF is non-nil, show reflog for that instead. +If optional HEADING is non-nil, use that as section heading +instead of \"Stashes:\"." + (let ((verified (magit-rev-verify ref)) + (autostash + (and (magit-rebase-in-progress-p) + (magit-file-line + (magit-git-dir + (-> (if (file-directory-p (magit-git-dir "rebase-merge")) + "rebase-merge/autostash" + "rebase-apply/autostash"))))))) + (when (or autostash verified) + (magit-insert-section (stashes ref) + (magit-insert-heading heading) + (when autostash + (pcase-let ((`(,author ,date ,msg) + (split-string + (car (magit-git-lines + "show" "-q" "--format=%aN%x00%at%x00%s" + autostash)) + "\0"))) + (magit-insert-section (stash autostash) + (insert (propertize "AUTOSTASH" 'font-lock-face 'magit-hash)) + (insert " " msg "\n") + (save-excursion + (backward-char) + (magit-log-format-margin autostash author date))))) + (if verified + (magit-git-wash (apply-partially 'magit-log-wash-log 'stash) + "reflog" "--format=%gd%x00%aN%x00%at%x00%gs" ref) + (insert ?\n) + (save-excursion + (backward-char) + (magit-make-margin-overlay))))))) + +;;; List Stashes + +;;;###autoload +(defun magit-stash-list () + "List all stashes in a buffer." + (interactive) + (magit-stashes-setup-buffer)) + +(define-derived-mode magit-stashes-mode magit-reflog-mode "Magit Stashes" + "Mode for looking at lists of stashes." + :group 'magit-log + (hack-dir-local-variables-non-file-buffer)) + +(defun magit-stashes-setup-buffer () + (magit-setup-buffer #'magit-stashes-mode nil + (magit-buffer-refname "refs/stash"))) + +(defun magit-stashes-refresh-buffer () + (magit-insert-section (stashesbuf) + (magit-insert-heading (if (equal magit-buffer-refname "refs/stash") + "Stashes:" + (format "Stashes [%s]:" magit-buffer-refname))) + (magit-git-wash (apply-partially 'magit-log-wash-log 'stash) + "reflog" "--format=%gd%x00%aN%x00%at%x00%gs" magit-buffer-refname))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-stashes-mode)) + magit-buffer-refname) + +(defvar magit--update-stash-buffer nil) + +(defun magit-stashes-maybe-update-stash-buffer (&optional _) + "When moving in the stashes buffer, update the stash buffer. +If there is no stash buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-stashes-mode) + (magit--maybe-update-stash-buffer))) + +(defun magit--maybe-update-stash-buffer () + (when-let ((stash (magit-section-value-if 'stash)) + (buffer (magit-get-mode-buffer 'magit-stash-mode nil t))) + (if magit--update-stash-buffer + (setq magit--update-stash-buffer (list stash buffer)) + (setq magit--update-stash-buffer (list stash buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (let ((args (with-current-buffer buffer + (let ((magit-direct-use-buffer-arguments 'selected)) + (magit-show-commit--arguments))))) + (lambda () + (pcase-let ((`(,stash ,buf) magit--update-stash-buffer)) + (setq magit--update-stash-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-stash-show stash args)))) + (setq magit--update-stash-buffer nil))))))) + +;;; Show Stash + +;;;###autoload +(defun magit-stash-show (stash &optional args files) + "Show all diffs of a stash in a buffer." + (interactive (cons (or (and (not current-prefix-arg) + (magit-stash-at-point)) + (magit-read-stash "Show stash")) + (pcase-let ((`(,args ,files) + (magit-diff-arguments 'magit-stash-mode))) + (list (delete "--stat" args) files)))) + (magit-stash-setup-buffer stash args files)) + +(define-derived-mode magit-stash-mode magit-diff-mode "Magit Stash" + "Mode for looking at individual stashes." + :group 'magit-diff + (hack-dir-local-variables-non-file-buffer)) + +(defun magit-stash-setup-buffer (stash args files) + (magit-setup-buffer #'magit-stash-mode nil + (magit-buffer-revision stash) + (magit-buffer-range (format "%s^..%s" stash stash)) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files))) + +(defun magit-stash-refresh-buffer () + (magit-set-header-line-format + (concat (capitalize magit-buffer-revision) " " + (propertize (magit-rev-format "%s" magit-buffer-revision) + 'font-lock-face + (list :weight 'normal :foreground + (face-attribute 'default :foreground))))) + (setq magit-buffer-revision-hash (magit-rev-parse magit-buffer-revision)) + (magit-insert-section (stash) + (magit-run-section-hook 'magit-stash-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-stash-mode)) + magit-buffer-revision) + +(defun magit-stash-insert-section (commit range message &optional files) + (magit-insert-section (commit commit) + (magit-insert-heading message) + (magit--insert-diff "diff" range "-p" "--no-prefix" magit-buffer-diff-args + "--" (or files magit-buffer-diff-files)))) + +(defun magit-insert-stash-notes () + "Insert section showing notes for a stash. +This shows the notes for stash@{N} but not for the other commits +that make up the stash." + (magit-insert-section section (note) + (magit-insert-heading "Notes") + (magit-git-insert "notes" "show" magit-buffer-revision) + (if (= (point) + (oref section content)) + (magit-cancel-section) + (insert "\n")))) + +(defun magit-insert-stash-index () + "Insert section showing staged changes of the stash." + (magit-stash-insert-section + (format "%s^2" magit-buffer-revision) + (format "%s^..%s^2" magit-buffer-revision magit-buffer-revision) + "Staged")) + +(defun magit-insert-stash-worktree () + "Insert section showing unstaged changes of the stash." + (magit-stash-insert-section + magit-buffer-revision + (format "%s^2..%s" magit-buffer-revision magit-buffer-revision) + "Unstaged")) + +(defun magit-insert-stash-untracked () + "Insert section showing the untracked files commit of the stash." + (let ((stash magit-buffer-revision) + (rev (concat magit-buffer-revision "^3"))) + (when (magit-rev-verify rev) + (magit-stash-insert-section (format "%s^3" stash) + (format "%s^..%s^3" stash stash) + "Untracked files" + (magit-git-items "ls-tree" "-z" "--name-only" + "-r" "--full-tree" rev))))) + +;;; _ +(provide 'magit-stash) +;;; magit-stash.el ends here diff --git a/elpa/magit-20200318.1224/magit-stash.elc b/elpa/magit-20200318.1224/magit-stash.elc new file mode 100644 index 00000000..38c33acd Binary files /dev/null and b/elpa/magit-20200318.1224/magit-stash.elc differ diff --git a/elpa/magit-20200318.1224/magit-status.el b/elpa/magit-20200318.1224/magit-status.el new file mode 100644 index 00000000..90e8980d --- /dev/null +++ b/elpa/magit-20200318.1224/magit-status.el @@ -0,0 +1,811 @@ +;;; magit-status.el --- the grand overview -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements the status buffer. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +;;; Options + +(defgroup magit-status nil + "Inspect and manipulate Git repositories." + :link '(info-link "(magit)Status Buffer") + :group 'magit-modes) + +(defcustom magit-status-mode-hook nil + "Hook run after entering Magit-Status mode." + :group 'magit-status + :type 'hook) + +(defcustom magit-status-headers-hook + '(magit-insert-error-header + magit-insert-diff-filter-header + magit-insert-head-branch-header + magit-insert-upstream-branch-header + magit-insert-push-branch-header + magit-insert-tags-header) + "Hook run to insert headers into the status buffer. + +This hook is run by `magit-insert-status-headers', which in turn +has to be a member of `magit-status-sections-hook' to be used at +all." + :package-version '(magit . "2.1.0") + :group 'magit-status + :type 'hook + :options '(magit-insert-error-header + magit-insert-diff-filter-header + magit-insert-repo-header + magit-insert-remote-header + magit-insert-head-branch-header + magit-insert-upstream-branch-header + magit-insert-push-branch-header + magit-insert-tags-header)) + +(defcustom magit-status-sections-hook + '(magit-insert-status-headers + magit-insert-merge-log + magit-insert-rebase-sequence + magit-insert-am-sequence + magit-insert-sequencer-sequence + magit-insert-bisect-output + magit-insert-bisect-rest + magit-insert-bisect-log + magit-insert-untracked-files + magit-insert-unstaged-changes + magit-insert-staged-changes + magit-insert-stashes + magit-insert-unpushed-to-pushremote + magit-insert-unpushed-to-upstream-or-recent + magit-insert-unpulled-from-pushremote + magit-insert-unpulled-from-upstream) + "Hook run to insert sections into a status buffer." + :package-version '(magit . "2.12.0") + :group 'magit-status + :type 'hook) + +(defcustom magit-status-initial-section '(1) + "The section point is placed on when a status buffer is created. + +When such a buffer is merely being refreshed or being shown again +after it was merely buried, then this option has no effect. + +If this is nil, then point remains on the very first section as +usual. Otherwise it has to be a list of integers and section +identity lists. The members of that list are tried in order +until a matching section is found. + +An integer means to jump to the nth section, 1 for example +jumps over the headings. To get a section's \"identity list\" +use \\[universal-argument] \\[magit-describe-section-briefly]. + +If, for example, you want to jump to the commits that haven't +been pulled from the upstream, or else the second section, then +use: (((unpulled . \"..@{upstream}\") (status)) 1). + +See option `magit-section-initial-visibility-alist' for how to +control the initial visibility of the jumped to section." + :package-version '(magit . "2.90.0") + :group 'magit-status + :type '(choice (const :tag "as usual" nil) + (repeat (choice (number :tag "nth top-level section") + (sexp :tag "section identity"))))) + +(defcustom magit-status-goto-file-position nil + "Whether to go to position corresponding to file position. + +If this is non-nil and the current buffer is visiting a file, +then `magit-status' tries to go to the position in the status +buffer that corresponds to the position in the file-visiting +buffer. This jumps into either the diff of unstaged changes +or the diff of staged changes. + +If the previously current buffer does not visit a file, or if +the file has neither unstaged nor staged changes then this has +no effect. + +The command `magit-status-here' tries to go to that position, +regardless of the value of this option." + :package-version '(magit . "3.0.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-status-show-hashes-in-headers nil + "Whether headers in the status buffer show hashes. +The functions which respect this option are +`magit-insert-head-branch-header', +`magit-insert-upstream-branch-header', and +`magit-insert-push-branch-header'." + :package-version '(magit . "2.4.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-status-margin + (list nil + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-status-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-status + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize 'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-status-mode)) + +;;; Commands + +;;;###autoload +(defun magit-init (directory) + "Initialize a Git repository, then show its status. + +If the directory is below an existing repository, then the user +has to confirm that a new one should be created inside. If the +directory is the root of the existing repository, then the user +has to confirm that it should be reinitialized. + +Non-interactively DIRECTORY is (re-)initialized unconditionally." + (interactive + (let ((directory (file-name-as-directory + (expand-file-name + (read-directory-name "Create repository in: "))))) + (when-let ((toplevel (magit-toplevel directory))) + (setq toplevel (expand-file-name toplevel)) + (unless (y-or-n-p (if (file-equal-p toplevel directory) + (format "Reinitialize existing repository %s? " + directory) + (format "%s is a repository. Create another in %s? " + toplevel directory))) + (user-error "Abort"))) + (list directory))) + ;; `git init' does not understand the meaning of "~"! + (magit-call-git "init" (magit-convert-filename-for-git + (expand-file-name directory))) + (magit-status-setup-buffer directory)) + +;;;###autoload +(defun magit-status (&optional directory cache) + "Show the status of the current Git repository in a buffer. + +If the current directory isn't located within a Git repository, +then prompt for an existing repository or an arbitrary directory, +depending on option `magit-repository-directories', and show the +status of the selected repository instead. + +* If that option specifies any existing repositories, then offer + those for completion and show the status buffer for the + selected one. + +* Otherwise read an arbitrary directory using regular file-name + completion. If the selected directory is the top-level of an + existing working tree, then show the status buffer for that. + +* Otherwise offer to initialize the selected directory as a new + repository. After creating the repository show its status + buffer. + +These fallback behaviors can also be forced using one or more +prefix arguments: + +* With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) read an arbitrary directory and act on + it as described above. The same could be accomplished using + the command `magit-init'. + +* With a single prefix argument read an existing repository, or + if none can be found based on `magit-repository-directories', + then fall back to the same behavior as with two prefix + arguments." + (interactive + (let ((magit--refresh-cache (list (cons 0 0)))) + (list (and (or current-prefix-arg (not (magit-toplevel))) + (magit-read-repository + (>= (prefix-numeric-value current-prefix-arg) 16))) + magit--refresh-cache))) + (let ((magit--refresh-cache (or cache (list (cons 0 0))))) + (if directory + (let ((toplevel (magit-toplevel directory))) + (setq directory (file-name-as-directory + (expand-file-name directory))) + (if (and toplevel (file-equal-p directory toplevel)) + (magit-status-setup-buffer directory) + (when (y-or-n-p + (if toplevel + (format "%s is a repository. Create another in %s? " + toplevel directory) + (format "Create repository in %s? " directory))) + ;; Creating a new repository invalidates cached values. + (setq magit--refresh-cache nil) + (magit-init directory)))) + (magit-status-setup-buffer default-directory)))) + +(put 'magit-status 'interactive-only 'magit-status-setup-buffer) + +;;;###autoload +(defalias 'magit 'magit-status + "An alias for `magit-status' for better discoverability. + +Instead of invoking this alias for `magit-status' using +\"M-x magit RET\", you should bind a key to `magit-status' +and read the info node `(magit)Getting Started', which +also contains other useful hints.") + +;;;###autoload +(defun magit-status-here () + "Like `magit-status' but with non-nil `magit-status-goto-file-position'." + (interactive) + (let ((magit-status-goto-file-position t)) + (call-interactively #'magit-status))) + +(put 'magit-status-here 'interactive-only 'magit-status-setup-buffer) + +(defvar magit--remotes-using-recent-git nil) + +(defun magit--tramp-asserts (directory) + (when-let ((remote (file-remote-p directory))) + (unless (member remote magit--remotes-using-recent-git) + (if-let ((version (let ((default-directory directory)) + (magit-git-version)))) + (if (version<= magit--minimal-git version) + (push version magit--remotes-using-recent-git) + (display-warning 'magit (format "\ +Magit requires Git >= %s, but on %s the version is %s. + +If multiple Git versions are installed on the host, then the +problem might be that TRAMP uses the wrong executable. + +First check the value of `magit-git-executable'. Its value is +used when running git locally as well as when running it on a +remote host. The default value is \"git\", except on Windows +where an absolute path is used for performance reasons. + +If the value already is just \"git\" but TRAMP never-the-less +doesn't use the correct executable, then consult the info node +`(tramp)Remote programs'.\n" magit--minimal-git remote version) :error)) + (display-warning 'magit (format "\ +Magit cannot find Git on %s. + +First check the value of `magit-git-executable'. Its value is +used when running git locally as well as when running it on a +remote host. The default value is \"git\", except on Windows +where an absolute path is used for performance reasons. + +If the value already is just \"git\" but TRAMP never-the-less +doesn't find the executable, then consult the info node +`(tramp)Remote programs'.\n" remote) :error))))) + +;;; Mode + +(defvar magit-status-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-mode-map) + (define-key map "j" 'magit-status-jump) + (define-key map [remap dired-jump] 'magit-dired-jump) + map) + "Keymap for `magit-status-mode'.") + +(define-transient-command magit-status-jump () + "In a Magit-Status buffer, jump to a section." + ["Jump to" + [("z " "Stashes" magit-jump-to-stashes + :if (lambda () (memq 'magit-insert-stashes magit-status-sections-hook))) + ("t " "Tracked" magit-jump-to-tracked + :if (lambda () (memq 'magit-insert-tracked-files magit-status-sections-hook))) + ("n " "Untracked" magit-jump-to-untracked + :if (lambda () (memq 'magit-insert-untracked-files magit-status-sections-hook))) + ("u " "Unstaged" magit-jump-to-unstaged + :if (lambda () (memq 'magit-insert-unstaged-changes magit-status-sections-hook))) + ("s " "Staged" magit-jump-to-staged + :if (lambda () (memq 'magit-insert-staged-changes magit-status-sections-hook)))] + [("fu" "Unpulled from upstream" magit-jump-to-unpulled-from-upstream + :if (lambda () (memq 'magit-insert-unpulled-from-upstream magit-status-sections-hook))) + ("fp" "Unpulled from pushremote" magit-jump-to-unpulled-from-pushremote + :if (lambda () (memq 'magit-insert-unpulled-from-pushremote magit-status-sections-hook))) + ("pu" "Unpushed to upstream" magit-jump-to-unpushed-to-upstream + :if (lambda () + (or (memq 'magit-insert-unpushed-to-upstream-or-recent magit-status-sections-hook) + (memq 'magit-insert-unpushed-to-upstream magit-status-sections-hook)))) + ("pp" "Unpushed to pushremote" magit-jump-to-unpushed-to-pushremote + :if (lambda () (memq 'magit-insert-unpushed-to-pushremote magit-status-sections-hook))) + ("a " "Assumed unstaged" magit-jump-to-assume-unchanged + :if (lambda () (memq 'magit-insert-assume-unchanged-files magit-status-sections-hook))) + ("w " "Skip worktree" magit-jump-to-skip-worktree + :if (lambda () (memq 'magit-insert-skip-worktree-files magit-status-sections-hook)))]]) + +(define-derived-mode magit-status-mode magit-mode "Magit" + "Mode for looking at Git status. + +This mode is documented in info node `(magit)Status Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the change or commit at point. + +Type \\[magit-dispatch] to invoke major commands. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\\ +Type \\[magit-commit] to create a commit. + +\\{magit-status-mode-map}" + :group 'magit-status + (hack-dir-local-variables-non-file-buffer) + (setq imenu-create-index-function + 'magit-imenu--status-create-index-function)) + +(put 'magit-status-mode 'magit-diff-default-arguments + '("--no-ext-diff")) +(put 'magit-status-mode 'magit-log-default-arguments + '("-n256" "--decorate")) + +;;;###autoload +(defun magit-status-setup-buffer (&optional directory) + (unless directory + (setq directory default-directory)) + (magit--tramp-asserts directory) + (let* ((default-directory directory) + (d (magit-diff--get-value 'magit-status-mode)) + (l (magit-log--get-value 'magit-status-mode)) + (file (and magit-status-goto-file-position + (magit-file-relative-name))) + (line (and file (line-number-at-pos))) + (col (and file (current-column))) + (buf (magit-setup-buffer #'magit-status-mode nil + (magit-buffer-diff-args (nth 0 d)) + (magit-buffer-diff-files (nth 1 d)) + (magit-buffer-log-args (nth 0 l)) + (magit-buffer-log-files (nth 1 l))))) + (when file + (with-current-buffer buf + (let ((staged (magit-get-section '((staged) (status))))) + (if (and staged + (cadr (magit-diff--locate-hunk file line staged))) + (magit-diff--goto-position file line col staged) + (let ((unstaged (magit-get-section '((unstaged) (status))))) + (unless (and unstaged + (magit-diff--goto-position file line col unstaged)) + (when staged + (magit-diff--goto-position file line col staged)))))))) + buf)) + +(defun magit-status-refresh-buffer () + (magit-git-exit-code "update-index" "--refresh") + (magit-insert-section (status) + (magit-run-section-hook 'magit-status-sections-hook))) + +(defun magit-status-goto-initial-section () + "In a `magit-status-mode' buffer, jump `magit-status-initial-section'. +Actually doing so is deferred until `magit-refresh-buffer-hook' +runs `magit-status-goto-initial-section-1'. That function then +removes itself from the hook, so that this only happens when the +status buffer is first created." + (when (and magit-status-initial-section + (derived-mode-p 'magit-status-mode)) + (add-hook 'magit-refresh-buffer-hook + 'magit-status-goto-initial-section-1 nil t))) + +(defun magit-status-goto-initial-section-1 () + "In a `magit-status-mode' buffer, jump `magit-status-initial-section'. +This function removes itself from `magit-refresh-buffer-hook'." + (when-let ((section + (--some (if (integerp it) + (nth (1- it) + (magit-section-siblings (magit-current-section) + 'next)) + (magit-get-section it)) + magit-status-initial-section))) + (goto-char (oref section start)) + (when-let ((vis (cdr (assq 'magit-status-initial-section + magit-section-initial-visibility-alist)))) + (if (eq vis 'hide) + (magit-section-hide section) + (magit-section-show section)))) + (remove-hook 'magit-refresh-buffer-hook + 'magit-status-goto-initial-section-1 t)) + +(defun magit-status-maybe-update-revision-buffer (&optional _) + "When moving in the status buffer, update the revision buffer. +If there is no revision buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-revision-buffer))) + +(defun magit-status-maybe-update-stash-buffer (&optional _) + "When moving in the status buffer, update the stash buffer. +If there is no stash buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-stash-buffer))) + +(defun magit-status-maybe-update-blob-buffer (&optional _) + "When moving in the status buffer, update the blob buffer. +If there is no blob buffer in the same frame, then do nothing." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-blob-buffer))) + +;;; Sections +;;;; Special Headers + +(defun magit-insert-status-headers () + "Insert header sections appropriate for `magit-status-mode' buffers. +The sections are inserted by running the functions on the hook +`magit-status-headers-hook'." + (if (magit-rev-verify "HEAD") + (magit-insert-headers 'magit-status-headers-hook) + (insert "In the beginning there was darkness\n\n"))) + +(defvar magit-error-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-process-buffer) + map) + "Keymap for `error' sections.") + +(defun magit-insert-error-header () + "Insert the message about the Git error that just occurred. + +This function is only aware of the last error that occur when Git +was run for side-effects. If, for example, an error occurs while +generating a diff, then that error won't be inserted. Refreshing +the status buffer causes this section to disappear again." + (when magit-this-error + (magit-insert-section (error 'git) + (insert (propertize (format "%-10s" "GitError! ") + 'font-lock-face 'magit-section-heading)) + (insert (propertize magit-this-error + 'font-lock-face 'font-lock-warning-face)) + (when-let ((key (car (where-is-internal 'magit-process-buffer)))) + (insert (format " [Type `%s' for details]" (key-description key)))) + (insert ?\n)) + (setq magit-this-error nil))) + +(defun magit-insert-diff-filter-header () + "Insert a header line showing the effective diff filters." + (let ((ignore-modules (magit-ignore-submodules-p))) + (when (or ignore-modules + magit-buffer-diff-files) + (insert (propertize (format "%-10s" "Filter! ") + 'font-lock-face 'magit-section-heading)) + (when ignore-modules + (insert ignore-modules) + (when magit-buffer-diff-files + (insert " -- "))) + (when magit-buffer-diff-files + (insert (mapconcat #'identity magit-buffer-diff-files " "))) + (insert ?\n)))) + +;;;; Reference Headers + +(defun magit-insert-head-branch-header (&optional branch) + "Insert a header line about the current branch. +If `HEAD' is detached, then insert information about that commit +instead. The optional BRANCH argument is for internal use only." + (let ((branch (or branch (magit-get-current-branch))) + (output (magit-rev-format "%h %s" (or branch "HEAD")))) + (string-match "^\\([^ ]+\\) \\(.*\\)" output) + (magit-bind-match-strings (commit summary) output + (when (equal summary "") + (setq summary "(no commit message)")) + (if branch + (magit-insert-section (branch branch) + (insert (format "%-10s" "Head: ")) + (when magit-status-show-hashes-in-headers + (insert (propertize commit 'font-lock-face 'magit-hash) ?\s)) + (insert (propertize branch 'font-lock-face 'magit-branch-local)) + (insert ?\s) + (insert (funcall magit-log-format-message-function branch summary)) + (insert ?\n)) + (magit-insert-section (commit commit) + (insert (format "%-10s" "Head: ")) + (insert (propertize commit 'font-lock-face 'magit-hash)) + (insert ?\s) + (insert (funcall magit-log-format-message-function nil summary)) + (insert ?\n)))))) + +(defun magit-insert-upstream-branch-header (&optional branch upstream keyword) + "Insert a header line about the upstream of the current branch. +If no branch is checked out, then insert nothing. The optional +arguments are for internal use only." + (when-let ((branch (or branch (magit-get-current-branch)))) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (rebase (magit-get "branch" branch "rebase"))) + (when (or remote merge) + (unless upstream + (setq upstream (magit-get-upstream-branch branch))) + (magit-insert-section (branch upstream) + (pcase rebase + ("true") + ("false" (setq rebase nil)) + (_ (setq rebase (magit-get-boolean "pull.rebase")))) + (insert (format "%-10s" (or keyword (if rebase "Rebase: " "Merge: ")))) + (insert + (if upstream + (concat (and magit-status-show-hashes-in-headers + (concat (propertize (magit-rev-format "%h" upstream) + 'font-lock-face 'magit-hash) + " ")) + upstream " " + (funcall magit-log-format-message-function upstream + (funcall magit-log-format-message-function nil + (or (magit-rev-format "%s" upstream) + "(no commit message)")))) + (cond + ((magit--unnamed-upstream-p remote merge) + (concat (propertize merge 'font-lock-face 'magit-branch-remote) + " from " + (propertize remote 'font-lock-face 'bold))) + ((magit--valid-upstream-p remote merge) + (if (equal remote ".") + (concat + (propertize merge 'font-lock-face 'magit-branch-local) + (propertize " does not exist" + 'font-lock-face 'font-lock-warning-face)) + (concat + (propertize merge 'font-lock-face 'magit-branch-remote) + (propertize " does not exist on " + 'font-lock-face 'font-lock-warning-face) + (propertize remote 'font-lock-face 'magit-branch-remote)))) + (t + (propertize "invalid upstream configuration" + 'font-lock-face 'font-lock-warning-face))))) + (insert ?\n)))))) + +(defun magit-insert-push-branch-header () + "Insert a header line about the branch the current branch is pushed to." + (when-let ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch))) + (magit-insert-section (branch target) + (insert (format "%-10s" "Push: ")) + (insert + (if (magit-rev-verify target) + (concat target " " + (and magit-status-show-hashes-in-headers + (concat (propertize (magit-rev-format "%h" target) + 'font-lock-face 'magit-hash) + " ")) + (funcall magit-log-format-message-function target + (funcall magit-log-format-message-function nil + (or (magit-rev-format "%s" target) + "(no commit message)")))) + (let ((remote (magit-get-push-remote branch))) + (if (magit-remote-p remote) + (concat target + (propertize " does not exist" + 'font-lock-face 'font-lock-warning-face)) + (concat remote + (propertize " remote does not exist" + 'font-lock-face 'font-lock-warning-face)))))) + (insert ?\n)))) + +(defun magit-insert-tags-header () + "Insert a header line about the current and/or next tag." + (let* ((this-tag (magit-get-current-tag nil t)) + (next-tag (magit-get-next-tag nil t)) + (this-cnt (cadr this-tag)) + (next-cnt (cadr next-tag)) + (this-tag (car this-tag)) + (next-tag (car next-tag)) + (both-tags (and this-tag next-tag t))) + (when (or this-tag next-tag) + (magit-insert-section (tag (or this-tag next-tag)) + (insert (format "%-10s" (if both-tags "Tags: " "Tag: "))) + (cl-flet ((insert-count + (tag count face) + (insert (concat (propertize tag 'font-lock-face 'magit-tag) + (and (> count 0) + (format " (%s)" + (propertize + (format "%s" count) + 'font-lock-face face))))))) + (when this-tag (insert-count this-tag this-cnt 'magit-branch-local)) + (when both-tags (insert ", ")) + (when next-tag (insert-count next-tag next-cnt 'magit-tag))) + (insert ?\n))))) + +;;;; Auxiliary Headers + +(defun magit-insert-user-header () + "Insert a header line about the current user." + (let ((name (magit-get "user.name")) + (email (magit-get "user.email"))) + (when (and name email) + (magit-insert-section (user name) + (insert (format "%-10s" "User: ")) + (insert (propertize name 'font-lock-face 'magit-log-author)) + (insert " <" email ">\n"))))) + +(defun magit-insert-repo-header () + "Insert a header line showing the path to the repository top-level." + (let ((topdir (magit-toplevel))) + (magit-insert-section (repo topdir) + (insert (format "%-10s%s\n" "Repo: " (abbreviate-file-name topdir)))))) + +(defun magit-insert-remote-header () + "Insert a header line about the remote of the current branch. + +If no remote is configured for the current branch, then fall back +showing the \"origin\" remote, or if that does not exist the first +remote in alphabetic order." + (when-let ((name (magit-get-some-remote)) + ;; Under certain configurations it's possible for url + ;; to be nil, when name is not, see #2858. + (url (magit-get "remote" name "url"))) + (magit-insert-section (remote name) + (insert (format "%-10s" "Remote: ")) + (insert (propertize name 'font-lock-face 'magit-branch-remote) ?\s) + (insert url ?\n)))) + +;;;; File Sections + +(defvar magit-untracked-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-delete-thing] 'magit-discard) + (define-key map "s" 'magit-stage) + map) + "Keymap for the `untracked' section.") + +(magit-define-section-jumper magit-jump-to-untracked "Untracked files" untracked) + +(defun magit-insert-untracked-files () + "Maybe insert a list or tree of untracked files. + +Do so depending on the value of `status.showUntrackedFiles'. +Note that even if the value is `all', Magit still initially +only shows directories. But the directory sections can then +be expanded using \"TAB\". + +If the first element of `magit-buffer-diff-files' is a +directory, then limit the list to files below that. The value +value of that variable can be set using \"D -- DIRECTORY RET g\"." + (let* ((show (or (magit-get "status.showUntrackedFiles") "normal")) + (base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base))) + (unless (equal show "no") + (if (equal show "all") + (when-let ((files (magit-untracked-files nil base))) + (magit-insert-section (untracked) + (magit-insert-heading "Untracked files:") + (magit-insert-files files base) + (insert ?\n))) + (when-let ((files + (--mapcat (and (eq (aref it 0) ??) + (list (substring it 3))) + (magit-git-items "status" "-z" "--porcelain" + (magit-ignore-submodules-p t) + "--" base)))) + (magit-insert-section (untracked) + (magit-insert-heading "Untracked files:") + (dolist (file files) + (magit-insert-section (file file) + (insert (propertize file 'font-lock-face 'magit-filename) ?\n))) + (insert ?\n))))))) + +(magit-define-section-jumper magit-jump-to-tracked "Tracked files" tracked) + +(defun magit-insert-tracked-files () + "Insert a tree of tracked files. + +If the first element of `magit-buffer-diff-files' is a +directory, then limit the list to files below that. The value +value of that variable can be set using \"D -- DIRECTORY RET g\"." + (when-let ((files (magit-list-files))) + (let* ((base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base))) + (magit-insert-section (tracked nil t) + (magit-insert-heading "Tracked files:") + (magit-insert-files files base) + (insert ?\n))))) + +(defun magit-insert-ignored-files () + "Insert a tree of ignored files. + +If the first element of `magit-buffer-diff-files' is a +directory, then limit the list to files below that. The value +of that variable can be set using \"D -- DIRECTORY RET g\"." + (when-let ((files (magit-ignored-files))) + (let* ((base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base))) + (magit-insert-section (tracked nil t) + (magit-insert-heading "Ignored files:") + (magit-insert-files files base) + (insert ?\n))))) + +(magit-define-section-jumper magit-jump-to-skip-worktree "Skip-worktree files" skip-worktree) + +(defun magit-insert-skip-worktree-files () + "Insert a tree of skip-worktree files. + +If the first element of `magit-buffer-diff-files' is a +directory, then limit the list to files below that. The value +of that variable can be set using \"D -- DIRECTORY RET g\"." + (when-let ((files (magit-skip-worktree-files))) + (let* ((base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base))) + (magit-insert-section (skip-worktree nil t) + (magit-insert-heading "Skip-worktree files:") + (magit-insert-files files base) + (insert ?\n))))) + +(magit-define-section-jumper magit-jump-to-assume-unchanged "Assume-unchanged files" assume-unchanged) + +(defun magit-insert-assume-unchanged-files () + "Insert a tree of files that are assumed to be unchanged. + +If the first element of `magit-buffer-diff-files' is a +directory, then limit the list to files below that. The value +of that variable can be set using \"D -- DIRECTORY RET g\"." + (when-let ((files (magit-assume-unchanged-files))) + (let* ((base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base))) + (magit-insert-section (assume-unchanged nil t) + (magit-insert-heading "Assume-unchanged files:") + (magit-insert-files files base) + (insert ?\n))))) + +(defun magit-insert-files (files directory) + (while (and files (string-prefix-p (or directory "") (car files))) + (let ((dir (file-name-directory (car files)))) + (if (equal dir directory) + (let ((file (pop files))) + (magit-insert-section (file file) + (insert (propertize file 'font-lock-face 'magit-filename) ?\n))) + (magit-insert-section (file dir t) + (insert (propertize dir 'file 'magit-filename) ?\n) + (magit-insert-heading) + (setq files (magit-insert-files files dir)))))) + files) + +;;; _ +(provide 'magit-status) +;;; magit-status.el ends here diff --git a/elpa/magit-20200318.1224/magit-status.elc b/elpa/magit-20200318.1224/magit-status.elc new file mode 100644 index 00000000..1c2ebae4 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-status.elc differ diff --git a/elpa/magit-20200318.1224/magit-submodule.el b/elpa/magit-20200318.1224/magit-submodule.el new file mode 100644 index 00000000..3f201631 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-submodule.el @@ -0,0 +1,664 @@ +;;; magit-submodule.el --- submodule support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit) + +(defvar x-stretch-cursor) +;;; Options + +(defcustom magit-module-sections-hook + '(magit-insert-modules-overview + magit-insert-modules-unpulled-from-upstream + magit-insert-modules-unpulled-from-pushremote + magit-insert-modules-unpushed-to-upstream + magit-insert-modules-unpushed-to-pushremote) + "Hook run by `magit-insert-modules'. + +That function isn't part of `magit-status-sections-hook's default +value, so you have to add it yourself for this hook to have any +effect." + :package-version '(magit . "2.11.0") + :group 'magit-status + :type 'hook) + +(defcustom magit-module-sections-nested t + "Whether `magit-insert-modules' wraps inserted sections. + +If this is non-nil, then only a single top-level section +is inserted. If it is nil, then all sections listed in +`magit-module-sections-hook' become top-level sections." + :package-version '(magit . "2.11.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-submodule-list-mode-hook '(hl-line-mode) + "Hook run after entering Magit-Submodule-List mode." + :package-version '(magit . "2.9.0") + :group 'magit-repolist + :type 'hook + :get 'magit-hook-custom-get + :options '(hl-line-mode)) + +(defcustom magit-submodule-list-columns + '(("Path" 25 magit-modulelist-column-path nil) + ("Version" 25 magit-repolist-column-version nil) + ("Branch" 20 magit-repolist-column-branch nil) + ("BU" 3 magit-repolist-column-unpushed-to-upstream ((:right-align t))) + ("BP" 3 magit-repolist-column-unpushed-to-pushremote ((:right-align t))) + ("B" 3 magit-repolist-column-branches ((:right-align t))) + ("S" 3 magit-repolist-column-stashes ((:right-align t)))) + "List of columns displayed by `magit-list-submodules'. + +Each element has the form (HEADER WIDTH FORMAT PROPS). + +HEADER is the string displayed in the header. WIDTH is the width +of the column. FORMAT is a function that is called with one +argument, the repository identification (usually its basename), +and with `default-directory' bound to the toplevel of its working +tree. It has to return a string to be inserted or nil. PROPS is +an alist that supports the keys `:right-align' and `:pad-right'." + :package-version '(magit . "2.8.0") + :group 'magit-repolist-mode + :type `(repeat (list :tag "Column" + (string :tag "Header Label") + (integer :tag "Column Width") + (function :tag "Inserter Function") + (repeat :tag "Properties" + (list (choice :tag "Property" + (const :right-align) + (const :pad-right) + (symbol)) + (sexp :tag "Value")))))) + +(defcustom magit-submodule-remove-trash-gitdirs nil + "Whether `magit-submodule-remove' offers to trash module gitdirs. + +If this is nil, then that command does not offer to do so unless +a prefix argument is used. When this is t, then it does offer to +do so even without a prefix argument. + +In both cases the action still has to be confirmed unless that is +disabled using the option `magit-no-confirm'. Doing the latter +and also setting this variable to t will lead to tears." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'boolean) + +;;; Popup + +;;;###autoload (autoload 'magit-submodule "magit-submodule" nil t) +(define-transient-command magit-submodule () + "Act on a submodule." + :man-page "git-submodule" + ["Arguments" + ("-f" "Force" ("-f" "--force")) + ("-r" "Recursive" "--recursive") + ("-N" "Do not fetch" ("-N" "--no-fetch")) + ("-C" "Checkout tip" "--checkout") + ("-R" "Rebase onto tip" "--rebase") + ("-M" "Merge tip" "--merge") + ("-U" "Use upstream tip" "--remote")] + ["One module actions" + ("a" magit-submodule-add) + ("r" magit-submodule-register) + ("p" magit-submodule-populate) + ("u" magit-submodule-update) + ("s" magit-submodule-synchronize) + ("d" magit-submodule-unpopulate) + ("k" "Remove" magit-submodule-remove)] + ["All modules actions" + ("l" "List all modules" magit-list-submodules) + ("f" "Fetch all modules" magit-fetch-modules)]) + +(defun magit-submodule-arguments (&rest filters) + (--filter (and (member it filters) it) + (transient-args 'magit-submodule))) + +(defclass magit--git-submodule-suffix (transient-suffix) + ()) + +(cl-defmethod transient-format-description ((obj magit--git-submodule-suffix)) + (let ((value (delq nil (mapcar 'transient-infix-value transient--suffixes)))) + (replace-regexp-in-string + "\\[--[^]]+\\]" + (lambda (match) + (format (propertize "[%s]" 'face 'transient-inactive-argument) + (mapconcat (lambda (arg) + (propertize arg 'face + (if (member arg value) + 'transient-argument + 'transient-inactive-argument))) + (save-match-data + (split-string (substring match 1 -1) "|")) + (propertize "|" 'face 'transient-inactive-argument)))) + (cl-call-next-method obj)))) + +;;;###autoload (autoload 'magit-submodule-add "magit-submodule" nil t) +(define-suffix-command magit-submodule-add (url &optional path name args) + "Add the repository at URL as a module. + +Optional PATH is the path to the module relative to the root of +the superproject. If it is nil, then the path is determined +based on the URL. Optional NAME is the name of the module. If +it is nil, then PATH also becomes the name." + :class 'magit--git-submodule-suffix + :description "Add git submodule add [--force]" + (interactive + (magit-with-toplevel + (let* ((url (magit-read-string-ns "Add submodule (remote url)")) + (path (let ((read-file-name-function + (if (or (eq read-file-name-function 'ido-read-file-name) + (advice-function-member-p + 'ido-read-file-name + read-file-name-function)) + ;; The Ido variant doesn't work properly here. + #'read-file-name-default + read-file-name-function))) + (directory-file-name + (file-relative-name + (read-directory-name + "Add submodules at path: " nil nil nil + (and (string-match "\\([^./]+\\)\\(\\.git\\)?$" url) + (match-string 1 url)))))))) + (list url + (directory-file-name path) + (magit-submodule-read-name-for-path path) + (magit-submodule-arguments "--force"))))) + (magit-submodule-add-1 url path name args)) + +(defun magit-submodule-add-1 (url &optional path name args) + (magit-with-toplevel + (magit-submodule--maybe-reuse-gitdir name path) + (magit-run-git-async "submodule" "add" + (and name (list "--name" name)) + args "--" url path) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (unless (version< (magit-git-version) "2.12.0") + (magit-call-git "submodule" "absorbgitdirs" path)) + (magit-refresh))))))) + +;;;###autoload +(defun magit-submodule-read-name-for-path (path &optional prefer-short) + (let* ((path (directory-file-name (file-relative-name path))) + (name (file-name-nondirectory path))) + (push (if prefer-short path name) minibuffer-history) + (magit-read-string-ns + "Submodule name" nil (cons 'minibuffer-history 2) + (or (--keep (pcase-let ((`(,var ,val) (split-string it "="))) + (and (equal val path) + (cadr (split-string var "\\.")))) + (magit-git-lines "config" "--list" "-f" ".gitmodules")) + (if prefer-short name path))))) + +;;;###autoload (autoload 'magit-submodule-register "magit-submodule" nil t) +(define-suffix-command magit-submodule-register (modules) + "Register MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; This command and the underlying "git submodule init" do NOT + ;; "initialize" modules. They merely "register" modules in the + ;; super-projects $GIT_DIR/config file, the purpose of which is to + ;; allow users to change such values before actually initializing + ;; the modules. + :description "Register git submodule init" + (interactive + (list (magit-module-confirm "Register" 'magit-module-no-worktree-p))) + (magit-with-toplevel + (magit-run-git-async "submodule" "init" "--" modules))) + +;;;###autoload (autoload 'magit-submodule-populate "magit-submodule" nil t) +(define-suffix-command magit-submodule-populate (modules) + "Create MODULES working directories, checking out the recorded commits. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; This is the command that actually "initializes" modules. + ;; A module is initialized when it has a working directory, + ;; a gitlink, and a .gitmodules entry. + :description "Populate git submodule update --init" + (interactive + (list (magit-module-confirm "Populate" 'magit-module-no-worktree-p))) + (magit-with-toplevel + (magit-run-git-async "submodule" "update" "--init" "--" modules))) + +;;;###autoload (autoload 'magit-submodule-update "magit-submodule" nil t) +(define-suffix-command magit-submodule-update (modules args) + "Update MODULES by checking out the recorded commits. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; Unlike `git-submodule's `update' command ours can only update + ;; "initialized" modules by checking out other commits but not + ;; "initialize" modules by creating the working directories. + ;; To do the latter we provide the "setup" command. + :class 'magit--git-submodule-suffix + :description "Update git submodule update [--force] [--no-fetch] + [--remote] [--recursive] [--checkout|--rebase|--merge]" + (interactive + (list (magit-module-confirm "Update" 'magit-module-worktree-p) + (magit-submodule-arguments + "--force" "--remote" "--recursive" "--checkout" "--rebase" "--merge" + "--no-fetch"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "update" args "--" modules))) + +;;;###autoload (autoload 'magit-submodule-synchronize "magit-submodule" nil t) +(define-suffix-command magit-submodule-synchronize (modules args) + "Synchronize url configuration of MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + :class 'magit--git-submodule-suffix + :description "Synchronize git submodule sync [--recursive]" + (interactive + (list (magit-module-confirm "Synchronize" 'magit-module-worktree-p) + (magit-submodule-arguments "--recursive"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "sync" args "--" modules))) + +;;;###autoload (autoload 'magit-submodule-unpopulate "magit-submodule" nil t) +(define-suffix-command magit-submodule-unpopulate (modules args) + "Remove working directories of MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; Even though a package is "uninitialized" (it has no worktree) + ;; the super-projects $GIT_DIR/config may never-the-less set the + ;; module's url. This may happen if you `deinit' and then `init' + ;; to register (NOT initialize). Because the purpose of `deinit' + ;; is to remove the working directory AND to remove the url, this + ;; command does not limit itself to modules that have no working + ;; directory. + :class 'magit--git-submodule-suffix + :description "Unpopulate git submodule deinit [--force]" + (interactive + (list (magit-module-confirm "Unpopulate") + (magit-submodule-arguments "--force"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "deinit" args "--" modules))) + +;;;###autoload +(defun magit-submodule-remove (modules args trash-gitdirs) + "Unregister MODULES and remove their working directories. + +For safety reasons, do not remove the gitdirs and if a module has +uncomitted changes, then do not remove it at all. If a module's +gitdir is located inside the working directory, then move it into +the gitdir of the superproject first. + +With the \"--force\" argument offer to remove dirty working +directories and with a prefix argument offer to delete gitdirs. +Both actions are very dangerous and have to be confirmed. There +are additional safety precautions in place, so you might be able +to recover from making a mistake here, but don't count on it." + (interactive + (list (if-let ((modules (magit-region-values 'magit-module-section t))) + (magit-confirm 'remove-modules nil "Remove %i modules" nil modules) + (list (magit-read-module-path "Remove module"))) + (magit-submodule-arguments "--force") + current-prefix-arg)) + (when (version< (magit-git-version) "2.12.0") + (error "This command requires Git v2.12.0")) + (when magit-submodule-remove-trash-gitdirs + (setq trash-gitdirs t)) + (magit-with-toplevel + (when-let + ((modified + (-filter (lambda (module) + (let ((default-directory (file-name-as-directory + (expand-file-name module)))) + (and (cddr (directory-files default-directory)) + (magit-anything-modified-p)))) + modules))) + (if (member "--force" args) + (if (magit-confirm 'remove-dirty-modules + "Remove dirty module %s" + "Remove %i dirty modules" + t modified) + (dolist (module modified) + (let ((default-directory (file-name-as-directory + (expand-file-name module)))) + (magit-git "stash" "push" + "-m" "backup before removal of this module"))) + (setq modules (cl-set-difference modules modified))) + (if (cdr modified) + (message "Omitting %s modules with uncommitted changes: %s" + (length modified) + (mapconcat #'identity modified ", ")) + (message "Omitting module %s, it has uncommitted changes" + (car modified))) + (setq modules (cl-set-difference modules modified)))) + (when modules + (let ((alist + (and trash-gitdirs + (--map (split-string it "\0") + (magit-git-lines "submodule" "foreach" "-q" + "printf \"$sm_path\\0$name\n\""))))) + (magit-git "submodule" "absorbgitdirs" "--" modules) + (magit-git "submodule" "deinit" args "--" modules) + (magit-git "rm" args "--" modules) + (when (and trash-gitdirs + (magit-confirm 'trash-module-gitdirs + "Trash gitdir of module %s" + "Trash gitdirs of %i modules" + t modules)) + (dolist (module modules) + (if-let ((name (cadr (assoc module alist)))) + ;; Disregard if `magit-delete-by-moving-to-trash' + ;; is nil. Not doing so would be too dangerous. + (delete-directory (magit-git-dir + (convert-standard-filename + (concat "modules/" name))) + t t) + (error "BUG: Weird module name and/or path for %s" module))))) + (magit-refresh)))) + +;;; Sections + +;;;###autoload +(defun magit-insert-modules () + "Insert submodule sections. +Hook `magit-module-sections-hook' controls which module sections +are inserted, and option `magit-module-sections-nested' controls +whether they are wrapped in an additional section." + (when-let ((modules (magit-list-module-paths))) + (if magit-module-sections-nested + (magit-insert-section (modules nil t) + (magit-insert-heading + (format "%s (%s)" + (propertize "Modules" + 'font-lock-face 'magit-section-heading) + (length modules))) + (magit-insert-section-body + (magit--insert-modules))) + (magit--insert-modules)))) + +(defun magit--insert-modules (&optional _section) + (magit-run-section-hook 'magit-module-sections-hook)) + +;;;###autoload +(defun magit-insert-modules-overview () + "Insert sections for all modules. +For each section insert the path and the output of `git describe --tags', +or, failing that, the abbreviated HEAD commit hash." + (when-let ((modules (magit-list-module-paths))) + (magit-insert-section (modules nil t) + (magit-insert-heading + (format "%s (%s)" + (propertize "Modules overview" + 'font-lock-face 'magit-section-heading) + (length modules))) + (magit-insert-section-body + (magit--insert-modules-overview))))) + +(defvar magit-modules-overview-align-numbers t) + +(defun magit--insert-modules-overview (&optional _section) + (magit-with-toplevel + (let* ((modules (magit-list-module-paths)) + (path-format (format "%%-%is " + (min (apply 'max (mapcar 'length modules)) + (/ (window-width) 2)))) + (branch-format (format "%%-%is " (min 25 (/ (window-width) 3))))) + (dolist (module modules) + (let ((default-directory + (expand-file-name (file-name-as-directory module)))) + (magit-insert-section (magit-module-section module t) + (insert (propertize (format path-format module) + 'font-lock-face 'magit-diff-file-heading)) + (if (not (file-exists-p ".git")) + (insert "(unpopulated)") + (insert (format + branch-format + (--if-let (magit-get-current-branch) + (propertize it 'font-lock-face 'magit-branch-local) + (propertize "(detached)" 'font-lock-face 'warning)))) + (--if-let (magit-git-string "describe" "--tags") + (progn (when (and magit-modules-overview-align-numbers + (string-match-p "\\`[0-9]" it)) + (insert ?\s)) + (insert (propertize it 'font-lock-face 'magit-tag))) + (--when-let (magit-rev-format "%h") + (insert (propertize it 'font-lock-face 'magit-hash))))) + (insert ?\n)))))) + (insert ?\n)) + +(defvar magit-modules-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-list-submodules) + map) + "Keymap for `modules' sections.") + +(defvar magit-module-section-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-file-section-map) + (define-key map (kbd "C-j") 'magit-submodule-visit) + (define-key map [C-return] 'magit-submodule-visit) + (define-key map [remap magit-visit-thing] 'magit-submodule-visit) + (define-key map [remap magit-delete-thing] 'magit-submodule-unpopulate) + (define-key map "K" 'magit-file-untrack) + (define-key map "R" 'magit-file-rename) + map) + "Keymap for `module' sections.") + +(defun magit-submodule-visit (module &optional other-window) + "Visit MODULE by calling `magit-status' on it. +Offer to initialize MODULE if it's not checked out yet. +With a prefix argument, visit in another window." + (interactive (list (or (magit-section-value-if 'module) + (magit-read-module-path "Visit module")) + current-prefix-arg)) + (magit-with-toplevel + (let ((path (expand-file-name module))) + (cond + ((file-exists-p (expand-file-name ".git" module)) + (magit-diff-visit-directory path other-window)) + ((y-or-n-p (format "Initialize submodule '%s' first?" module)) + (magit-run-git-async "submodule" "update" "--init" "--" module) + (set-process-sentinel + magit-this-process + (lambda (process event) + (let ((magit-process-raise-error t)) + (magit-process-sentinel process event)) + (when (and (eq (process-status process) 'exit) + (= (process-exit-status process) 0)) + (magit-diff-visit-directory path other-window))))) + ((file-exists-p path) + (dired-jump other-window (concat path "/."))))))) + +;;;###autoload +(defun magit-insert-modules-unpulled-from-upstream () + "Insert sections for modules that haven't been pulled from the upstream. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpulled from @{upstream}" + 'modules-unpulled-from-upstream + "HEAD..@{upstream}")) + +;;;###autoload +(defun magit-insert-modules-unpulled-from-pushremote () + "Insert sections for modules that haven't been pulled from the push-remote. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpulled from @{push}" + 'modules-unpulled-from-pushremote + "HEAD..@{push}")) + +;;;###autoload +(defun magit-insert-modules-unpushed-to-upstream () + "Insert sections for modules that haven't been pushed to the upstream. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unmerged into @{upstream}" + 'modules-unpushed-to-upstream + "@{upstream}..HEAD")) + +;;;###autoload +(defun magit-insert-modules-unpushed-to-pushremote () + "Insert sections for modules that haven't been pushed to the push-remote. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpushed to @{push}" + 'modules-unpushed-to-pushremote + "@{push}..HEAD")) + +(defun magit--insert-modules-logs (heading type range) + "For internal use, don't add to a hook." + (unless (magit-ignore-submodules-p) + (when-let ((modules (magit-list-module-paths))) + (magit-insert-section section ((eval type) nil t) + (string-match "\\`\\(.+\\) \\([^ ]+\\)\\'" heading) + (magit-insert-heading + (propertize (match-string 1 heading) + 'font-lock-face 'magit-section-heading) + " " + (propertize (match-string 2 heading) + 'font-lock-face 'magit-branch-remote) + ":") + (magit-with-toplevel + (dolist (module modules) + (when (magit-module-worktree-p module) + (let ((default-directory + (expand-file-name (file-name-as-directory module)))) + (when (magit-file-accessible-directory-p default-directory) + (magit-insert-section sec (magit-module-section module t) + (magit-insert-heading + (propertize module + 'font-lock-face 'magit-diff-file-heading) + ":") + (magit-git-wash + (apply-partially 'magit-log-wash-log 'module) + "-c" "push.default=current" "log" "--oneline" range) + (when (> (point) + (oref sec content)) + (delete-char -1)))))))) + (if (> (point) + (oref section content)) + (insert ?\n) + (magit-cancel-section)))))) + +;;; List + +;;;###autoload +(defun magit-list-submodules () + "Display a list of the current repository's submodules." + (interactive) + (magit-display-buffer + (or (magit-get-mode-buffer 'magit-submodule-list-mode) + (magit-with-toplevel + (magit-generate-new-buffer 'magit-submodule-list-mode)))) + (magit-submodule-list-mode) + (magit-submodule-list-refresh) + (tabulated-list-print)) + +(defvar magit-submodule-list-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map magit-repolist-mode-map) + map) + "Local keymap for Magit-Submodule-List mode buffers.") + +(define-derived-mode magit-submodule-list-mode tabulated-list-mode "Modules" + "Major mode for browsing a list of Git submodules." + :group 'magit-repolist-mode + (setq-local x-stretch-cursor nil) + (setq tabulated-list-padding 0) + (setq tabulated-list-sort-key (cons "Path" nil)) + (setq tabulated-list-format + (vconcat (mapcar (pcase-lambda (`(,title ,width ,_fn ,props)) + (nconc (list title width t) + (-flatten props))) + magit-submodule-list-columns))) + (tabulated-list-init-header) + (add-hook 'tabulated-list-revert-hook 'magit-submodule-list-refresh nil t) + (setq imenu-prev-index-position-function + #'magit-imenu--submodule-prev-index-position-function) + (setq imenu-extract-index-name-function + #'magit-imenu--submodule-extract-index-name-function)) + +(defun magit-submodule-list-refresh () + (setq tabulated-list-entries + (-keep (lambda (module) + (let ((default-directory + (expand-file-name (file-name-as-directory module)))) + (and (file-exists-p ".git") + (list module + (vconcat + (--map (or (funcall (nth 2 it) module) "") + magit-submodule-list-columns)))))) + (magit-list-module-paths)))) + +(defun magit-modulelist-column-path (path) + "Insert the relative path of the submodule." + path) + +;;; Utilities + +(defun magit-submodule--maybe-reuse-gitdir (name path) + (let ((gitdir + (magit-git-dir (convert-standard-filename (concat "modules/" name))))) + (when (and (file-exists-p gitdir) + (not (file-exists-p path))) + (pcase (read-char-choice + (concat + gitdir " already exists.\n" + "Type [u] to use the existing gitdir and create the working tree\n" + " [r] to rename the existing gitdir and clone again\n" + " [t] to trash the existing gitdir and clone again\n" + " [C-g] to abort ") + '(?u ?r ?t)) + (?u (magit-submodule--restore-worktree (expand-file-name path) gitdir)) + (?r (rename-file gitdir (concat gitdir "-" + (format-time-string "%F-%T")))) + (?t (delete-directory gitdir t t)))))) + +(defun magit-submodule--restore-worktree (worktree gitdir) + (make-directory worktree t) + (with-temp-file (expand-file-name ".git" worktree) + (insert "gitdir: " (file-relative-name gitdir worktree) "\n")) + (let ((default-directory worktree)) + (magit-call-git "reset" "--hard" "HEAD" "--"))) + +;;; _ +(provide 'magit-submodule) +;;; magit-submodule.el ends here diff --git a/elpa/magit-20200318.1224/magit-submodule.elc b/elpa/magit-20200318.1224/magit-submodule.elc new file mode 100644 index 00000000..e8561810 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-submodule.elc differ diff --git a/elpa/magit-20200318.1224/magit-subtree.el b/elpa/magit-20200318.1224/magit-subtree.el new file mode 100644 index 00000000..1ea3bbe0 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-subtree.el @@ -0,0 +1,182 @@ +;;; magit-subtree.el --- subtree support for Magit -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-subtree "magit-subtree" nil t) +(define-transient-command magit-subtree () + "Import or export subtrees." + :man-page "git-subtree" + ["Actions" + ("i" "Import" magit-subtree-import) + ("e" "Export" magit-subtree-export)]) + +;;;###autoload (autoload 'magit-subtree-import "magit-subtree" nil t) +(define-transient-command magit-subtree-import () + "Import subtrees." + :man-page "git-subtree" + ["Arguments" + (magit-subtree:--prefix) + (magit-subtree:--message) + ("-s" "Squash" "--squash")] + ["Actions" + [("a" "Add" magit-subtree-add) + ("c" "Add commit" magit-subtree-add-commit)] + [("m" "Merge" magit-subtree-merge) + ("f" "Pull" magit-subtree-pull)]]) + +;;;###autoload (autoload 'magit-subtree-export "magit-subtree" nil t) +(define-transient-command magit-subtree-export () + "Export subtrees." + :man-page "git-subtree" + ["Arguments" + (magit-subtree:--prefix) + (magit-subtree:--annotate) + (magit-subtree:--branch) + (magit-subtree:--onto) + ("-i" "Ignore joins" "--ignore-joins") + ("-j" "Rejoin" "--rejoin")] + ["Actions" + ("p" "Push" magit-subtree-push) + ("s" "Split" magit-subtree-split)]) + +(define-infix-argument magit-subtree:--prefix () + :description "Prefix" + :class 'transient-option + :shortarg "-P" + :argument "--prefix=" + :reader 'magit-subtree-read-prefix) + +(defun magit-subtree-read-prefix (prompt &optional default _history) + (let* ((insert-default-directory nil) + (topdir (magit-toplevel)) + (prefix (read-directory-name (concat prompt ": ") topdir default))) + (if (file-name-absolute-p prefix) + ;; At least `ido-mode's variant is not compatible. + (if (string-prefix-p topdir prefix) + (file-relative-name prefix topdir) + (user-error "%s isn't inside the repository at %s" prefix topdir)) + prefix))) + +(define-infix-argument magit-subtree:--message () + :description "Message" + :class 'transient-option + :shortarg "-m" + :argument "--message=") + +(define-infix-argument magit-subtree:--annotate () + :description "Annotate" + :class 'transient-option + :key "-a" + :argument "--annotate=") + +(define-infix-argument magit-subtree:--branch () + :description "Branch" + :class 'transient-option + :shortarg "-b" + :argument "--branch=") + +(define-infix-argument magit-subtree:--onto () + :description "Onto" + :class 'transient-option + :key "-o" + :argument "--onto=" + :reader 'magit-transient-read-revision) + +(defun magit-subtree-prefix (transient prompt) + (--if-let (--first (string-prefix-p "--prefix=" it) + (transient-args transient)) + (substring it 9) + (magit-subtree-read-prefix prompt))) + +(defun magit-subtree-arguments (transient) + (--remove (string-prefix-p "--prefix=" it) + (transient-args transient))) + +(defun magit-git-subtree (subcmd prefix &rest args) + (magit-run-git-async "subtree" subcmd (concat "--prefix=" prefix) args)) + +;;;###autoload +(defun magit-subtree-add (prefix repository ref args) + "Add REF from REPOSITORY as a new subtree at PREFIX." + (interactive + (cons (magit-subtree-prefix 'magit-subtree-import "Add subtree") + (let ((remote (magit-read-remote-or-url "From repository"))) + (list remote + (magit-read-refspec "Ref" remote) + (magit-subtree-arguments 'magit-subtree-import))))) + (magit-git-subtree "add" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-add-commit (prefix commit args) + "Add COMMIT as a new subtree at PREFIX." + (interactive + (list (magit-subtree-prefix 'magit-subtree-import "Add subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-import))) + (magit-git-subtree "add" prefix args commit)) + +;;;###autoload +(defun magit-subtree-merge (prefix commit args) + "Merge COMMIT into the PREFIX subtree." + (interactive + (list (magit-subtree-prefix 'magit-subtree-import "Merge into subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-import))) + (magit-git-subtree "merge" prefix args commit)) + +;;;###autoload +(defun magit-subtree-pull (prefix repository ref args) + "Pull REF from REPOSITORY into the PREFIX subtree." + (interactive + (cons (magit-subtree-prefix 'magit-subtree-import "Pull into subtree") + (let ((remote (magit-read-remote-or-url "From repository"))) + (list remote + (magit-read-refspec "Ref" remote) + (magit-subtree-arguments 'magit-subtree-import))))) + (magit-git-subtree "pull" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-push (prefix repository ref args) + "Extract the history of the subtree PREFIX and push it to REF on REPOSITORY." + (interactive (list (magit-subtree-prefix 'magit-subtree-export "Push subtree") + (magit-read-remote-or-url "To repository") + (magit-read-string-ns "To reference") + (magit-subtree-arguments 'magit-subtree-export))) + (magit-git-subtree "push" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-split (prefix commit args) + "Extract the history of the subtree PREFIX." + (interactive (list (magit-subtree-prefix 'magit-subtree-export "Split subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-export))) + (magit-git-subtree "split" prefix args commit)) + +;;; _ +(provide 'magit-subtree) +;;; magit-subtree.el ends here diff --git a/elpa/magit-20200318.1224/magit-subtree.elc b/elpa/magit-20200318.1224/magit-subtree.elc new file mode 100644 index 00000000..f9555aff Binary files /dev/null and b/elpa/magit-20200318.1224/magit-subtree.elc differ diff --git a/elpa/magit-20200318.1224/magit-tag.el b/elpa/magit-20200318.1224/magit-tag.el new file mode 100644 index 00000000..c11dae8b --- /dev/null +++ b/elpa/magit-20200318.1224/magit-tag.el @@ -0,0 +1,193 @@ +;;; magit-tag.el --- tag functionality -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements tag commands. + +;;; Code: + +(require 'magit) + +;;;###autoload (autoload 'magit-tag "magit" nil t) +(define-transient-command magit-tag () + "Create or delete a tag." + :man-page "git-tag" + ["Arguments" + ("-f" "Force" ("-f" "--force")) + ("-a" "Annotate" ("-a" "--annotate")) + ("-s" "Sign" ("-s" "--sign")) + (magit-tag:--local-user)] + [["Create" + ("t" "tag" magit-tag-create) + ("r" "release" magit-tag-release)] + ["Do" + ("k" "delete" magit-tag-delete) + ("p" "prune" magit-tag-prune)]]) + +(defun magit-tag-arguments () + (transient-args 'magit-tag)) + +(define-infix-argument magit-tag:--local-user () + :description "Sign as" + :class 'transient-option + :shortarg "-u" + :argument "--local-user=" + :reader 'magit-read-gpg-secret-key + :history-key 'magit:--gpg-sign) + +;;;###autoload +(defun magit-tag-create (name rev &optional args) + "Create a new tag with the given NAME at REV. +With a prefix argument annotate the tag. +\n(git tag [--annotate] NAME REV)" + (interactive (list (magit-read-tag "Tag name") + (magit-read-branch-or-commit "Place tag on") + (let ((args (magit-tag-arguments))) + (when current-prefix-arg + (cl-pushnew "--annotate" args)) + args))) + (magit-run-git-with-editor "tag" args name rev)) + +;;;###autoload +(defun magit-tag-delete (tags) + "Delete one or more tags. +If the region marks multiple tags (and nothing else), then offer +to delete those, otherwise prompt for a single tag to be deleted, +defaulting to the tag at point. +\n(git tag -d TAGS)" + (interactive (list (--if-let (magit-region-values 'tag) + (magit-confirm t nil "Delete %i tags" nil it) + (magit-read-tag "Delete tag" t)))) + (magit-run-git "tag" "-d" tags)) + +;;;###autoload +(defun magit-tag-prune (tags remote-tags remote) + "Offer to delete tags missing locally from REMOTE, and vice versa." + (interactive + (let* ((remote (magit-read-remote "Prune tags using remote")) + (tags (magit-list-tags)) + (rtags (prog2 (message "Determining remote tags...") + (magit-remote-list-tags remote) + (message "Determining remote tags...done"))) + (ltags (-difference tags rtags)) + (rtags (-difference rtags tags))) + (unless (or ltags rtags) + (message "Same tags exist locally and remotely")) + (unless (magit-confirm t + "Delete %s locally" + "Delete %i tags locally" + 'noabort ltags) + (setq ltags nil)) + (unless (magit-confirm t + "Delete %s from remote" + "Delete %i tags from remote" + 'noabort rtags) + (setq rtags nil)) + (list ltags rtags remote))) + (when tags + (magit-call-git "tag" "-d" tags)) + (when remote-tags + (magit-run-git-async "push" remote (--map (concat ":" it) remote-tags)))) + +(defvar magit-release-tag-regexp "\\`\ +\\(?1:\\(?:v\\(?:ersion\\)?\\|r\\(?:elease\\)?\\)?[-_]?\\)?\ +\\(?2:[0-9]+\\(?:\\.[0-9]+\\)*\\)\\'" + "Regexp used to parse release tag names. +The first submatch must match the prefix, if any. +The second submatch must match the version string.") + +;;;###autoload +(defun magit-tag-release (tag msg) + "Create an annotated release tag. + +Assume that release tags match `magit-release-tag-regexp'. + +First prompt for the name of the new tag using the highest +existing tag as initial input and leaving it to the user to +increment the desired part of the version string. + +Then prompt for the message of the new tag. Base the proposed +tag message on the message of the highest tag, provided that +that contains the corresponding version string and substituting +the new version string for that. Otherwise propose something +like \"Foo-Bar 1.2.3\", given, for example, a TAG \"v1.2.3\" and a +repository located at something like \"/path/to/foo-bar\". + +Then call \"git tag --annotate --sign -m MSG TAG\" to create the, +tag, regardless of whether these arguments are enabled in the +popup. Finally show the refs buffer to let the user quickly +review the result." + (interactive + (save-match-data + (pcase-let* + ((`(,pver ,ptag ,pmsg) (car (magit--list-releases))) + (tag (read-string "Create release tag: " ptag)) + (ver (and (string-match magit-release-tag-regexp tag) + (match-string 2 tag))) + (msg (cond ((and pver (string-match (regexp-quote pver) pmsg)) + (replace-match ver t t pmsg)) + ((and ptag (string-match (regexp-quote ptag) pmsg)) + (replace-match tag t t pmsg)) + (t (format "%s %s" + (capitalize + (file-name-nondirectory + (directory-file-name (magit-toplevel)))) + ver))))) + (list tag (read-string (format "Message for %S: " tag) msg))))) + (magit-run-git-async "tag" "--annotate" "--sign" "-m" msg tag) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (magit-process-sentinel process event) + (magit-refs-setup-buffer "HEAD" (magit-show-refs-arguments)))))) + +(defun magit--list-releases () + "Return a list of releases. +The list is ordered, beginning with the highest release. +Each release element has the form (VERSION TAG MESSAGE). +`magit-release-tag-regexp' is used to determine whether +a tag qualifies as a release tag." + (save-match-data + (mapcar + #'cdr + (nreverse + (cl-sort (cl-mapcan + (lambda (line) + (and (string-match " +" line) + (let ((tag (substring line 0 (match-beginning 0))) + (msg (substring line (match-end 0)))) + (and (string-match magit-release-tag-regexp tag) + (let ((ver (match-string 2 tag))) + (list (list (version-to-list ver) + ver tag msg))))))) + ;; Cannot rely on "--sort=-version:refname" because + ;; that gets confused if the version prefix has changed. + (magit-git-lines "tag" "-n")) + ;; The inverse of this function does not exist. + #'version-list-< :key #'car))))) + +;;; _ +(provide 'magit-tag) +;;; magit-tag.el ends here diff --git a/elpa/magit-20200318.1224/magit-tag.elc b/elpa/magit-20200318.1224/magit-tag.elc new file mode 100644 index 00000000..430ef41a Binary files /dev/null and b/elpa/magit-20200318.1224/magit-tag.elc differ diff --git a/elpa/magit-20200318.1224/magit-transient.el b/elpa/magit-20200318.1224/magit-transient.el new file mode 100644 index 00000000..830eb507 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-transient.el @@ -0,0 +1,202 @@ +;;; magit-transient.el --- support for transients -*- lexical-binding: t -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements Magit-specific prefix and suffix classes, +;; and their methods. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'transient) + +(require 'magit-git) +(require 'magit-mode) +(require 'magit-process) + +;;; Classes + +(defclass magit--git-variable (transient-variable) + ((scope :initarg :scope))) + +(defclass magit--git-variable:choices (magit--git-variable) + ((choices :initarg :choices) + (fallback :initarg :fallback :initform nil) + (default :initarg :default :initform nil))) + +(defclass magit--git-variable:urls (magit--git-variable) + ((seturl-arg :initarg :seturl-arg :initform nil))) + +;;; Methods +;;;; Init + +(cl-defmethod transient-init-scope ((obj magit--git-variable)) + (oset obj scope + (cond (transient--prefix + (oref transient--prefix scope)) + ((slot-boundp obj 'scope) + (funcall (oref obj scope) obj))))) + +(cl-defmethod transient-init-value ((obj magit--git-variable)) + (let ((variable (format (oref obj variable) + (oref obj scope)))) + (oset obj variable variable) + (oset obj value + (cond ((oref obj multi-value) + (magit-get-all variable)) + (t + (magit-git-string "config" "--local" variable)))))) + +;;;; Read + +(cl-defmethod transient-infix-read :around ((obj magit--git-variable:urls)) + (mapcar (lambda (url) + (if (string-prefix-p "~" url) + (expand-file-name url) + url)) + (cl-call-next-method obj))) + +(cl-defmethod transient-infix-read ((obj magit--git-variable:choices)) + (let ((choices (oref obj choices))) + (when (functionp choices) + (setq choices (funcall choices))) + (if-let ((value (oref obj value))) + (cadr (member value choices)) + (car choices)))) + +;;;; Readers + +(defun magit-transient-read-person (prompt initial-input history) + (magit-completing-read + prompt + (mapcar (lambda (line) + (save-excursion + (and (string-match "\\`[\s\t]+[0-9]+\t" line) + (list (substring line (match-end 0)))))) + (magit-git-lines "shortlog" "-n" "-s" "-e" "HEAD")) + nil nil initial-input history)) + +(defun magit-transient-read-revision (prompt initial-input history) + (or (magit-completing-read prompt (cons "HEAD" (magit-list-refnames)) + nil nil initial-input history + (or (magit-branch-or-commit-at-point) + (magit-get-current-branch))) + (user-error "Nothing selected"))) + +;;;; Set + +(cl-defmethod transient-infix-set ((obj magit--git-variable) value) + (let ((variable (oref obj variable))) + (oset obj value value) + (if (oref obj multi-value) + (magit-set-all value variable) + (magit-set value variable)) + (magit-refresh) + (unless (or value transient--prefix) + (message "Unset %s" variable)))) + +(cl-defmethod transient-infix-set ((obj magit--git-variable:urls) values) + (let ((previous (oref obj value)) + (seturl (oref obj seturl-arg)) + (remote (oref transient--prefix scope))) + (oset obj value values) + (dolist (v (-difference values previous)) + (magit-call-git "remote" "set-url" seturl "--add" remote v)) + (dolist (v (-difference previous values)) + (magit-call-git "remote" "set-url" seturl "--delete" remote + (concat "^" (regexp-quote v) "$"))) + (magit-refresh))) + +;;;; Draw + +(cl-defmethod transient-format-description ((obj magit--git-variable)) + (or (oref obj description) + (oref obj variable))) + +(cl-defmethod transient-format-value ((obj magit--git-variable)) + (if-let ((value (oref obj value))) + (if (oref obj multi-value) + (if (cdr value) + (mapconcat (lambda (v) + (concat "\n " + (propertize v 'face 'transient-value))) + value "") + (propertize (car value) 'face 'transient-value)) + (propertize (car (split-string value "\n")) + 'face 'transient-value)) + (propertize "unset" 'face 'transient-inactive-value))) + +(cl-defmethod transient-format-value ((obj magit--git-variable:choices)) + (let* ((variable (oref obj variable)) + (choices (oref obj choices)) + (local (magit-git-string "config" "--local" variable)) + (global (magit-git-string "config" "--global" variable)) + (default (oref obj default)) + (fallback (oref obj fallback)) + (fallback (and fallback + (when-let ((val (magit-get fallback))) + (concat fallback ":" val))))) + (when (functionp choices) + (setq choices (funcall choices))) + (concat + (propertize "[" 'face 'transient-inactive-value) + (mapconcat (lambda (choice) + (propertize choice 'face (if (equal choice local) + (if (member choice choices) + 'transient-value + 'font-lock-warning-face) + 'transient-inactive-value))) + (if (and local (not (member local choices))) + (cons local choices) + choices) + (propertize "|" 'face 'transient-inactive-value)) + (and (or global fallback default) + (concat + (propertize "|" 'face 'transient-inactive-value) + (cond (global + (propertize (concat "global:" global) + 'face (cond (local + 'transient-inactive-value) + ((member global choices) + 'transient-value) + (t + 'font-lock-warning-face)))) + (fallback + (propertize fallback + 'face (if local + 'transient-inactive-value + 'transient-value))) + (default + (propertize (concat "default:" default) + 'face (if local + 'transient-inactive-value + 'transient-value)))))) + (propertize "]" 'face 'transient-inactive-value)))) + +;;; _ +(provide 'magit-transient) +;;; magit-transient.el ends here + diff --git a/elpa/magit-20200318.1224/magit-transient.elc b/elpa/magit-20200318.1224/magit-transient.elc new file mode 100644 index 00000000..29254b5f Binary files /dev/null and b/elpa/magit-20200318.1224/magit-transient.elc differ diff --git a/elpa/magit-20200318.1224/magit-utils.el b/elpa/magit-20200318.1224/magit-utils.el new file mode 100644 index 00000000..613d0e2a --- /dev/null +++ b/elpa/magit-20200318.1224/magit-utils.el @@ -0,0 +1,1195 @@ +;;; magit-utils.el --- various utilities -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Contains code from GNU Emacs https://www.gnu.org/software/emacs, +;; released under the GNU General Public License version 3 or later. + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library defines several utility functions used by several +;; other libraries which cannot depend on one another (because +;; circular dependencies are not good). Luckily most (all) of these +;; functions have very little (nothing) to do with Git, so we not only +;; have to do this, it even makes sense. + +;; Unfortunately there are also some options which are used by several +;; libraries which cannot depend on one another, they are defined here +;; too. + +;;; Code: + +(require 'cl-lib) +(require 'dash) + +(eval-when-compile + (require 'subr-x)) + +(require 'crm) + +(eval-when-compile (require 'ido)) +(declare-function ido-completing-read+ "ido-completing-read+" + (prompt collection &optional predicate + require-match initial-input + hist def inherit-input-method)) +(declare-function Info-get-token "info" (pos start all &optional errorstring)) + +(eval-when-compile (require 'vc-git)) +(declare-function vc-git--run-command-string "vc-git" (file &rest args)) + +(eval-when-compile (require 'which-func)) +(declare-function which-function "which-func" ()) + +(defvar magit-wip-before-change-mode) + +;;; Options + +(defcustom magit-completing-read-function 'magit-builtin-completing-read + "Function to be called when requesting input from the user. + +If you have enabled `ivy-mode' or `helm-mode', then you don't +have to customize this option; `magit-builtin-completing-read' +will work just fine. However, if you use Ido completion, then +you do have to use `magit-ido-completing-read', because Ido is +less well behaved than the former, more modern alternatives. + +If you would like to use Ivy or Helm completion with Magit but +not enable the respective modes globally, then customize this +option to use `ivy-completing-read' or +`helm--completing-read-default'. If you choose to use +`ivy-completing-read', note that the items may always be shown in +alphabetical order, depending on your version of Ivy." + :group 'magit-essentials + :type '(radio (function-item magit-builtin-completing-read) + (function-item magit-ido-completing-read) + (function-item ivy-completing-read) + (function-item helm--completing-read-default) + (function :tag "Other function"))) + +(defcustom magit-dwim-selection + '((magit-stash-apply nil t) + (magit-stash-branch nil t) + (magit-stash-branch-here nil t) + (magit-stash-format-patch nil t) + (magit-stash-drop nil ask) + (magit-stash-pop nil ask) + (forge-browse-dwim nil t) + (forge-browse-commit nil t) + (forge-browse-branch nil t) + (forge-browse-remote nil t) + (forge-browse-issue nil t) + (forge-browse-pullreq nil t) + (forge-edit-topic-title nil t) + (forge-edit-topic-state nil t) + (forge-edit-topic-labels nil t) + (forge-edit-topic-marks nil t) + (forge-edit-topic-assignees nil t) + (forge-edit-topic-review-requests nil t) + (forge-pull-pullreq nil t) + (forge-visit-issue nil t) + (forge-visit-pullreq nil t)) + "When not to offer alternatives and ask for confirmation. + +Many commands by default ask the user to select from a list of +possible candidates. They do so even when there is a thing at +point that they can act on, which is then offered as the default. + +This option can be used to tell certain commands to use the thing +at point instead of asking the user to select a candidate to act +on, with or without confirmation. + +The value has the form ((COMMAND nil|PROMPT DEFAULT)...). + +- COMMAND is the command that should not prompt for a choice. + To have an effect, the command has to use the function + `magit-completing-read' or a utility function which in turn uses + that function. + +- If the command uses `magit-completing-read' multiple times, then + PROMPT can be used to only affect one of these uses. PROMPT, if + non-nil, is a regular expression that is used to match against + the PROMPT argument passed to `magit-completing-read'. + +- DEFAULT specifies how to use the default. If it is t, then + the DEFAULT argument passed to `magit-completing-read' is used + without confirmation. If it is `ask', then the user is given + a chance to abort. DEFAULT can also be nil, in which case the + entry has no effect." + :package-version '(magit . "2.12.0") + :group 'magit-commands + :type '(repeat + (list (symbol :tag "Command") ; It might not be fboundp yet. + (choice (const :tag "for all prompts" nil) + (regexp :tag "for prompts matching regexp")) + (choice (const :tag "offer other choices" nil) + (const :tag "require confirmation" ask) + (const :tag "use default without confirmation" t))))) + +(defconst magit--confirm-actions + '((const reverse) (const discard) + (const rename) (const resurrect) + (const untrack) (const trash) + (const delete) (const abort-rebase) + (const abort-merge) (const merge-dirty) + (const drop-stashes) (const reset-bisect) + (const kill-process) (const delete-unmerged-branch) + (const delete-pr-branch) (const remove-modules) + (const stage-all-changes) (const unstage-all-changes) + (const safe-with-wip))) + +(defcustom magit-no-confirm nil + "A list of symbols for actions Magit should not confirm, or t. + +Many potentially dangerous commands by default ask the user for +confirmation. Each of the below symbols stands for an action +which, when invoked unintentionally or without being fully aware +of the consequences, could lead to tears. In many cases there +are several commands that perform variations of a certain action, +so we don't use the command names but more generic symbols. + +Applying changes: + + `discard' Discarding one or more changes (i.e. hunks or the + complete diff for a file) loses that change, obviously. + + `reverse' Reverting one or more changes can usually be undone + by reverting the reversion. + + `stage-all-changes', `unstage-all-changes' When there are both + staged and unstaged changes, then un-/staging everything would + destroy that distinction. Of course that also applies when + un-/staging a single change, but then less is lost and one does + that so often that having to confirm every time would be + unacceptable. + +Files: + + `delete' When a file that isn't yet tracked by Git is deleted + then it is completely lost, not just the last changes. Very + dangerous. + + `trash' Instead of deleting a file it can also be move to the + system trash. Obviously much less dangerous than deleting it. + + Also see option `magit-delete-by-moving-to-trash'. + + `resurrect' A deleted file can easily be resurrected by + \"deleting\" the deletion, which is done using the same command + that was used to delete the same file in the first place. + + `untrack' Untracking a file can be undone by tracking it again. + + `rename' Renaming a file can easily be undone. + +Sequences: + + `reset-bisect' Aborting (known to Git as \"resetting\") a + bisect operation loses all information collected so far. + + `abort-rebase' Aborting a rebase throws away all already + modified commits, but it's possible to restore those from the + reflog. + + `abort-merge' Aborting a merge throws away all conflict + resolutions which has already been carried out by the user. + + `merge-dirty' Merging with a dirty worktree can make it hard to + go back to the state before the merge was initiated. + +References: + + `delete-unmerged-branch' Once a branch has been deleted it can + only be restored using low-level recovery tools provided by + Git. And even then the reflog is gone. The user always has + to confirm the deletion of a branch by accepting the default + choice (or selecting another branch), but when a branch has + not been merged yet, also make sure the user is aware of that. + + `delete-pr-remote' When deleting a branch that was created from + a pull-request and if no other branches still exist on that + remote, then `magit-branch-delete' offers to delete the remote + as well. This should be safe because it only happens if no + other refs exist in the remotes namespace, and you can recreate + the remote if necessary. + + `drop-stashes' Dropping a stash is dangerous because Git stores + stashes in the reflog. Once a stash is removed, there is no + going back without using low-level recovery tools provided by + Git. When a single stash is dropped, then the user always has + to confirm by accepting the default (or selecting another). + This action only concerns the deletion of multiple stashes at + once. + +Edit published history: + + Without adding these symbols here, you will be warned before + editing commits that have already been pushed to one of the + branches listed in `magit-published-branches'. + + `amend-published' Affects most commands that amend to \"HEAD\". + + `rebase-published' Affects commands that perform interactive + rebases. This includes commands from the commit popup that + modify a commit other than \"HEAD\", namely the various fixup + and squash variants. + + `edit-published' Affects the commands `magit-edit-line-commit' + and `magit-diff-edit-hunk-commit'. These two commands make + it quite easy to accidentally edit a published commit, so you + should think twice before configuring them not to ask for + confirmation. + + To disable confirmation completely, add all three symbols here + or set `magit-published-branches' to nil. + +Removing modules: + + `remove-modules' When you remove the working directory of a + module that does not contain uncommitted changes, then that is + safer than doing so when there are uncommitted changes and/or + when you also remove the gitdir. Still, you don't want to do + that by accident. + + `remove-dirty-modules' When you remove the working directory of + a module that contains uncommitted changes, then those changes + are gone for good. It is better to go to the module, inspect + these changes and only if appropriate discard them manually. + + `trash-module-gitdirs' When you remove the gitdir of a module, + then all unpushed changes are gone for good. It is very easy + to forget that you have some unfinished work on an unpublished + feature branch or even in a stash. + + Actually there are some safety precautions in place, that might + help you out if you make an unwise choice here, but don't count + on it. In case of emergency, stay calm and check the stash and + the `trash-directory' for traces of lost work. + +Various: + + `kill-process' There seldom is a reason to kill a process. + +Global settings: + + Instead of adding all of the above symbols to the value of this + option you can also set it to the atom `t', which has the same + effect as adding all of the above symbols. Doing that most + certainly is a bad idea, especially because other symbols might + be added in the future. So even if you don't want to be asked + for confirmation for any of these actions, you are still better + of adding all of the respective symbols individually. + + When `magit-wip-before-change-mode' is enabled then these actions + can fairly easily be undone: `discard', `reverse', + `stage-all-changes', and `unstage-all-changes'. If and only if + this mode is enabled, then `safe-with-wip' has the same effect + as adding all of these symbols individually." + :package-version '(magit . "2.1.0") + :group 'magit-essentials + :group 'magit-commands + :type `(choice (const :tag "Always require confirmation" nil) + (const :tag "Never require confirmation" t) + (set :tag "Require confirmation except for" + ;; `remove-dirty-modules' and + ;; `trash-module-gitdirs' intentionally + ;; omitted. + ,@magit--confirm-actions))) + +(defcustom magit-slow-confirm '(drop-stashes) + "Whether to ask user \"y or n\" or \"yes or no\" questions. + +When this is nil, then `y-or-n-p' is used when the user has to +confirm a potentially destructive action. When this is t, then +`yes-or-no-p' is used instead. If this is a list of symbols +identifying actions, then `yes-or-no-p' is used for those, +`y-or-no-p' for all others. The list of actions is the same as +for `magit-no-confirm' (which see)." + :package-version '(magit . "2.9.0") + :group 'magit-miscellaneous + :type `(choice (const :tag "Always ask \"yes or no\" questions" t) + (const :tag "Always ask \"y or n\" questions" nil) + (set :tag "Ask \"yes or no\" questions only for" + ,@magit--confirm-actions))) + +(defcustom magit-no-message nil + "A list of messages Magit should not display. + +Magit displays most echo area messages using `message', but a few +are displayed using `magit-message' instead, which takes the same +arguments as the former, FORMAT-STRING and ARGS. `magit-message' +forgoes printing a message if any member of this list is a prefix +of the respective FORMAT-STRING. + +If Magit prints a message which causes you grief, then please +first investigate whether there is another option which can be +used to suppress it. If that is not the case, then ask the Magit +maintainers to start using `magit-message' instead of `message' +in that case. We are not proactively replacing all uses of +`message' with `magit-message', just in case someone *might* find +some of these messages useless. + +Messages which can currently be suppressed using this option are: +* \"Turning on magit-auto-revert-mode...\"" + :package-version '(magit . "2.8.0") + :group 'magit-miscellaneous + :type '(repeat string)) + +(defcustom magit-ellipsis ?… + "Character used to abbreviate text. + +Currently this is used to abbreviate author names in the margin +and in process buffers to elide `magit-git-global-arguments'." + :package-version '(magit . "2.1.0") + :group 'magit-miscellaneous + :type 'character) + +(defcustom magit-update-other-window-delay 0.2 + "Delay before automatically updating the other window. + +When moving around in certain buffers, then certain other +buffers, which are being displayed in another window, may +optionally be updated to display information about the +section at point. + +When holding down a key to move by more than just one section, +then that would update that buffer for each section on the way. +To prevent that, updating the revision buffer is delayed, and +this option controls for how long. For optimal experience you +might have to adjust this delay and/or the keyboard repeat rate +and delay of your graphical environment or operating system." + :package-version '(magit . "2.3.0") + :group 'magit-miscellaneous + :type 'number) + +(defcustom magit-view-git-manual-method 'info + "How links to Git documentation are followed from Magit's Info manuals. + +`info' Follow the link to the node in the `gitman' Info manual + as usual. Unfortunately that manual is not installed by + default on some platforms, and when it is then the nodes + look worse than the actual manpages. + +`man' View the respective man-page using the `man' package. + +`woman' View the respective man-page using the `woman' package." + :package-version '(magit . "2.9.0") + :group 'magit-miscellaneous + :type '(choice (const :tag "view info manual" info) + (const :tag "view manpage using `man'" man) + (const :tag "view manpage using `woman'" woman))) + +;;; User Input + +(defvar helm-completion-in-region-default-sort-fn) +(defvar ivy-sort-functions-alist) + +(defvar magit-completing-read--silent-default nil) + +(defun magit-completing-read (prompt collection &optional + predicate require-match initial-input + hist def fallback) + "Read a choice in the minibuffer, or use the default choice. + +This is the function that Magit commands use when they need the +user to select a single thing to act on. The arguments have the +same meaning as for `completing-read', except for FALLBACK, which +is unique to this function and is described below. + +Instead of asking the user to choose from a list of possible +candidates, this function may instead just return the default +specified by DEF, with or without requiring user confirmation. +Whether that is the case depends on PROMPT, `this-command' and +`magit-dwim-selection'. See the documentation of the latter for +more information. + +If it does use the default without the user even having to +confirm that, then `magit-completing-read--silent-default' is set +to t, otherwise nil. + +If it does read a value in the minibuffer, then this function +acts similarly to `completing-read', except for the following: + +- COLLECTION must be a list of choices. A function is not + supported. + +- If REQUIRE-MATCH is nil and the user exits without a choice, + then nil is returned instead of an empty string. + +- If REQUIRE-MATCH is non-nil and the user exits without a + choice, `user-error' is raised. + +- FALLBACK specifies a secondary default that is only used if + the primary default DEF is nil. The secondary default is not + subject to `magit-dwim-selection' — if DEF is nil but FALLBACK + is not, then this function always asks the user to choose a + candidate, just as if both defaults were nil. + +- \": \" is appended to PROMPT. + +- PROMPT is modified to end with \" (default DEF|FALLBACK): \" + provided that DEF or FALLBACK is non-nil, that neither + `ivy-mode' nor `helm-mode' is enabled, and that + `magit-completing-read-function' is set to its default value of + `magit-builtin-completing-read'." + (setq magit-completing-read--silent-default nil) + (if-let ((dwim (and def + (nth 2 (-first (pcase-lambda (`(,cmd ,re ,_)) + (and (eq this-command cmd) + (or (not re) + (string-match-p re prompt)))) + magit-dwim-selection))))) + (if (eq dwim 'ask) + (if (y-or-n-p (format "%s %s? " prompt def)) + def + (user-error "Abort")) + (setq magit-completing-read--silent-default t) + def) + (unless def + (setq def fallback)) + (let ((command this-command) + (reply (funcall magit-completing-read-function + (concat prompt ": ") + (if (and def (not (member def collection))) + (cons def collection) + collection) + predicate + require-match initial-input hist def))) + (setq this-command command) + (if (string= reply "") + (if require-match + (user-error "Nothing selected") + nil) + reply)))) + +(defun magit--completion-table (collection) + (lambda (string pred action) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity)) + (complete-with-action action collection string pred)))) + +(defun magit-builtin-completing-read + (prompt choices &optional predicate require-match initial-input hist def) + "Magit wrapper for standard `completing-read' function." + (unless (or (bound-and-true-p helm-mode) + (bound-and-true-p ivy-mode)) + (setq prompt (magit-prompt-with-default prompt def)) + (setq choices (magit--completion-table choices))) + (cl-letf (((symbol-function 'completion-pcm--all-completions) + #'magit-completion-pcm--all-completions)) + (let ((ivy-sort-functions-alist nil)) + (completing-read prompt choices + predicate require-match + initial-input hist def)))) + +(defun magit-completing-read-multiple + (prompt choices &optional sep default hist keymap) + "Read multiple items from CHOICES, separated by SEP. + +Set up the `crm' variables needed to read multiple values with +`read-from-minibuffer'. + +SEP is a regexp matching characters that can separate choices. +When SEP is nil, it defaults to `crm-default-separator'. +DEFAULT, HIST, and KEYMAP are passed to `read-from-minibuffer'. +When KEYMAP is nil, it defaults to `crm-local-completion-map'. + +Unlike `completing-read-multiple', the return value is not split +into a list." + (let* ((crm-separator (or sep crm-default-separator)) + (crm-completion-table (magit--completion-table choices)) + (choose-completion-string-functions + '(crm--choose-completion-string)) + (minibuffer-completion-table #'crm--collection-fn) + (minibuffer-completion-confirm t) + (helm-completion-in-region-default-sort-fn nil) + (input + (cl-letf (((symbol-function 'completion-pcm--all-completions) + #'magit-completion-pcm--all-completions)) + (read-from-minibuffer + (concat prompt (and default (format " (%s)" default)) ": ") + nil (or keymap crm-local-completion-map) + nil hist default)))) + (when (string-equal input "") + (or (setq input default) + (user-error "Nothing selected"))) + input)) + +(defun magit-completing-read-multiple* + (prompt table &optional predicate require-match initial-input + hist def inherit-input-method) + "Read multiple strings in the minibuffer, with completion. +Like `completing-read-multiple' but don't mess with order of +TABLE. Also bind `helm-completion-in-region-default-sort-fn' +to nil." + (unwind-protect + (cl-letf (((symbol-function 'completion-pcm--all-completions) + #'magit-completion-pcm--all-completions)) + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string) + (let* ((minibuffer-completion-table #'crm--collection-fn) + (minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (crm-completion-table (magit--completion-table table)) + (map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + (helm-completion-in-region-default-sort-fn nil) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + (and def (string-equal input "") (setq input def)) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) + (remove-hook 'choose-completion-string-functions + 'crm--choose-completion-string))) + +(defun magit-ido-completing-read + (prompt choices &optional predicate require-match initial-input hist def) + "Ido-based `completing-read' almost-replacement. + +Unfortunately `ido-completing-read' is not suitable as a +drop-in replacement for `completing-read', instead we use +`ido-completing-read+' from the third-party package by the +same name." + (if (require 'ido-completing-read+ nil t) + (ido-completing-read+ prompt choices predicate require-match + initial-input hist + (or def (and require-match (car choices)))) + (display-warning 'magit "ido-completing-read+ is not installed + +To use Ido completion with Magit you need to install the +third-party `ido-completing-read+' packages. Falling +back to built-in `completing-read' for now." :error) + (magit-builtin-completing-read prompt choices predicate require-match + initial-input hist def))) + +(defun magit-prompt-with-default (prompt def) + (if (and def (> (length prompt) 2) + (string-equal ": " (substring prompt -2))) + (format "%s (default %s): " (substring prompt 0 -2) def) + prompt)) + +(defvar magit-minibuffer-local-ns-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\s" 'magit-whitespace-disallowed) + (define-key map "\t" 'magit-whitespace-disallowed) + map)) + +(defun magit-whitespace-disallowed () + "Beep to tell the user that whitespace is not allowed." + (interactive) + (ding) + (message "Whitespace isn't allowed here") + (setq defining-kbd-macro nil) + (force-mode-line-update)) + +(defun magit-read-string (prompt &optional initial-input history default-value + inherit-input-method no-whitespace) + "Read a string from the minibuffer, prompting with string PROMPT. + +This is similar to `read-string', but +* empty input is only allowed if DEFAULT-VALUE is non-nil in + which case that is returned, +* whitespace is not allowed and leading and trailing whitespace is + removed automatically if NO-WHITESPACE is non-nil, +* \": \" is appended to PROMPT, and +* an invalid DEFAULT-VALUE is silently ignored." + (when default-value + (when (consp default-value) + (setq default-value (car default-value))) + (unless (stringp default-value) + (setq default-value nil))) + (let* ((minibuffer-completion-table nil) + (val (read-from-minibuffer + (magit-prompt-with-default (concat prompt ": ") default-value) + initial-input (and no-whitespace magit-minibuffer-local-ns-map) + nil history default-value inherit-input-method)) + (trim (lambda (regexp string) + (save-match-data + (if (string-match regexp string) + (replace-match "" t t string) + string))))) + (when (and (string= val "") default-value) + (setq val default-value)) + (when no-whitespace + (setq val (funcall trim "\\`\\(?:[ \t\n\r]+\\)" + (funcall trim "\\(?:[ \t\n\r]+\\)\\'" val)))) + (cond ((string= val "") + (user-error "Need non-empty input")) + ((and no-whitespace (string-match-p "[\s\t\n]" val)) + (user-error "Input contains whitespace")) + (t val)))) + +(defun magit-read-string-ns (prompt &optional initial-input history + default-value inherit-input-method) + "Call `magit-read-string' with non-nil NO-WHITESPACE." + (magit-read-string prompt initial-input history default-value + inherit-input-method t)) + +(defmacro magit-read-char-case (prompt verbose &rest clauses) + (declare (indent 2) + (debug (form form &rest (characterp form body)))) + `(prog1 (pcase (read-char-choice + (concat ,prompt + ,(concat (mapconcat 'cadr clauses ", ") + (and verbose ", or [C-g] to abort") " ")) + ',(mapcar 'car clauses)) + ,@(--map `(,(car it) ,@(cddr it)) clauses)) + (message ""))) + +(defun magit-y-or-n-p (prompt &optional action) + "Ask user a \"y or n\" or a \"yes or no\" question using PROMPT. +Which kind of question is used depends on whether +ACTION is a member of option `magit-slow-confirm'." + (if (or (eq magit-slow-confirm t) + (and action (member action magit-slow-confirm))) + (yes-or-no-p prompt) + (y-or-n-p prompt))) + +(defvar magit--no-confirm-alist + '((safe-with-wip magit-wip-before-change-mode + discard reverse stage-all-changes unstage-all-changes))) + +(cl-defun magit-confirm (action &optional prompt prompt-n noabort + (items nil sitems)) + (declare (indent defun)) + (setq prompt-n (format (concat (or prompt-n prompt) "? ") (length items))) + (setq prompt (format (concat (or prompt (magit-confirm-make-prompt action)) + "? ") + (car items))) + (or (cond ((and (not (eq action t)) + (or (eq magit-no-confirm t) + (memq action magit-no-confirm) + (cl-member-if (pcase-lambda (`(,key ,var . ,sub)) + (and (memq key magit-no-confirm) + (memq action sub) + (or (not var) + (and (boundp var) + (symbol-value var))))) + magit--no-confirm-alist))) + (or (not sitems) items)) + ((not sitems) + (magit-y-or-n-p prompt action)) + ((= (length items) 1) + (and (magit-y-or-n-p prompt action) items)) + ((> (length items) 1) + (and (magit-y-or-n-p (concat (mapconcat #'identity items "\n") + "\n\n" prompt-n) + action) + items))) + (if noabort nil (user-error "Abort")))) + +(defun magit-confirm-files (action files &optional prompt) + (when files + (unless prompt + (setq prompt (magit-confirm-make-prompt action))) + (magit-confirm action + (concat prompt " %s") + (concat prompt " %i files") + nil files))) + +(defun magit-confirm-make-prompt (action) + (let ((prompt (symbol-name action))) + (replace-regexp-in-string + "-" " " (concat (upcase (substring prompt 0 1)) (substring prompt 1))))) + +(defun magit-read-number-string (prompt &optional default _history) + "Like `read-number' but return value is a string. +DEFAULT may be a number or a numeric string." + (number-to-string + (read-number prompt (if (stringp default) + (string-to-number default) + default)))) + +;;; Debug Utilities + +;;;###autoload +(defun magit-emacs-Q-command () + "Show a shell command that runs an uncustomized Emacs with only Magit loaded. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (let ((cmd (mapconcat + #'shell-quote-argument + `(,(concat invocation-directory invocation-name) + "-Q" "--eval" "(setq debug-on-error t)" + ,@(cl-mapcan + (lambda (dir) (list "-L" dir)) + (delete-dups + (cl-mapcan + (lambda (lib) + (let ((path (locate-library lib))) + (cond + (path + (list (file-name-directory path))) + ((not (equal lib "libgit")) + (error "Cannot find mandatory dependency %s" lib))))) + '(;; Like `LOAD_PATH' in `default.mk'. + "dash" + "libgit" + "transient" + "with-editor" + ;; Obviously `magit' itself is needed too. + "magit" + ;; While this is part of the Magit repository, + ;; it is distributed as a separate package. + "git-commit" + ;; Even though `async' is a dependency of the + ;; `magit' package, it is not required here. + )))) + ;; Avoid Emacs bug#16406 by using full path. + "-l" ,(file-name-sans-extension (locate-library "magit"))) + " "))) + (message "Uncustomized Magit command saved to kill-ring, %s" + "please run it in a terminal.") + (kill-new cmd))) + +;;; Text Utilities + +(defmacro magit-bind-match-strings (varlist string &rest body) + "Bind variables to submatches according to VARLIST then evaluate BODY. +Bind the symbols in VARLIST to submatches of the current match +data, starting with 1 and incrementing by 1 for each symbol. If +the last match was against a string, then that has to be provided +as STRING." + (declare (indent 2) (debug (listp form body))) + (let ((s (cl-gensym "string")) + (i 0)) + `(let ((,s ,string)) + (let ,(save-match-data + (--map (list it (list 'match-string (cl-incf i) s)) varlist)) + ,@body)))) + +(defun magit-delete-line () + "Delete the rest of the current line." + (delete-region (point) (1+ (line-end-position)))) + +(defun magit-delete-match (&optional num) + "Delete text matched by last search. +If optional NUM is specified, only delete that subexpression." + (delete-region (match-beginning (or num 0)) + (match-end (or num 0)))) + +(defun magit-file-line (file) + "Return the first line of FILE as a string." + (when (file-regular-p file) + (with-temp-buffer + (insert-file-contents file) + (buffer-substring-no-properties (point-min) + (line-end-position))))) + +(defun magit-file-lines (file &optional keep-empty-lines) + "Return a list of strings containing one element per line in FILE. +Unless optional argument KEEP-EMPTY-LINES is t, trim all empty lines." + (when (file-regular-p file) + (with-temp-buffer + (insert-file-contents file) + (split-string (buffer-string) "\n" (not keep-empty-lines))))) + +(defun magit-set-header-line-format (string) + "Set the header-line using STRING. +Propertize STRING with the `magit-header-line'. If the `face' +property of any part of STRING is already set, then that takes +precedence. Also pad the left and right sides of STRING so that +it aligns with the text area." + (setq header-line-format + (concat + (propertize " " 'display '(space :align-to 0)) + string + (propertize " " 'display + `(space :width + (+ left-fringe + left-margin + ,@(and (eq (car (window-current-scroll-bars)) + 'left) + '(scroll-bar))))))) + (magit--add-face-text-property 0 (1- (length header-line-format)) + 'magit-header-line t header-line-format)) + +(defun magit-face-property-all (face string) + "Return non-nil if FACE is present in all of STRING." + (cl-loop for pos = 0 then (next-single-property-change + pos 'font-lock-face string) + unless pos + return t + for current = (get-text-property pos 'font-lock-face string) + unless (if (consp current) + (memq face current) + (eq face current)) + return nil)) + +(defun magit--add-face-text-property (beg end face &optional append object) + "Like `add-face-text-property' but for `font-lock-face'." + (cl-loop for pos = (next-single-property-change + beg 'font-lock-face object end) + for current = (get-text-property beg 'font-lock-face object) + for newface = (if (listp current) + (if append + (append current (list face)) + (cons face current)) + (if append + (list current face) + (list face current))) + do (progn (put-text-property beg pos 'font-lock-face newface object) + (setq beg pos)) + while (< beg end))) + +(defun magit--propertize-face (string face) + (propertize string 'face face 'font-lock-face face)) + +(defun magit--put-face (beg end face string) + (put-text-property beg end 'face face string) + (put-text-property beg end 'font-lock-face face string)) + +(defun magit--format-spec (format specification) + "Like `format-spec' but preserve text properties in SPECIFICATION." + (with-temp-buffer + (insert format) + (goto-char (point-min)) + (while (search-forward "%" nil t) + (cond + ;; Quoted percent sign. + ((eq (char-after) ?%) + (delete-char 1)) + ;; Valid format spec. + ((looking-at "\\([-0-9.]*\\)\\([a-zA-Z]\\)") + (let* ((num (match-string 1)) + (spec (string-to-char (match-string 2))) + (val (assq spec specification))) + (unless val + (error "Invalid format character: `%%%c'" spec)) + (setq val (cdr val)) + ;; Pad result to desired length. + (let ((text (format (concat "%" num "s") val))) + ;; Insert first, to preserve text properties. + (if (next-property-change 0 (concat " " text)) + ;; If the inserted text has properties, then preserve those. + (insert text) + ;; Otherwise preserve FORMAT's properties, like `format-spec'. + (insert-and-inherit text)) + ;; Delete the specifier body. + (delete-region (+ (match-beginning 0) (length text)) + (+ (match-end 0) (length text))) + ;; Delete the percent sign. + (delete-region (1- (match-beginning 0)) (match-beginning 0))))) + ;; Signal an error on bogus format strings. + (t + (error "Invalid format string")))) + (buffer-string))) + +;;; Missing from Emacs + +(defun magit-kill-this-buffer () + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun magit--buffer-string (&optional min max trim) + "Like `buffer-substring-no-properties' but the arguments are optional. + +This combines the benefits of `buffer-string', `buffer-substring' +and `buffer-substring-no-properties' into one function that is +not as painful to use as the latter. I.e. you can write + (magit--buffer-string) +instead of + (buffer-substring-no-properties (point-min) + (point-max)) + +Optional MIN defaults to the value of `point-min'. +Optional MAX defaults to the value of `point-max'. + +If optional TRIM is non-nil, then all leading and trailing +whitespace is remove. If it is the newline character, then +one trailing newline is added." + ;; Lets write that one last time and be done with it: + (let ((str (buffer-substring-no-properties (or min (point-min)) + (or max (point-max))))) + (if trim + (concat (string-trim str) + (and (eq trim ?\n) "\n")) + str))) + +;;; Kludges for Emacs Bugs + +(defun magit-file-accessible-directory-p (filename) + "Like `file-accessible-directory-p' but work around an Apple bug. +See http://debbugs.gnu.org/cgi/bugreport.cgi?bug=21573#17 +and https://github.com/magit/magit/issues/2295." + (and (file-directory-p filename) + (file-accessible-directory-p filename))) + +(when (version<= "25.1" emacs-version) + (with-eval-after-load 'vc-git + (defun vc-git-conflicted-files (directory) + "Return the list of files with conflicts in DIRECTORY." + (let* ((status + (vc-git--run-command-string directory "diff-files" + "--name-status")) + (lines (when status (split-string status "\n" 'omit-nulls))) + files) + (dolist (line lines files) + (when (string-match "\\([ MADRCU?!]\\)[ \t]+\\(.+\\)" line) + (let ((state (match-string 1 line)) + (file (match-string 2 line))) + (when (equal state "U") + (push (expand-file-name file directory) files))))))))) + +(when (< emacs-major-version 27) + (defun vc-git--call@bug21559 (fn buffer command &rest args) + "Backport https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21559." + (let ((process-environment process-environment)) + (when revert-buffer-in-progress-p + (push "GIT_OPTIONAL_LOCKS=0" process-environment)) + (apply fn buffer command args))) + (advice-add 'vc-git--call :around 'vc-git--call@bug21559) + + (defun vc-git-command@bug21559 + (fn buffer okstatus file-or-list &rest flags) + "Backport https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21559." + (let ((process-environment process-environment)) + (when revert-buffer-in-progress-p + (push "GIT_OPTIONAL_LOCKS=0" process-environment)) + (apply fn buffer okstatus file-or-list flags))) + (advice-add 'vc-git-command :around 'vc-git-command@bug21559) + + (defun auto-revert-handler@bug21559 (fn) + "Backport https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21559." + (let ((revert-buffer-in-progress-p t)) + (funcall fn))) + (advice-add 'auto-revert-handler :around 'auto-revert-handler@bug21559) + ) + +;; `completion-pcm--all-completions' reverses the completion list. To +;; preserve the order of our pre-sorted completions, we'll temporarily +;; override it with the function below. bug#24676 +(defun magit-completion-pcm--all-completions (prefix pattern table pred) + (if (completion-pcm--pattern-trivial-p pattern) + (all-completions (concat prefix (car pattern)) table pred) + (let* ((regex (completion-pcm--pattern->regex pattern)) + (case-fold-search completion-ignore-case) + (completion-regexp-list (cons regex completion-regexp-list)) + (compl (all-completions + (concat prefix + (if (stringp (car pattern)) (car pattern) "")) + table pred))) + (if (not (functionp table)) + compl + (let ((poss ())) + (dolist (c compl) + (when (string-match-p regex c) (push c poss))) + ;; This `nreverse' call is the only code change made to the + ;; `completion-pcm--all-completions' that shipped with Emacs 25.1. + (nreverse poss)))))) + +(defun magit-which-function () + "Return current function name based on point. + +This is a simple wrapper around `which-function', that resets +Imenu's potentially outdated and therefore unreliable cache by +setting `imenu--index-alist' to nil before calling that function." + (setq imenu--index-alist nil) + (which-function)) + +;;; Kludges for Custom + +(defun magit-custom-initialize-reset (symbol exp) + "Initialize SYMBOL based on EXP. +Set the symbol, using `set-default' (unlike +`custom-initialize-reset' which uses the `:set' function if any.) +The value is either the symbol's current value + (as obtained using the `:get' function), if any, +or the value in the symbol's `saved-value' property if any, +or (last of all) the value of EXP." + (set-default-toplevel-value + symbol + (condition-case nil + (let ((def (default-toplevel-value symbol)) + (getter (get symbol 'custom-get))) + (if getter (funcall getter symbol) def)) + (error + (eval (let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp))))))) + +(defun magit-hook-custom-get (symbol) + (if (symbol-file symbol 'defvar) + (default-toplevel-value symbol) + ;; + ;; Called by `custom-initialize-reset' on behalf of `symbol's + ;; `defcustom', which is being evaluated for the first time to + ;; set the initial value, but there's already a default value, + ;; which most likely was established by one or more `add-hook' + ;; calls. + ;; + ;; We combine the `standard-value' and the current value, while + ;; preserving the order established by `:options', and return + ;; the result of that to be used as the "initial" default value. + ;; + (let ((standard (eval (car (get symbol 'standard-value)))) + (current (default-toplevel-value symbol)) + (value nil)) + (dolist (fn (get symbol 'custom-options)) + (when (or (memq fn standard) + (memq fn current)) + (push fn value))) + (dolist (fn current) + (unless (memq fn value) + (push fn value))) + (nreverse value)))) + +;;; Kludges for Info Manuals + +;;;###autoload +(defun Info-follow-nearest-node--magit-gitman (fn &optional fork) + (let ((node (Info-get-token + (point) "\\*note[ \n\t]+" + "\\*note[ \n\t]+\\([^:]*\\):\\(:\\|[ \n\t]*(\\)?"))) + (if (and node (string-match "^(gitman)\\(.+\\)" node)) + (pcase magit-view-git-manual-method + (`info (funcall fn fork)) + (`man (require 'man) + (man (match-string 1 node))) + (`woman (require 'woman) + (woman (match-string 1 node))) + (_ + (user-error "Invalid value for `magit-view-git-manual-method'"))) + (funcall fn fork)))) + +;;;###autoload +(advice-add 'Info-follow-nearest-node :around + 'Info-follow-nearest-node--magit-gitman) + +;;;###autoload +(defun org-man-export--magit-gitman (fn link description format) + (if (and (eq format 'texinfo) + (string-match-p "\\`git" link)) + (replace-regexp-in-string "%s" link " +@ifinfo +@ref{%s,,,gitman,}. +@end ifinfo +@ifhtml +@html +the %s(1) manpage. +@end html +@end ifhtml +@iftex +the %s(1) manpage. +@end iftex +") + (funcall fn link description format))) + +;;;###autoload +(advice-add 'org-man-export :around + 'org-man-export--magit-gitman) + +;;; Bitmaps + +(when (fboundp 'define-fringe-bitmap) + (define-fringe-bitmap 'magit-fringe-bitmap+ + [#b00000000 + #b00011000 + #b00011000 + #b01111110 + #b01111110 + #b00011000 + #b00011000 + #b00000000]) + (define-fringe-bitmap 'magit-fringe-bitmap- + [#b00000000 + #b00000000 + #b00000000 + #b01111110 + #b01111110 + #b00000000 + #b00000000 + #b00000000]) + + (define-fringe-bitmap 'magit-fringe-bitmap> + [#b01100000 + #b00110000 + #b00011000 + #b00001100 + #b00011000 + #b00110000 + #b01100000 + #b00000000]) + (define-fringe-bitmap 'magit-fringe-bitmapv + [#b00000000 + #b10000010 + #b11000110 + #b01101100 + #b00111000 + #b00010000 + #b00000000 + #b00000000]) + + (define-fringe-bitmap 'magit-fringe-bitmap-bold> + [#b11100000 + #b01110000 + #b00111000 + #b00011100 + #b00011100 + #b00111000 + #b01110000 + #b11100000]) + (define-fringe-bitmap 'magit-fringe-bitmap-boldv + [#b10000001 + #b11000011 + #b11100111 + #b01111110 + #b00111100 + #b00011000 + #b00000000 + #b00000000]) + ) + +;;; Miscellaneous + +(defun magit-message (format-string &rest args) + "Display a message at the bottom of the screen, or not. +Like `message', except that if the users configured option +`magit-no-message' to prevent the message corresponding to +FORMAT-STRING to be displayed, then don't." + (unless (--first (string-prefix-p it format-string) magit-no-message) + (apply #'message format-string args))) + +(defun magit-msg (format-string &rest args) + "Display a message at the bottom of the screen, but don't log it. +Like `message', except that `message-log-max' is bound to nil." + (let ((message-log-max nil)) + (apply #'message format-string args))) + +(defmacro magit--with-temp-position (buf pos &rest body) + (declare (indent 2)) + `(with-current-buffer ,buf + (save-excursion + (save-restriction + (widen) + (goto-char ,pos) + ,@body)))) + +;;; _ +(provide 'magit-utils) +;;; magit-utils.el ends here diff --git a/elpa/magit-20200318.1224/magit-utils.elc b/elpa/magit-20200318.1224/magit-utils.elc new file mode 100644 index 00000000..c61c26ec Binary files /dev/null and b/elpa/magit-20200318.1224/magit-utils.elc differ diff --git a/elpa/magit-20200318.1224/magit-wip.el b/elpa/magit-20200318.1224/magit-wip.el new file mode 100644 index 00000000..b24f93cf --- /dev/null +++ b/elpa/magit-20200318.1224/magit-wip.el @@ -0,0 +1,456 @@ +;;; magit-wip.el --- commit snapshots to work-in-progress refs -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library defines tree global modes which automatically commit +;; snapshots to branch-specific work-in-progress refs before and after +;; making changes, and two commands which can be used to do so on +;; demand. + +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'magit-core) +(require 'magit-log) + +;;; Options + +(defgroup magit-wip nil + "Automatically commit to work-in-progress refs." + :link '(info-link "(magit)Wip Modes") + :group 'magit-modes + :group 'magit-essentials) + +(defgroup magit-wip-legacy nil + "It is better to not use these modes individually." + :link '(info-link "(magit)Legacy Wip Modes") + :group 'magit-wip) + +(defcustom magit-wip-mode-lighter " Wip" + "Lighter for Magit-Wip mode." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :type 'string) + +(defcustom magit-wip-after-save-local-mode-lighter "" + "Lighter for Magit-Wip-After-Save-Local mode." + :package-version '(magit . "2.1.0") + :group 'magit-wip-legacy + :type 'string) + +(defcustom magit-wip-after-apply-mode-lighter "" + "Lighter for Magit-Wip-After-Apply mode." + :package-version '(magit . "2.1.0") + :group 'magit-wip-legacy + :type 'string) + +(defcustom magit-wip-before-change-mode-lighter "" + "Lighter for Magit-Wip-Before-Change mode." + :package-version '(magit . "2.1.0") + :group 'magit-wip-legacy + :type 'string) + +(defcustom magit-wip-initial-backup-mode-lighter "" + "Lighter for Magit-Wip-Initial Backup mode." + :package-version '(magit . "2.1.0") + :group 'magit-wip-legacy + :type 'string) + +(defcustom magit-wip-merge-branch nil + "Whether to merge the current branch into its wip ref. + +If non-nil and the current branch has new commits, then it is +merged into the wip ref before creating a new wip commit. This +makes it easier to inspect wip history and the wip commits are +never garbage collected. + +If nil and the current branch has new commits, then the wip ref +is reset to the tip of the branch before creating a new wip +commit. With this setting wip commits are eventually garbage +collected. This is currently the default." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :type 'boolean) + +(defcustom magit-wip-namespace "refs/wip/" + "Namespace used for work-in-progress refs. +The wip refs are named \"index/\" +and \"wtree/\". When snapshots +are created while the `HEAD' is detached then \"HEAD\" +is used as `branch-ref'." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :type 'string) + +;;; Modes + +(define-minor-mode magit-wip-mode + "Save uncommitted changes to work-in-progress refs. + +Whenever appropriate (i.e. when dataloss would be a possibility +otherwise) this mode causes uncommitted changes to be committed +to dedicated work-in-progress refs. + +For historic reasons this mode is implemented on top of four +other `magit-wip-*' modes, which can also be used individually, +if you want finer control over when the wip refs are updated; +but that is discouraged." + :package-version '(magit . "2.90.0") + :lighter magit-wip-mode-lighter + :global t + (let ((arg (if magit-wip-mode 1 -1))) + (magit-wip-after-save-mode arg) + (magit-wip-after-apply-mode arg) + (magit-wip-before-change-mode arg) + (magit-wip-initial-backup-mode arg))) + +(define-minor-mode magit-wip-after-save-local-mode + "After saving, also commit to a worktree work-in-progress ref. + +After saving the current file-visiting buffer this mode also +commits the changes to the worktree work-in-progress ref for +the current branch. + +This mode should be enabled globally by turning on the globalized +variant `magit-wip-after-save-mode'." + :package-version '(magit . "2.1.0") + :lighter magit-wip-after-save-local-mode-lighter + (if magit-wip-after-save-local-mode + (if (and buffer-file-name (magit-inside-worktree-p t)) + (add-hook 'after-save-hook 'magit-wip-commit-buffer-file t t) + (setq magit-wip-after-save-local-mode nil) + (user-error "Need a worktree and a file")) + (remove-hook 'after-save-hook 'magit-wip-commit-buffer-file t))) + +(defun magit-wip-after-save-local-mode-turn-on () + (and buffer-file-name + (magit-inside-worktree-p t) + (magit-file-tracked-p buffer-file-name) + (magit-wip-after-save-local-mode))) + +;;;###autoload +(define-globalized-minor-mode magit-wip-after-save-mode + magit-wip-after-save-local-mode magit-wip-after-save-local-mode-turn-on + :package-version '(magit . "2.1.0") + :group 'magit-wip) + +(defun magit-wip-commit-buffer-file (&optional msg) + "Commit visited file to a worktree work-in-progress ref. + +Also see `magit-wip-after-save-mode' which calls this function +automatically whenever a buffer visiting a tracked file is saved." + (interactive) + (--when-let (magit-wip-get-ref) + (magit-with-toplevel + (let ((file (file-relative-name buffer-file-name))) + (magit-wip-commit-worktree + it (list file) + (format (cond (msg) + ((called-interactively-p 'any) + "wip-save %s after save") + (t + "autosave %s after save")) + file)))))) + +;;;###autoload +(define-minor-mode magit-wip-after-apply-mode + "Commit to work-in-progress refs. + +After applying a change using any \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected files to the current wip refs. For each branch there +may be two wip refs; one contains snapshots of the files as found +in the worktree and the other contains snapshots of the entries +in the index." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :lighter magit-wip-after-apply-mode-lighter + :global t) + +(defun magit-wip-commit-after-apply (&optional files msg) + (when magit-wip-after-apply-mode + (magit-wip-commit files msg))) + +;;;###autoload +(define-minor-mode magit-wip-before-change-mode + "Commit to work-in-progress refs before certain destructive changes. + +Before invoking a revert command or an \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected tracked files to the current wip refs. For each branch +there may be two wip refs; one contains snapshots of the files +as found in the worktree and the other contains snapshots of the +entries in the index. + +Only changes to files which could potentially be affected by the +command which is about to be called are committed." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :lighter magit-wip-before-change-mode-lighter + :global t) + +(defun magit-wip-commit-before-change (&optional files msg) + (when magit-wip-before-change-mode + (magit-with-toplevel + (magit-wip-commit files msg)))) + +(define-minor-mode magit-wip-initial-backup-mode + "Before saving a buffer for the first time, commit to a wip ref." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :lighter magit-wip-initial-backup-mode-lighter + :global t + (if magit-wip-initial-backup-mode + (add-hook 'before-save-hook 'magit-wip-commit-initial-backup) + (remove-hook 'before-save-hook 'magit-wip-commit-initial-backup))) + +(defun magit--any-wip-mode-enabled-p () + "Return non-nil if any global wip mode is enabled." + (or magit-wip-mode + magit-wip-after-save-mode + magit-wip-after-apply-mode + magit-wip-before-change-mode + magit-wip-initial-backup-mode)) + +(defvar-local magit-wip-buffer-backed-up nil) +(put 'magit-wip-buffer-backed-up 'permanent-local t) + +;;;###autoload +(defun magit-wip-commit-initial-backup () + "Before saving, commit current file to a worktree wip ref. + +The user has to add this function to `before-save-hook'. + +Commit the current state of the visited file before saving the +current buffer to that file. This backs up the same version of +the file as `backup-buffer' would, but stores the backup in the +worktree wip ref, which is also used by the various Magit Wip +modes, instead of in a backup file as `backup-buffer' would. + +This function ignores the variables that affect `backup-buffer' +and can be used along-side that function, which is recommended +because this function only backs up files that are tracked in +a Git repository." + (when (and (not magit-wip-buffer-backed-up) + buffer-file-name + (magit-inside-worktree-p t) + (magit-file-tracked-p buffer-file-name)) + (let ((magit-save-repository-buffers nil)) + (magit-wip-commit-buffer-file "autosave %s before save")) + (setq magit-wip-buffer-backed-up t))) + +;;; Core + +(defun magit-wip-commit (&optional files msg) + "Commit all tracked files to the work-in-progress refs. + +Interactively, commit all changes to all tracked files using +a generic commit message. With a prefix-argument the commit +message is read in the minibuffer. + +Non-interactively, only commit changes to FILES using MSG as +commit message." + (interactive (list nil (if current-prefix-arg + (magit-read-string "Wip commit message") + "wip-save tracked files"))) + (--when-let (magit-wip-get-ref) + (magit-wip-commit-index it files msg) + (magit-wip-commit-worktree it files msg))) + +(defun magit-wip-commit-index (ref files msg) + (let* ((wipref (magit--wip-index-ref ref)) + (parent (magit-wip-get-parent ref wipref)) + (tree (magit-git-string "write-tree"))) + (magit-wip-update-wipref ref wipref tree parent files msg "index"))) + +(defun magit-wip-commit-worktree (ref files msg) + (let* ((wipref (magit--wip-wtree-ref ref)) + (parent (magit-wip-get-parent ref wipref)) + (tree (magit-with-temp-index parent (list "--reset" "-i") + (if files + ;; Note: `update-index' is used instead of `add' + ;; because `add' will fail if a file is already + ;; deleted in the temporary index. + (magit-call-git + "update-index" "--add" "--remove" + (and (pcase (magit-repository-local-get + 'update-index-has-ignore-sw-p 'unset) + (`unset + (let ((val (version<= "2.25.0" + (magit-git-version)))) + (magit-repository-local-set + 'update-index-has-ignore-sw-p val) + val)) + (val val)) + "--ignore-skip-worktree-entries") + "--" files) + (magit-with-toplevel + (magit-call-git "add" "-u" "."))) + (magit-git-string "write-tree")))) + (magit-wip-update-wipref ref wipref tree parent files msg "worktree"))) + +(defun magit-wip-update-wipref (ref wipref tree parent files msg start-msg) + (cond + ((and (not (equal parent wipref)) + (or (not magit-wip-merge-branch) + (not (magit-rev-verify wipref)))) + (setq start-msg (concat "start autosaving " start-msg)) + (magit-update-ref wipref start-msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" parent "-m" start-msg + (concat parent "^{tree}"))) + (setq parent wipref)) + ((and magit-wip-merge-branch + (or (not (magit-rev-ancestor-p ref wipref)) + (not (magit-rev-ancestor-p + (concat (magit-git-string "log" "--format=%H" + "-1" "--merges" wipref) + "^2") + ref)))) + (setq start-msg (format "merge %s into %s" ref start-msg)) + (magit-update-ref wipref start-msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" wipref "-p" ref + "-m" start-msg + (concat ref "^{tree}"))) + (setq parent wipref))) + (when (magit-git-failure "diff-tree" "--quiet" parent tree "--" files) + (unless (and msg (not (= (aref msg 0) ?\s))) + (let ((len (length files))) + (setq msg (concat + (cond ((= len 0) "autosave tracked files") + ((> len 1) (format "autosave %s files" len)) + (t (concat "autosave " + (file-relative-name (car files) + (magit-toplevel))))) + msg)))) + (magit-update-ref wipref msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" parent "-m" msg tree)))) + +(defun magit-wip-get-ref () + (let ((ref (or (magit-git-string "symbolic-ref" "HEAD") "HEAD"))) + (and (magit-rev-verify ref) + ref))) + +(defun magit-wip-get-parent (ref wipref) + (if (and (magit-rev-verify wipref) + (equal (magit-git-string "merge-base" wipref ref) + (magit-rev-verify ref))) + wipref + ref)) + +(defun magit--wip-index-ref (&optional ref) + (magit--wip-ref "index/" ref)) + +(defun magit--wip-wtree-ref (&optional ref) + (magit--wip-ref "wtree/" ref)) + +(defun magit--wip-ref (namespace &optional ref) + (concat magit-wip-namespace namespace + (or (and ref (string-prefix-p "refs/" ref) ref) + (when-let ((branch (and (not (equal ref "HEAD")) + (or ref (magit-get-current-branch))))) + (concat "refs/heads/" branch)) + "HEAD"))) + +(defun magit-wip-maybe-add-commit-hook () + (when (and magit-wip-merge-branch + (magit-wip-any-enabled-p)) + (add-hook 'git-commit-post-finish-hook 'magit-wip-commit nil t))) + +(defun magit-wip-any-enabled-p () + (or magit-wip-mode + magit-wip-after-save-local-mode + magit-wip-after-save-mode + magit-wip-after-apply-mode + magit-wip-before-change-mode + magit-wip-initial-backup-mode)) + +;;; Log + +(defun magit-wip-log-index (args files) + "Show log for the index wip ref of the current branch." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list (magit--wip-index-ref)) args files)) + +(defun magit-wip-log-worktree (args files) + "Show log for the worktree wip ref of the current branch." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list (magit--wip-wtree-ref)) args files)) + +(defun magit-wip-log-current (branch args files count) + "Show log for the current branch and its wip refs. +With a negative prefix argument only show the worktree wip ref. +The absolute numeric value of the prefix argument controls how +many \"branches\" of each wip ref are shown." + (interactive + (nconc (list (or (magit-get-current-branch) "HEAD")) + (magit-log-arguments) + (list (prefix-numeric-value current-prefix-arg)))) + (magit-wip-log branch args files count)) + +(defun magit-wip-log (branch args files count) + "Show log for a branch and its wip refs. +With a negative prefix argument only show the worktree wip ref. +The absolute numeric value of the prefix argument controls how +many \"branches\" of each wip ref are shown." + (interactive + (nconc (list (magit-completing-read + "Log branch and its wip refs" + (-snoc (magit-list-local-branch-names) "HEAD") + nil t nil 'magit-revision-history + (or (magit-branch-at-point) + (magit-get-current-branch) + "HEAD"))) + (magit-log-arguments) + (list (prefix-numeric-value current-prefix-arg)))) + (magit-log-setup-buffer (nconc (list branch) + (magit-wip-log-get-tips + (magit--wip-wtree-ref branch) + (abs count)) + (and (>= count 0) + (magit-wip-log-get-tips + (magit--wip-index-ref branch) + (abs count)))) + args files)) + +(defun magit-wip-log-get-tips (wipref count) + (when-let ((reflog (magit-git-lines "reflog" wipref))) + (let (tips) + (while (and reflog (> count 1)) + (setq reflog (cl-member "^[^ ]+ [^:]+: restart autosaving" + reflog :test #'string-match-p)) + (when (and (cadr reflog) + (string-match "^[^ ]+ \\([^:]+\\)" (cadr reflog))) + (push (match-string 1 (cadr reflog)) tips)) + (setq reflog (cddr reflog)) + (cl-decf count)) + (cons wipref (nreverse tips))))) + +;;; _ +(provide 'magit-wip) +;;; magit-wip.el ends here diff --git a/elpa/magit-20200318.1224/magit-wip.elc b/elpa/magit-20200318.1224/magit-wip.elc new file mode 100644 index 00000000..7a8b86fd Binary files /dev/null and b/elpa/magit-20200318.1224/magit-wip.elc differ diff --git a/elpa/magit-20200318.1224/magit-worktree.el b/elpa/magit-20200318.1224/magit-worktree.el new file mode 100644 index 00000000..609a4a32 --- /dev/null +++ b/elpa/magit-20200318.1224/magit-worktree.el @@ -0,0 +1,184 @@ +;;; magit-worktree.el --- worktree support -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; This library implements support for `git-worktree'. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-worktree-read-directory-name-function 'read-directory-name + "Function used to read a directory for worktree commands. +This is called with one argument, the prompt, and can be used +to e.g. use a base directory other than `default-directory'. +Used by `magit-worktree-checkout' and `magit-worktree-branch'." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'function) + +;;; Commands + +;;;###autoload (autoload 'magit-worktree "magit-worktree" nil t) +(define-transient-command magit-worktree () + "Act on a worktree." + :man-page "git-worktree" + [["Create new" + ("b" "worktree" magit-worktree-checkout) + ("c" "branch and worktree" magit-worktree-branch)] + ["Commands" + ("m" "Move worktree" magit-worktree-move) + ("k" "Delete worktree" magit-worktree-delete) + ("g" "Visit worktree" magit-worktree-status)]]) + +;;;###autoload +(defun magit-worktree-checkout (path branch) + "Checkout BRANCH in a new worktree at PATH." + (interactive + (let ((branch (magit-read-branch-or-commit "Checkout"))) + (list (funcall magit-worktree-read-directory-name-function + (format "Checkout %s in new worktree: " branch)) + branch))) + (magit-run-git "worktree" "add" (expand-file-name path) branch) + (magit-diff-visit-directory path)) + +;;;###autoload +(defun magit-worktree-branch (path branch start-point &optional force) + "Create a new BRANCH and check it out in a new worktree at PATH." + (interactive + `(,(funcall magit-worktree-read-directory-name-function + "Create worktree: ") + ,@(magit-branch-read-args "Create and checkout branch") + ,current-prefix-arg)) + (magit-run-git "worktree" "add" (if force "-B" "-b") + branch (expand-file-name path) start-point) + (magit-diff-visit-directory path)) + +;;;###autoload +(defun magit-worktree-move (worktree path) + "Move WORKTREE to PATH." + (interactive + (list (magit-completing-read "Move worktree" + (cdr (magit-list-worktrees)) + nil t nil nil + (magit-section-value-if 'worktree)) + (funcall magit-worktree-read-directory-name-function + "Move worktree to: "))) + (if (file-directory-p (expand-file-name ".git" worktree)) + (user-error "You may not move the main working tree") + (let ((preexisting-directory (file-directory-p path))) + (when (and (zerop (magit-call-git "worktree" "move" worktree + (expand-file-name path))) + (not (file-exists-p default-directory)) + (derived-mode-p 'magit-status-mode)) + (kill-buffer) + (magit-diff-visit-directory + (if preexisting-directory + (concat (file-name-as-directory path) + (file-name-nondirectory worktree)) + path))) + (magit-refresh)))) + +(defun magit-worktree-delete (worktree) + "Delete a worktree, defaulting to the worktree at point. +The primary worktree cannot be deleted." + (interactive + (list (magit-completing-read "Delete worktree" + (cdr (magit-list-worktrees)) + nil t nil nil + (magit-section-value-if 'worktree)))) + (if (file-directory-p (expand-file-name ".git" worktree)) + (user-error "Deleting %s would delete the shared .git directory" worktree) + (let ((primary (file-name-as-directory (caar (magit-list-worktrees))))) + (magit-confirm-files (if magit-delete-by-moving-to-trash 'trash 'delete) + (list "worktree")) + (when (file-exists-p worktree) + (let ((delete-by-moving-to-trash magit-delete-by-moving-to-trash)) + (delete-directory worktree t magit-delete-by-moving-to-trash))) + (if (file-exists-p default-directory) + (magit-run-git "worktree" "prune") + (let ((default-directory primary)) + (magit-run-git "worktree" "prune")) + (when (derived-mode-p 'magit-status-mode) + (kill-buffer) + (magit-status-setup-buffer primary)))))) + +(defun magit-worktree-status (worktree) + "Show the status for the worktree at point. +If there is no worktree at point, then read one in the +minibuffer. If the worktree at point is the one whose +status is already being displayed in the current buffer, +then show it in Dired instead." + (interactive + (list (or (magit-section-value-if 'worktree) + (magit-completing-read + "Show status for worktree" + (cl-delete (directory-file-name (magit-toplevel)) + (magit-list-worktrees) + :test #'equal :key #'car))))) + (magit-diff-visit-directory worktree)) + +;;; Sections + +(defvar magit-worktree-section-map + (let ((map (make-sparse-keymap))) + (define-key map [remap magit-visit-thing] 'magit-worktree-status) + (define-key map [remap magit-delete-thing] 'magit-worktree-delete) + map) + "Keymap for `worktree' sections.") + +(defun magit-insert-worktrees () + "Insert sections for all worktrees. +If there is only one worktree, then insert nothing." + (let ((worktrees (magit-list-worktrees))) + (when (> (length worktrees) 1) + (magit-insert-section (worktrees) + (magit-insert-heading "Worktrees:") + (let* ((cols + (mapcar + (pcase-lambda (`(,path ,barep ,commit ,branch)) + (cons (cond + (branch (propertize + branch 'font-lock-face 'magit-branch-local)) + (commit (propertize (magit-rev-abbrev commit) + 'font-lock-face 'magit-hash)) + (barep "(bare)")) + path)) + worktrees)) + (align (1+ (-max (--map (string-width (car it)) cols))))) + (pcase-dolist (`(,head . ,path) cols) + (magit-insert-section (worktree path) + (insert head) + (indent-to align) + (insert (let ((r (file-relative-name path)) + (a (abbreviate-file-name path))) + (if (< (string-width r) (string-width a)) r a))) + (insert ?\n)))) + (insert ?\n))))) + +;;; _ +(provide 'magit-worktree) +;;; magit-worktree.el ends here diff --git a/elpa/magit-20200318.1224/magit-worktree.elc b/elpa/magit-20200318.1224/magit-worktree.elc new file mode 100644 index 00000000..3ec7d5b0 Binary files /dev/null and b/elpa/magit-20200318.1224/magit-worktree.elc differ diff --git a/elpa/magit-20200318.1224/magit.el b/elpa/magit-20200318.1224/magit.el new file mode 100644 index 00000000..a2602e7c --- /dev/null +++ b/elpa/magit-20200318.1224/magit.el @@ -0,0 +1,596 @@ +;;; magit.el --- A Git porcelain inside Emacs -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2008-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Author: Marius Vollmer +;; Maintainer: Jonas Bernoulli +;; Kyle Meyer +;; Noam Postavsky +;; Former-Maintainers: +;; Nicolas Dudebout +;; Peter J. Weisberg +;; Phil Jackson +;; Rémi Vanicat +;; Yann Hodique + +;; Keywords: git tools vc +;; Homepage: https://github.com/magit/magit + +;; Magit requires at least GNU Emacs 25.1 and Git 2.2.0. + +;; Magit 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, or (at your option) +;; any later version. +;; +;; Magit 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 Magit. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Magit is an interface to the version control system Git, +;; implemented as an Emacs package. Magit aspires to be a complete +;; Git porcelain. While we cannot (yet) claim, that Magit wraps and +;; improves upon each and every Git command, it is complete enough to +;; allow even experienced Git users to perform almost all of their +;; daily version control tasks directly from within Emacs. While many +;; fine Git clients exist, only Magit and Git itself deserve to be +;; called porcelains. + +;;; Code: + +(require 'cl-lib) +(require 'dash) + +(require 'subr-x) + +(require 'with-editor) +(require 'git-commit) +(require 'magit-core) +(require 'magit-diff) +(require 'magit-log) +(require 'magit-wip) +(require 'magit-apply) +(require 'magit-repos) + +(require 'format-spec) +(require 'package nil t) ; used in `magit-version' + +(defconst magit--minimal-git "2.2.0") +(defconst magit--minimal-emacs "25.1") + +;;; Faces + +(defface magit-header-line + '((t :inherit magit-section-heading)) + "Face for the `header-line' in some Magit modes. +Note that some modes, such as `magit-log-select-mode', have their +own faces for the `header-line', or for parts of the +`header-line'." + :group 'magit-faces) + +(defface magit-header-line-key + '((t :inherit font-lock-builtin-face)) + "Face for keys in the `header-line'." + :group 'magit-faces) + +(defface magit-dimmed + '((((class color) (background light)) :foreground "grey50") + (((class color) (background dark)) :foreground "grey50")) + "Face for text that shouldn't stand out." + :group 'magit-faces) + +(defface magit-hash + '((((class color) (background light)) :foreground "grey60") + (((class color) (background dark)) :foreground "grey40")) + "Face for the sha1 part of the log output." + :group 'magit-faces) + +(defface magit-tag + '((((class color) (background light)) :foreground "Goldenrod4") + (((class color) (background dark)) :foreground "LightGoldenrod2")) + "Face for tag labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote + '((((class color) (background light)) :foreground "DarkOliveGreen4") + (((class color) (background dark)) :foreground "DarkSeaGreen2")) + "Face for remote branch head labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote-head + '((((class color) (background light)) :inherit magit-branch-remote :box t) + (((class color) (background dark)) :inherit magit-branch-remote :box t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-local + '((((class color) (background light)) :foreground "SkyBlue4") + (((class color) (background dark)) :foreground "LightSkyBlue1")) + "Face for local branches." + :group 'magit-faces) + +(defface magit-branch-current + '((((class color) (background light)) :inherit magit-branch-local :box t) + (((class color) (background dark)) :inherit magit-branch-local :box t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-upstream + '((t :slant italic)) + "Face for upstream branch. +This face is only used in logs and it gets combined + with `magit-branch-local', `magit-branch-remote' +and/or `magit-branch-remote-head'." + :group 'magit-faces) + +(defface magit-head + '((((class color) (background light)) :inherit magit-branch-local) + (((class color) (background dark)) :inherit magit-branch-local)) + "Face for the symbolic ref `HEAD'." + :group 'magit-faces) + +(defface magit-refname + '((((class color) (background light)) :foreground "grey30") + (((class color) (background dark)) :foreground "grey80")) + "Face for refnames without a dedicated face." + :group 'magit-faces) + +(defface magit-refname-stash + '((t :inherit magit-refname)) + "Face for stash refnames." + :group 'magit-faces) + +(defface magit-refname-wip + '((t :inherit magit-refname)) + "Face for wip refnames." + :group 'magit-faces) + +(defface magit-refname-pullreq + '((t :inherit magit-refname)) + "Face for pullreq refnames." + :group 'magit-faces) + +(defface magit-keyword + '((t :inherit font-lock-string-face)) + "Face for parts of commit messages inside brackets." + :group 'magit-faces) + +(defface magit-keyword-squash + '((t :inherit font-lock-warning-face)) + "Face for squash! and fixup! keywords in commit messages." + :group 'magit-faces) + +(defface magit-signature-good + '((t :foreground "green")) + "Face for good signatures." + :group 'magit-faces) + +(defface magit-signature-bad + '((t :foreground "red" :weight bold)) + "Face for bad signatures." + :group 'magit-faces) + +(defface magit-signature-untrusted + '((t :foreground "cyan")) + "Face for good untrusted signatures." + :group 'magit-faces) + +(defface magit-signature-expired + '((t :foreground "orange")) + "Face for signatures that have expired." + :group 'magit-faces) + +(defface magit-signature-expired-key + '((t :inherit magit-signature-expired)) + "Face for signatures made by an expired key." + :group 'magit-faces) + +(defface magit-signature-revoked + '((t :foreground "violet red")) + "Face for signatures made by a revoked key." + :group 'magit-faces) + +(defface magit-signature-error + '((t :foreground "firebrick3")) + "Face for signatures that cannot be checked (e.g. missing key)." + :group 'magit-faces) + +(defface magit-cherry-unmatched + '((t :foreground "cyan")) + "Face for unmatched cherry commits." + :group 'magit-faces) + +(defface magit-cherry-equivalent + '((t :foreground "magenta")) + "Face for equivalent cherry commits." + :group 'magit-faces) + +(defface magit-filename + '((t :weight normal)) + "Face for filenames." + :group 'magit-faces) + +;;; Dispatch Popup + +;;;###autoload (autoload 'magit-dispatch "magit" nil t) +(define-transient-command magit-dispatch () + "Invoke a Magit command from a list of available commands." + ["Transient and dwim commands" + [("A" "Apply" magit-cherry-pick) + ("b" "Branch" magit-branch) + ("B" "Bisect" magit-bisect) + ("c" "Commit" magit-commit) + ("C" "Clone" magit-clone) + ("d" "Diff" magit-diff) + ("D" "Diff (change)" magit-diff-refresh) + ("e" "Ediff (dwim)" magit-ediff-dwim) + ("E" "Ediff" magit-ediff)] + [("f" "Fetch" magit-fetch) + ("F" "Pull" magit-pull) + ("l" "Log" magit-log) + ("L" "Log (change)" magit-log-refresh) + ("m" "Merge" magit-merge) + ("M" "Remote" magit-remote) + ("o" "Submodule" magit-submodule) + ("O" "Subtree" magit-subtree)] + [("P" "Push" magit-push) + ("r" "Rebase" magit-rebase) + ("t" "Tag" magit-tag) + ("T" "Note" magit-notes) + ("V" "Revert" magit-revert) + ("w" "Apply patches" magit-am) + ("W" "Format patches" magit-patch) + ("X" "Reset" magit-reset)] + [("y" "Show Refs" magit-show-refs) + ("Y" "Cherries" magit-cherry) + ("z" "Stash" magit-stash) + ("!" "Run" magit-run) + ("%" "Worktree" magit-worktree)]] + ["Applying changes" + :if-derived magit-mode + [("a" "Apply" magit-apply) + ("v" "Reverse" magit-reverse) + ("k" "Discard" magit-discard)] + [("s" "Stage" magit-stage) + ("u" "Unstage" magit-unstage)] + [("S" "Stage all" magit-stage-modified) + ("U" "Unstage all" magit-unstage-all)]] + ["Essential commands" + :if-derived magit-mode + ("g" " refresh current buffer" magit-refresh) + ("" " toggle section at point" magit-section-toggle) + ("" "visit thing at point" magit-visit-thing) + ("C-h m" " show all key bindings" describe-mode)]) + +;;; Git Popup + +(defcustom magit-shell-command-verbose-prompt t + "Whether to show the working directory when reading a command. +This affects `magit-git-command', `magit-git-command-topdir', +`magit-shell-command', and `magit-shell-command-topdir'." + :package-version '(magit . "2.11.0") + :group 'magit-commands + :type 'boolean) + +(defvar magit-git-command-history nil) + +;;;###autoload (autoload 'magit-run "magit" nil t) +(define-transient-command magit-run () + "Run git or another command, or launch a graphical utility." + [["Run git subcommand" + ("!" "in repository root" magit-git-command-topdir) + ("p" "in working directory" magit-git-command)] + ["Run shell command" + ("s" "in repository root" magit-shell-command-topdir) + ("S" "in working directory" magit-shell-command)] + ["Launch" + ("k" "gitk" magit-run-gitk) + ("a" "gitk --all" magit-run-gitk-all) + ("b" "gitk --branches" magit-run-gitk-branches) + ("g" "git gui" magit-run-git-gui)]]) + +;;;###autoload +(defun magit-git-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +With a prefix argument COMMAND is run in the top-level directory +of the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command nil "git "))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-git-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +COMMAND is run in the top-level directory of the current +working tree." + (interactive (list (magit-read-shell-command t "git "))) + (magit--shell-command command (magit-toplevel))) + +;;;###autoload +(defun magit-shell-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. With a +prefix argument COMMAND is run in the top-level directory of +the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-shell-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. COMMAND +is run in the top-level directory of the current working tree." + (interactive (list (magit-read-shell-command t))) + (magit--shell-command command (magit-toplevel))) + +(defun magit--shell-command (command &optional directory) + (let ((default-directory (or directory default-directory)) + (process-environment process-environment)) + (push "GIT_PAGER=cat" process-environment) + (magit-start-process shell-file-name nil + shell-command-switch command)) + (magit-process-buffer)) + +(defun magit-read-shell-command (&optional toplevel initial-input) + (let ((dir (abbreviate-file-name + (if (or toplevel current-prefix-arg) + (or (magit-toplevel) + (magit--not-inside-repository-error)) + default-directory)))) + (read-shell-command (if magit-shell-command-verbose-prompt + (format "Async shell command in %s: " dir) + "Async shell command: ") + initial-input 'magit-git-command-history))) + +;;; Font-Lock Keywords + +(defconst magit-font-lock-keywords + (eval-when-compile + `((,(concat "(\\(magit-define-section-jumper\\)\\_>" + "[ \t'\(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face nil t)) + (,(concat "(" (regexp-opt '("magit-insert-section" + "magit-section-case" + "magit-bind-match-strings" + "magit-with-temp-index" + "magit-with-blob" + "magit-with-toplevel") t) + "\\_>") + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode magit-font-lock-keywords) + +;;; Version + +(defvar magit-version 'undefined + "The version of Magit that you're using. +Use the function by the same name instead of this variable.") + +;;;###autoload +(defun magit-version (&optional print-dest) + "Return the version of Magit currently in use. +If optional argument PRINT-DEST is non-nil, output +stream (interactively, the echo area, or the current buffer with +a prefix argument), also print the used versions of Magit, Git, +and Emacs to it." + (interactive (list (if current-prefix-arg (current-buffer) t))) + (let ((magit-git-global-arguments nil) + (toplib (or load-file-name buffer-file-name)) + debug) + (unless (and toplib + (equal (file-name-nondirectory toplib) "magit.el")) + (setq toplib (locate-library "magit.el"))) + (setq toplib (and toplib (file-chase-links toplib))) + (push toplib debug) + (when toplib + (let* ((topdir (file-name-directory toplib)) + (gitdir (expand-file-name + ".git" (file-name-directory + (directory-file-name topdir)))) + (static (locate-library "magit-version.el" nil (list topdir))) + (static (and static (file-chase-links static)))) + (or (progn + (push 'repo debug) + (when (and (file-exists-p gitdir) + ;; It is a repo, but is it the Magit repo? + (file-exists-p + (expand-file-name "../lisp/magit.el" gitdir))) + (push t debug) + ;; Inside the repo the version file should only exist + ;; while running make. + (when (and static (not noninteractive)) + (ignore-errors (delete-file static))) + (setq magit-version + (let ((default-directory topdir)) + (magit-git-string "describe" "--tags" "--dirty"))))) + (progn + (push 'static debug) + (when (and static (file-exists-p static)) + (push t debug) + (load-file static) + magit-version)) + (when (featurep 'package) + (push 'elpa debug) + (ignore-errors + (--when-let (assq 'magit package-alist) + (push t debug) + (setq magit-version + (and (fboundp 'package-desc-version) + (package-version-join + (package-desc-version (cadr it)))))))) + (progn + (push 'dirname debug) + (let ((dirname (file-name-nondirectory + (directory-file-name topdir)))) + (when (string-match "\\`magit-\\([0-9]\\{8\\}\\.[0-9]*\\)" + dirname) + (setq magit-version (match-string 1 dirname)))))))) + (if (stringp magit-version) + (when print-dest + (princ (format "Magit %s, Git %s, Emacs %s, %s" + (or magit-version "(unknown)") + (or (let ((magit-git-debug + (lambda (err) + (display-warning '(magit git) + err :error)))) + (magit-git-version t)) + "(unknown)") + emacs-version + system-type) + print-dest)) + (setq debug (reverse debug)) + (setq magit-version 'error) + (when magit-version + (push magit-version debug)) + (unless (equal (getenv "TRAVIS") "true") + ;; The repository is a sparse clone. + (message "Cannot determine Magit's version %S" debug))) + magit-version)) + +;;; Debugging Tools + +(defun magit-debug-git-executable () + "Display a buffer with information about `magit-git-executable'. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (with-current-buffer (get-buffer-create "*magit-git-debug*") + (pop-to-buffer (current-buffer)) + (erase-buffer) + (insert (concat + (format "magit-git-executable: %S" magit-git-executable) + (and (not (file-name-absolute-p magit-git-executable)) + (format " [%S]" (executable-find magit-git-executable))) + (format " (%s)\n" + (let* ((errmsg nil) + (magit-git-debug (lambda (err) (setq errmsg err)))) + (or (magit-git-version t) errmsg))))) + (insert (format "exec-path: %S\n" exec-path)) + (--when-let (cl-set-difference + (-filter #'file-exists-p (remq nil (parse-colon-path + (getenv "PATH")))) + (-filter #'file-exists-p (remq nil exec-path)) + :test #'file-equal-p) + (insert (format " entries in PATH, but not in exec-path: %S\n" it))) + (dolist (execdir exec-path) + (insert (format " %s (%s)\n" execdir (car (file-attributes execdir)))) + (when (file-directory-p execdir) + (dolist (exec (directory-files + execdir t (concat + "\\`git" (regexp-opt exec-suffixes) "\\'"))) + (insert (format " %s (%s)\n" exec + (let* ((magit-git-executable exec) + (errmsg nil) + (magit-git-debug (lambda (err) (setq errmsg err)))) + (or (magit-git-version t) errmsg))))))))) + +;;; Startup Asserts + +(defun magit-startup-asserts () + (when-let ((val (getenv "GIT_DIR"))) + (setenv "GIT_DIR") + (message "Magit unset $GIT_DIR (was %S). See \ +https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike" val)) + (when-let ((val (getenv "GIT_WORK_TREE"))) + (setenv "GIT_WORK_TREE") + (message "Magit unset $GIT_WORK_TREE (was %S). See \ +https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike" val)) + (let ((version (magit-git-version))) + (when (and version + (version< version magit--minimal-git) + (not (equal (getenv "TRAVIS") "true"))) + (display-warning 'magit (format "\ +Magit requires Git >= %s, you are using %s. + +If this comes as a surprise to you, because you do actually have +a newer version installed, then that probably means that the +older version happens to appear earlier on the `$PATH'. If you +always start Emacs from a shell, then that can be fixed in the +shell's init file. If you start Emacs by clicking on an icon, +or using some sort of application launcher, then you probably +have to adjust the environment as seen by graphical interface. +For X11 something like ~/.xinitrc should work. + +If you use Tramp to work inside remote Git repositories, then you +have to make sure a suitable Git is used on the remote machines +too.\n" magit--minimal-git version) :error))) + (when (version< emacs-version magit--minimal-emacs) + (display-warning 'magit (format "\ +Magit requires Emacs >= %s, you are using %s. + +If this comes as a surprise to you, because you do actually have +a newer version installed, then that probably means that the +older version happens to appear earlier on the `$PATH'. If you +always start Emacs from a shell, then that can be fixed in the +shell's init file. If you start Emacs by clicking on an icon, +or using some sort of application launcher, then you probably +have to adjust the environment as seen by graphical interface. +For X11 something like ~/.xinitrc should work.\n" + magit--minimal-emacs emacs-version) + :error))) + +;;; Loading Libraries + +(provide 'magit) + +(cl-eval-when (load eval) + (require 'magit-status) + (require 'magit-refs) + (require 'magit-files) + (require 'magit-reset) + (require 'magit-branch) + (require 'magit-merge) + (require 'magit-tag) + (require 'magit-worktree) + (require 'magit-notes) + (require 'magit-sequence) + (require 'magit-commit) + (require 'magit-remote) + (require 'magit-clone) + (require 'magit-fetch) + (require 'magit-pull) + (require 'magit-push) + (require 'magit-bisect) + (require 'magit-stash) + (require 'magit-blame) + (require 'magit-obsolete) + (require 'magit-submodule) + (unless (load "magit-autoloads" t t) + (require 'magit-patch) + (require 'magit-subtree) + (require 'magit-ediff) + (require 'magit-gitignore) + (require 'magit-extras) + (require 'git-rebase) + (require 'magit-imenu) + (require 'magit-bookmark))) + +(eval-after-load 'bookmark + '(require 'magit-bookmark)) + +(if after-init-time + (progn (magit-startup-asserts) + (magit-version)) + (add-hook 'after-init-hook #'magit-startup-asserts t) + (add-hook 'after-init-hook #'magit-version t)) + +;;; magit.el ends here diff --git a/elpa/magit-20200318.1224/magit.elc b/elpa/magit-20200318.1224/magit.elc new file mode 100644 index 00000000..00b65b40 Binary files /dev/null and b/elpa/magit-20200318.1224/magit.elc differ diff --git a/elpa/magit-20200318.1224/magit.info b/elpa/magit-20200318.1224/magit.info new file mode 100644 index 00000000..1ccafb58 --- /dev/null +++ b/elpa/magit-20200318.1224/magit.info @@ -0,0 +1,192 @@ +This is magit.info, produced by makeinfo version 6.5 from magit.texi. + + Copyright (C) 2015-2020 Jonas Bernoulli + + You can redistribute this document 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. + + This document 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. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Magit: (magit). Using Git from Emacs with Magit. +END-INFO-DIR-ENTRY + + +Indirect: +magit.info-1: 754 +magit.info-2: 302693 + +Tag Table: +(Indirect) +Node: Top754 +Node: Introduction6439 +Node: Installation11162 +Node: Installing from Melpa11492 +Node: Installing from the Git Repository12565 +Node: Post-Installation Tasks14913 +Node: Getting Started16198 +Node: Interface Concepts21647 +Node: Modes and Buffers22008 +Node: Switching Buffers23757 +Node: Naming Buffers28508 +Node: Quitting Windows31815 +Node: Automatic Refreshing of Magit Buffers33561 +Node: Automatic Saving of File-Visiting Buffers36413 +Node: Automatic Reverting of File-Visiting Buffers37598 +Node: Risk of Reverting Automatically42593 +Node: Sections44975 +Node: Section Movement45901 +Node: Section Visibility50811 +Node: Section Hooks56888 +Node: Section Types and Values59295 +Node: Section Options60598 +Node: Transient Commands61070 +Node: Transient Arguments and Buffer Variables62307 +Node: Completion Confirmation and the Selection69325 +Node: Action Confirmation69769 +Node: Completion and Confirmation77119 +Node: The Selection80305 +Node: The hunk-internal region83204 +Node: Support for Completion Frameworks84293 +Node: Additional Completion Options89200 +Node: Running Git89799 +Node: Viewing Git Output90072 +Node: Git Process Status91205 +Node: Running Git Manually92170 +Node: Git Executable94640 +Node: Global Git Arguments96922 +Node: Inspecting97728 +Node: Status Buffer98885 +Node: Status Sections102875 +Node: Status Header Sections108427 +Node: Status Module Sections111057 +Node: Status Options113562 +Node: Repository List115031 +Node: Logging118069 +Node: Refreshing Logs120632 +Node: Log Buffer122078 +Node: Log Margin125934 +Node: Select from Log129113 +Node: Reflog131338 +Node: Cherries132995 +Node: Diffing134843 +Node: Refreshing Diffs137924 +Node: Commands Available in Diffs141503 +Node: Diff Options144039 +Node: Revision Buffer149077 +Node: Ediffing152407 +Node: References Buffer156055 +Node: References Sections166575 +Node: Bisecting167436 +Node: Visiting Files and Blobs169249 +Node: General-Purpose Visit Commands169719 +Node: Visiting Files and Blobs from a Diff170675 +Node: Blaming174134 +Node: Manipulating180697 +Node: Creating Repository181039 +Node: Cloning Repository181594 +Node: Staging and Unstaging186837 +Node: Staging from File-Visiting Buffers190920 +Node: Applying192088 +Node: Committing193981 +Node: Initiating a Commit194564 +Node: Editing Commit Messages197949 +Node: Using the Revision Stack200752 +Node: Commit Pseudo Headers203803 +Node: Commit Mode and Hooks205139 +Node: Commit Message Conventions208077 +Node: Branching210205 +Node: The Two Remotes210431 +Node: Branch Commands213084 +Node: Branch Git Variables225467 +Node: Auxiliary Branch Commands230858 +Node: Merging231976 +Node: Resolving Conflicts235984 +Node: Rebasing240985 +Node: Editing Rebase Sequences245844 +Node: Information About In-Progress Rebase250172 +Ref: Information About In-Progress Rebase-Footnote-1259054 +Node: Cherry Picking259650 +Node: Reverting263981 +Node: Resetting265430 +Node: Stashing267084 +Node: Transferring271785 +Node: Remotes272007 +Node: Remote Commands272159 +Node: Remote Git Variables276240 +Node: Fetching277519 +Node: Pulling280006 +Node: Pushing281052 +Node: Plain Patches284522 +Node: Maildir Patches286013 +Node: Miscellaneous287527 +Node: Tagging287843 +Node: Notes289771 +Node: Submodules292143 +Node: Listing Submodules292361 +Node: Submodule Transient294289 +Node: Subtree296811 +Node: Worktree298787 +Node: Common Commands299892 +Node: Wip Modes302693 +Node: Wip Graph307626 +Node: Legacy Wip Modes309940 +Node: Minor Mode for Buffers Visiting Files312835 +Node: Minor Mode for Buffers Visiting Blobs319936 +Node: Customizing320749 +Node: Per-Repository Configuration322345 +Node: Essential Settings324600 +Node: Safety324924 +Node: Performance326685 +Node: Microsoft Windows Performance334323 +Node: MacOS Performance335514 +Ref: MacOS Performance-Footnote-1336529 +Node: Plumbing336611 +Node: Calling Git337440 +Node: Getting a Value from Git338965 +Node: Calling Git for Effect342051 +Node: Section Plumbing348571 +Node: Creating Sections348799 +Node: Section Selection352699 +Node: Matching Sections354498 +Node: Refreshing Buffers360471 +Node: Conventions363619 +Node: Theming Faces363811 +Node: FAQ371926 +Node: FAQ - How to ...?372368 +Node: How to show git's output?372728 +Node: How to install the gitman info manual?373482 +Node: How to show diffs for gpg-encrypted files?374452 +Node: How does branching and pushing work?375048 +Node: Can Magit be used as ediff-version-control-package?375411 +Node: FAQ - Issues and Errors377400 +Node: Magit is slow378296 +Node: I changed several thousand files at once and now Magit is unusable378510 +Node: I am having problems committing379239 +Node: I am using MS Windows and cannot push with Magit379720 +Node: I am using OS X and SOMETHING works in shell but not in Magit380337 +Node: Expanding a file to show the diff causes it to disappear381168 +Node: Point is wrong in the COMMIT_EDITMSG buffer381749 +Node: The mode-line information isn't always up-to-date382795 +Node: A branch and tag sharing the same name breaks SOMETHING383877 +Node: My Git hooks work on the command-line but not inside Magit384763 +Node: git-commit-mode isn't used when committing from the command-line385609 +Node: Point ends up inside invisible text when jumping to a file-visiting buffer387876 +Node: Debugging Tools388674 +Node: Keystroke Index390853 +Node: Command Index424837 +Node: Function Index461862 +Node: Variable Index478214 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/elpa/magit-20200318.1224/magit.info-1 b/elpa/magit-20200318.1224/magit.info-1 new file mode 100644 index 00000000..a55cf1b7 --- /dev/null +++ b/elpa/magit-20200318.1224/magit.info-1 @@ -0,0 +1,7822 @@ +This is magit.info, produced by makeinfo version 6.5 from magit.texi. + + Copyright (C) 2015-2020 Jonas Bernoulli + + You can redistribute this document 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. + + This document 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. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Magit: (magit). Using Git from Emacs with Magit. +END-INFO-DIR-ENTRY + + +File: magit.info, Node: Top, Next: Introduction, Up: (dir) + +Magit User Manual +***************** + +Magit is an interface to the version control system Git, implemented as +an Emacs package. Magit aspires to be a complete Git porcelain. While +we cannot (yet) claim that Magit wraps and improves upon each and every +Git command, it is complete enough to allow even experienced Git users +to perform almost all of their daily version control tasks directly from +within Emacs. While many fine Git clients exist, only Magit and Git +itself deserve to be called porcelains. + +This manual is for Magit version 2.90.1 (v2.90.1-948-ge293416ce+1). + + Copyright (C) 2015-2020 Jonas Bernoulli + + You can redistribute this document 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. + + This document 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. + +* Menu: + +* Introduction:: +* Installation:: +* Getting Started:: +* Interface Concepts:: +* Inspecting:: +* Manipulating:: +* Transferring:: +* Miscellaneous:: +* Customizing:: +* Plumbing:: +* FAQ:: +* Debugging Tools:: +* Keystroke Index:: +* Command Index:: +* Function Index:: +* Variable Index:: + +— The Detailed Node Listing — + +Installation + +* Installing from Melpa:: +* Installing from the Git Repository:: +* Post-Installation Tasks:: + +Interface Concepts + +* Modes and Buffers:: +* Sections:: +* Transient Commands:: +* Transient Arguments and Buffer Variables:: +* Completion, Confirmation and the Selection: Completion Confirmation and the Selection. +* Running Git:: + +Modes and Buffers + +* Switching Buffers:: +* Naming Buffers:: +* Quitting Windows:: +* Automatic Refreshing of Magit Buffers:: +* Automatic Saving of File-Visiting Buffers:: +* Automatic Reverting of File-Visiting Buffers:: + + +Sections + +* Section Movement:: +* Section Visibility:: +* Section Hooks:: +* Section Types and Values:: +* Section Options:: + + +Completion, Confirmation and the Selection + +* Action Confirmation:: +* Completion and Confirmation:: +* The Selection:: +* The hunk-internal region:: +* Support for Completion Frameworks:: +* Additional Completion Options:: + + +Running Git + +* Viewing Git Output:: +* Git Process Status:: +* Running Git Manually:: +* Git Executable:: +* Global Git Arguments:: + + +Inspecting + +* Status Buffer:: +* Repository List:: +* Logging:: +* Diffing:: +* Ediffing:: +* References Buffer:: +* Bisecting:: +* Visiting Files and Blobs:: +* Blaming:: + +Status Buffer + +* Status Sections:: +* Status Header Sections:: +* Status Module Sections:: +* Status Options:: + + +Logging + +* Refreshing Logs:: +* Log Buffer:: +* Log Margin:: +* Select from Log:: +* Reflog:: +* Cherries:: + + +Diffing + +* Refreshing Diffs:: +* Commands Available in Diffs:: +* Diff Options:: +* Revision Buffer:: + + +References Buffer + +* References Sections:: + + +Visiting Files and Blobs + +* General-Purpose Visit Commands:: +* Visiting Files and Blobs from a Diff:: + + +Manipulating + +* Creating Repository:: +* Cloning Repository:: +* Staging and Unstaging:: +* Applying:: +* Committing:: +* Branching:: +* Merging:: +* Resolving Conflicts:: +* Rebasing:: +* Cherry Picking:: +* Resetting:: +* Stashing:: + +Staging and Unstaging + +* Staging from File-Visiting Buffers:: + + +Committing + +* Initiating a Commit:: +* Editing Commit Messages:: + + +Branching + +* The Two Remotes:: +* Branch Commands:: +* Branch Git Variables:: +* Auxiliary Branch Commands:: + + +Rebasing + +* Editing Rebase Sequences:: +* Information About In-Progress Rebase:: + + +Cherry Picking + +* Reverting:: + + +Transferring + +* Remotes:: +* Fetching:: +* Pulling:: +* Pushing:: +* Plain Patches:: +* Maildir Patches:: + +Remotes + +* Remote Commands:: +* Remote Git Variables:: + + +Miscellaneous + +* Tagging:: +* Notes:: +* Submodules:: +* Subtree:: +* Worktree:: +* Common Commands:: +* Wip Modes:: +* Minor Mode for Buffers Visiting Files:: +* Minor Mode for Buffers Visiting Blobs:: + +Submodules + +* Listing Submodules:: +* Submodule Transient:: + + +Wip Modes + +* Wip Graph:: +* Legacy Wip Modes:: + + +Customizing + +* Per-Repository Configuration:: +* Essential Settings:: + +Essential Settings + +* Safety:: +* Performance:: + + +Plumbing + +* Calling Git:: +* Section Plumbing:: +* Refreshing Buffers:: +* Conventions:: + +Calling Git + +* Getting a Value from Git:: +* Calling Git for Effect:: + + +Section Plumbing + +* Creating Sections:: +* Section Selection:: +* Matching Sections:: + + +Conventions + +* Theming Faces:: + + +FAQ + +* FAQ - How to ...?:: +* FAQ - Issues and Errors:: + +FAQ - How to ...? + +* How to show git's output?:: +* How to install the gitman info manual?:: +* How to show diffs for gpg-encrypted files?:: +* How does branching and pushing work?:: +* Can Magit be used as ediff-version-control-package?:: + + +FAQ - Issues and Errors + +* Magit is slow:: +* I changed several thousand files at once and now Magit is unusable:: +* I am having problems committing:: +* I am using MS Windows and cannot push with Magit:: +* I am using OS X and SOMETHING works in shell, but not in Magit: I am using OS X and SOMETHING works in shell but not in Magit. +* Expanding a file to show the diff causes it to disappear:: +* Point is wrong in the COMMIT_EDITMSG buffer:: +* The mode-line information isn't always up-to-date:: +* A branch and tag sharing the same name breaks SOMETHING:: +* My Git hooks work on the command-line but not inside Magit:: +* git-commit-mode isn't used when committing from the command-line:: +* Point ends up inside invisible text when jumping to a file-visiting buffer:: + + + + +File: magit.info, Node: Introduction, Next: Installation, Prev: Top, Up: Top + +1 Introduction +************** + +Magit is an interface to the version control system Git, implemented as +an Emacs package. Magit aspires to be a complete Git porcelain. While +we cannot (yet) claim that Magit wraps and improves upon each and every +Git command, it is complete enough to allow even experienced Git users +to perform almost all of their daily version control tasks directly from +within Emacs. While many fine Git clients exist, only Magit and Git +itself deserve to be called porcelains. + + Staging and otherwise applying changes is one of the most important +features in a Git porcelain and here Magit outshines anything else, +including Git itself. Git’s own staging interface (‘git add --patch’) +is so cumbersome that many users only use it in exceptional cases. In +Magit staging a hunk or even just part of a hunk is as trivial as +staging all changes made to a file. + + The most visible part of Magit’s interface is the status buffer, +which displays information about the current repository. Its content is +created by running several Git commands and making their output +actionable. Among other things, it displays information about the +current branch, lists unpulled and unpushed changes and contains +sections displaying the staged and unstaged changes. That might sound +noisy, but, since sections are collapsible, it’s not. + + To stage or unstage a change one places the cursor on the change and +then types ‘s’ or ‘u’. The change can be a file or a hunk, or when the +region is active (i.e. when there is a selection) several files or +hunks, or even just part of a hunk. The change or changes that these +commands - and many others - would act on are highlighted. + + Magit also implements several other "apply variants" in addition to +staging and unstaging. One can discard or reverse a change, or apply it +to the working tree. Git’s own porcelain only supports this for staging +and unstaging and you would have to do something like ‘git diff ... | +??? | git apply ...’ to discard, revert, or apply a single hunk on the +command line. In fact that’s exactly what Magit does internally (which +is what lead to the term "apply variants"). + + Magit isn’t just for Git experts, but it does assume some prior +experience with Git as well as Emacs. That being said, many users have +reported that using Magit was what finally taught them what Git is +capable of and how to use it to its fullest. Other users wished they +had switched to Emacs sooner so that they would have gotten their hands +on Magit earlier. + + While one has to know the basic features of Emacs to be able to make +full use of Magit, acquiring just enough Emacs skills doesn’t take long +and is worth it, even for users who prefer other editors. Vim users are +advised to give Evil (https://bitbucket.org/lyro/evil/wiki/Home), the +"Extensible VI Layer for Emacs", and Spacemacs +(https://github.com/syl20bnr/spacemacs), an "Emacs starter-kit focused +on Evil" a try. + + Magit provides a consistent and efficient Git porcelain. After a +short learning period, you will be able to perform most of your daily +version control tasks faster than you would on the command line. You +will likely also start using features that seemed too daunting in the +past. + + Magit fully embraces Git. It exposes many advanced features using a +simple but flexible interface instead of only wrapping the trivial ones +like many GUI clients do. Of course Magit supports logging, cloning, +pushing, and other commands that usually don’t fail in spectacular ways; +but it also supports tasks that often cannot be completed in a single +step. Magit fully supports tasks such as merging, rebasing, +cherry-picking, reverting, and blaming by not only providing a command +to initiate these tasks but also by displaying context sensitive +information along the way and providing commands that are useful for +resolving conflicts and resuming the sequence after doing so. + + Magit wraps and in many cases improves upon at least the following +Git porcelain commands: ‘add’, ‘am’, ‘bisect’, ‘blame’, ‘branch’, +‘checkout’, ‘cherry’, ‘cherry-pick’, ‘clean’, ‘clone’, ‘commit’, +‘config’, ‘describe’, ‘diff’, ‘fetch’, ‘format-patch’, ‘init’, ‘log’, +‘merge’, ‘merge-tree’, ‘mv’, ‘notes’, ‘pull’, ‘rebase’, ‘reflog’, +‘remote’, ‘request-pull’, ‘reset’, ‘revert’, ‘rm’, ‘show’, ‘stash’, +‘submodule’, ‘subtree’, ‘tag’, and ‘worktree.’ Many more Magit porcelain +commands are implemented on top of Git plumbing commands. + + +File: magit.info, Node: Installation, Next: Getting Started, Prev: Introduction, Up: Top + +2 Installation +************** + +Magit can be installed using Emacs’ package manager or manually from its +development repository. + +* Menu: + +* Installing from Melpa:: +* Installing from the Git Repository:: +* Post-Installation Tasks:: + + +File: magit.info, Node: Installing from Melpa, Next: Installing from the Git Repository, Up: Installation + +2.1 Installing from Melpa +========================= + +Magit is available from Melpa and Melpa-Stable. If you haven’t used +Emacs’ package manager before, then it is high time you familiarize +yourself with it by reading the documentation in the Emacs manual, see +*note (emacs)Packages::. Then add one of the archives to +‘package-archives’: + + • To use Melpa: + + (require 'package) + (add-to-list 'package-archives + '("melpa" . "http://melpa.org/packages/") t) + + • To use Melpa-Stable: + + (require 'package) + (add-to-list 'package-archives + '("melpa-stable" . "http://stable.melpa.org/packages/") t) + + Once you have added your preferred archive, you need to update the +local package list using: + + M-x package-refresh-contents RET + + Once you have done that, you can install Magit and its dependencies +using: + + M-x package-install RET magit RET + + Now see *note Post-Installation Tasks::. + + +File: magit.info, Node: Installing from the Git Repository, Next: Post-Installation Tasks, Prev: Installing from Melpa, Up: Installation + +2.2 Installing from the Git Repository +====================================== + +Magit depends on the ‘dash’, ‘transient’ and ‘with-editor’ libraries +which are available from Melpa and Melpa-Stable. Install them using +‘M-x package-install RET RET’. Of course you may also install +them manually from their repository. + + Then clone the Magit repository: + + $ git clone https://github.com/magit/magit.git ~/.emacs.d/site-lisp/magit + $ cd ~/.emacs.d/site-lisp/magit + + Then compile the libraries and generate the info manuals: + + $ make + + If you haven’t installed ‘dash’, ‘transient’ and ‘with-editor’ from +Melpa or at ‘/path/to/magit/../’, then you have to tell ‘make’ +where to find them. To do so create the file ‘/path/to/magit/config.mk’ +with the following content before running ‘make’: + + LOAD_PATH = -L /path/to/magit/lisp + LOAD_PATH += -L /path/to/dash + LOAD_PATH += -L /path/to/transient + LOAD_PATH += -L /path/to/with-editor + + Finally add this to your init file: + + (add-to-list 'load-path "~/.emacs.d/site-lisp/magit/lisp") + (require 'magit) + + (with-eval-after-load 'info + (info-initialize) + (add-to-list 'Info-directory-list + "~/.emacs.d/site-lisp/magit/Documentation/")) + + Note that you have to add the ‘lisp’ subdirectory to the ‘load-path’, +not the top-level of the repository, and that elements of ‘load-path’ +should not end with a slash, while those of ‘Info-directory-list’ +should. + + Instead of requiring the feature ‘magit’, you could load just the +autoload definitions, by loading the file ‘magit-autoloads.el’. + + (load "/path/to/magit/lisp/magit-autoloads") + + Instead of running Magit directly from the repository by adding that +to the ‘load-path’, you might want to instead install it in some other +directory using ‘sudo make install’ and setting ‘load-path’ accordingly. + + To update Magit use: + + $ git pull + $ make + + At times it might be necessary to run ‘make clean all’ instead. + + To view all available targets use ‘make help’. + + Now see *note Post-Installation Tasks::. + + +File: magit.info, Node: Post-Installation Tasks, Prev: Installing from the Git Repository, Up: Installation + +2.3 Post-Installation Tasks +=========================== + +After installing Magit you should verify that you are indeed using the +Magit, Git, and Emacs releases you think you are using. It’s best to +restart Emacs before doing so, to make sure you are not using an +outdated value for ‘load-path’. + + M-x magit-version RET + + should display something like + + Magit 2.8.0, Git 2.10.2, Emacs 25.1.1, gnu/linux + + Then you might also want to read about options that many users likely +want to customize. See *note Essential Settings::. + + To be able to follow cross references to Git manpages found in this +manual, you might also have to manually install the ‘gitman’ info +manual, or advice ‘Info-follow-nearest-node’ to instead open the actual +manpage. See *note How to install the gitman info manual?::. + + If you are completely new to Magit then see *note Getting Started::. + + If you run into problems, then please see the *note FAQ::. Also see +the *note Debugging Tools::. + + And last but not least please consider making a donation, to ensure +that I can keep working on Magit. See . +for various donation options. + + +File: magit.info, Node: Getting Started, Next: Interface Concepts, Prev: Installation, Up: Top + +3 Getting Started +***************** + +This short tutorial describes the most essential features that many +Magitians use on a daily basis. It only scratches the surface but +should be enough to get you started. + + IMPORTANT: It is safest if you clone some repository just for this +tutorial. Alternatively you can use an existing local repository, but +if you do that, then you should commit all uncommitted changes before +proceeding. + + To display information about the current Git repository, type ‘M-x +magit-status RET’. You will be using this command a lot, and should +therefore give it a global key binding. This is what we recommend: + + (global-set-key (kbd "C-x g") 'magit-status) + + Most Magit commands are commonly invoked from the status buffer. It +can be considered the primary interface for interacting with Git using +Magit. Many other Magit buffers may exist at a given time, but they are +often created from this buffer. + + Depending on what state your repository is in, this buffer may +contain sections titled "Staged changes", "Unstaged changes", "Unmerged +into origin/master", "Unpushed to origin/master", and many others. + + Since we are starting from a safe state, which you can easily return +to (by doing a ‘git reset --hard PRE-MAGIT-STATE’), there currently are +no staged or unstaged changes. Edit some files and save the changes. +Then go back to the status buffer, while at the same time refreshing it, +by typing ‘C-x g’. (When the status buffer, or any Magit buffer for +that matter, is the current buffer, then you can also use just ‘g’ to +refresh it). + + Move between sections using ‘p’ and ‘n’. Note that the bodies of +some sections are hidden. Type ‘TAB’ to expand or collapse the section +at point. You can also use ‘C-tab’ to cycle the visibility of the +current section and its children. Move to a file section inside the +section named "Unstaged changes" and type ‘s’ to stage the changes you +have made to that file. That file now appears under "Staged changes". + + Magit can stage and unstage individual hunks, not just complete +files. Move to the file you have just staged, expand it using ‘TAB’, +move to one of the hunks using ‘n’, and unstage just that by typing ‘u’. +Note how the staging (‘s’) and unstaging (‘u’) commands operate on the +change at point. Many other commands behave the same way. + + You can also un-/stage just part of a hunk. Inside the body of a +hunk section (move there using ‘C-n’), set the mark using ‘C-SPC’ and +move down until some added and/or removed lines fall inside the region +but not all of them. Again type ‘s’ to stage. + + It is also possible to un-/stage multiple files at once. Move to a +file section, type ‘C-SPC’, move to the next file using ‘n’, and then +‘s’ to stage both files. Note that both the mark and point have to be +on the headings of sibling sections for this to work. If the region +looks like it does in other buffers, then it doesn’t select Magit +sections that can be acted on as a unit. + + And then of course you want to commit your changes. Type ‘c’. This +shows the available commit commands and arguments in a buffer at the +bottom of the frame. Each command and argument is prefixed with the key +that invokes/sets it. Do not worry about this for now. We want to +create a "normal" commit, which is done by typing ‘c’ again. + + Now two new buffers appear. One is for writing the commit message, +the other shows a diff with the changes that you are about to committed. +Write a message and then type ‘C-c C-c’ to actually create the commit. + + You probably don’t want to push the commit you just created because +you just committed some random changes, but if that is not the case you +could push it by typing ‘P’ to show all the available push commands and +arguments and then ‘p’ to push to a branch with the same name as the +local branch onto the remote configured as the push-remote. (If the +push-remote is not configured yet, then you would first be prompted for +the remote to push to.) + + So far we have mentioned the commit, push, and log transient prefix +commands. These are probably among the transients you will be using the +most, but many others exist. To show a transient that lists all other +transients (as well as the various apply commands and some other +essential commands), type ‘h’. Try a few. + + The key bindings in that transient correspond to the bindings in +Magit buffers, including but not limited to the status buffer. So you +could type ‘h d’ to bring up the diff transient, but once you remember +that "d" stands for "diff", you would usually do so by just typing ‘d’. +But this "prefix of prefixes" is useful even once you have memorized all +the bindings, as it can provide easy access to Magit commands from +non-Magit buffers. You should create a global key binding for this +command too: + + (global-set-key (kbd "C-x M-g") 'magit-dispatch) + + In the same vein, you might also want to enable +‘global-magit-file-mode’ to get some more Magit key bindings in regular +file-visiting buffers (see *note Minor Mode for Buffers Visiting +Files::). + + It is not necessary that you do so now, but if you stick with Magit, +then it is highly recommended that you read the next section too. + + +File: magit.info, Node: Interface Concepts, Next: Inspecting, Prev: Getting Started, Up: Top + +4 Interface Concepts +******************** + +* Menu: + +* Modes and Buffers:: +* Sections:: +* Transient Commands:: +* Transient Arguments and Buffer Variables:: +* Completion, Confirmation and the Selection: Completion Confirmation and the Selection. +* Running Git:: + + +File: magit.info, Node: Modes and Buffers, Next: Sections, Up: Interface Concepts + +4.1 Modes and Buffers +===================== + +Magit provides several major-modes. For each of these modes there +usually exists only one buffer per repository. Separate modes and thus +buffers exist for commits, diffs, logs, and some other things. + + Besides these special purpose buffers, there also exists an overview +buffer, called the *status buffer*. It’s usually from this buffer that +the user invokes Git commands, or creates or visits other buffers. + + In this manual we often speak about "Magit buffers". By that we mean +buffers whose major-modes derive from ‘magit-mode’. + +‘M-x magit-toggle-buffer-lock’ (‘magit-toggle-buffer-lock’) + + This command locks the current buffer to its value or if the buffer + is already locked, then it unlocks it. + + Locking a buffer to its value prevents it from being reused to + display another value. The name of a locked buffer contains its + value, which allows telling it apart from other locked buffers and + the unlocked buffer. + + Not all Magit buffers can be locked to their values; for example, + it wouldn’t make sense to lock a status buffer. + + There can only be a single unlocked buffer using a certain + major-mode per repository. So when a buffer is being unlocked and + another unlocked buffer already exists for that mode and + repository, then the former buffer is instead deleted and the + latter is displayed in its place. + +* Menu: + +* Switching Buffers:: +* Naming Buffers:: +* Quitting Windows:: +* Automatic Refreshing of Magit Buffers:: +* Automatic Saving of File-Visiting Buffers:: +* Automatic Reverting of File-Visiting Buffers:: + + +File: magit.info, Node: Switching Buffers, Next: Naming Buffers, Up: Modes and Buffers + +4.1.1 Switching Buffers +----------------------- + + -- Function: magit-display-buffer buffer &optional display-function + + This function is a wrapper around ‘display-buffer’ and is used to + display any Magit buffer. It displays BUFFER in some window and, + unlike ‘display-buffer’, also selects that window, provided + ‘magit-display-buffer-noselect’ is ‘nil’. It also runs the hooks + mentioned below. + + If optional DISPLAY-FUNCTION is non-nil, then that is used to + display the buffer. Usually that is ‘nil’ and the function + specified by ‘magit-display-buffer-function’ is used. + + -- Variable: magit-display-buffer-noselect + + When this is non-nil, then ‘magit-display-buffer’ only displays the + buffer but forgoes also selecting the window. This variable should + not be set globally, it is only intended to be let-bound, by code + that automatically updates "the other window". This is used for + example when the revision buffer is updated when you move inside + the log buffer. + + -- User Option: magit-display-buffer-function + + The function specified here is called by ‘magit-display-buffer’ + with one argument, a buffer, to actually display that buffer. This + function should call ‘display-buffer’ with that buffer as first and + a list of display actions as second argument. + + Magit provides several functions, listed below, that are suitable + values for this option. If you want to use different rules, then a + good way of doing that is to start with a copy of one of these + functions and then adjust it to your needs. + + Instead of using a wrapper around ‘display-buffer’, that function + itself can be used here, in which case the display actions have to + be specified by adding them to ‘display-buffer-alist’ instead. + + To learn about display actions, see *note (elisp)Choosing Window::. + + -- Function: magit-display-buffer-traditional buffer + + This function is the current default value of the option + ‘magit-display-buffer-function’. Before that option and this + function were added, the behavior was hard-coded in many places all + over the code base but now all the rules are contained in this one + function (except for the "noselect" special case mentioned above). + + -- Function: magit-display-buffer-same-window-except-diff-v1 + + This function displays most buffers in the currently selected + window. If a buffer’s mode derives from ‘magit-diff-mode’ or + ‘magit-process-mode’, it is displayed in another window. + + -- Function: magit-display-buffer-fullframe-status-v1 + + This function fills the entire frame when displaying a status + buffer. Otherwise, it behaves like + ‘magit-display-buffer-traditional’. + + -- Function: magit-display-buffer-fullframe-status-topleft-v1 + + This function fills the entire frame when displaying a status + buffer. It behaves like ‘magit-display-buffer-fullframe-status-v1’ + except that it displays buffers that derive from ‘magit-diff-mode’ + or ‘magit-process-mode’ to the top or left of the current buffer + rather than to the bottom or right. As a result, Magit buffers + tend to pop up on the same side as they would if + ‘magit-display-buffer-traditional’ were in use. + + -- Function: magit-display-buffer-fullcolumn-most-v1 + + This function displays most buffers so that they fill the entire + height of the frame. However, the buffer is displayed in another + window if (1) the buffer’s mode derives from ‘magit-process-mode’, + or (2) the buffer’s mode derives from ‘magit-diff-mode’, provided + that the mode of the current buffer derives from ‘magit-log-mode’ + or ‘magit-cherry-mode’. + + -- User Option: magit-pre-display-buffer-hook + + This hook is run by ‘magit-display-buffer’ before displaying the + buffer. + + -- Function: magit-save-window-configuration + + This function saves the current window configuration. Later when + the buffer is buried, it may be restored by + ‘magit-restore-window-configuration’. + + -- User Option: magit-post-display-buffer-hook + + This hook is run by ‘magit-display-buffer’ after displaying the + buffer. + + -- Function: magit-maybe-set-dedicated + + This function remembers if a new window had to be created to + display the buffer, or whether an existing window was reused. This + information is later used by ‘magit-mode-quit-window’, to determine + whether the window should be deleted when its last Magit buffer is + buried. + + +File: magit.info, Node: Naming Buffers, Next: Quitting Windows, Prev: Switching Buffers, Up: Modes and Buffers + +4.1.2 Naming Buffers +-------------------- + + -- User Option: magit-generate-buffer-name-function + + The function used to generate the names of Magit buffers. + + Such a function should take the options + ‘magit-uniquify-buffer-names’ as well as ‘magit-buffer-name-format’ + into account. If it doesn’t, then should be clearly stated in the + doc-string. And if it supports %-sequences beyond those mentioned + in the doc-string of the option ‘magit-buffer-name-format’, then + its own doc-string should describe the additions. + + -- Function: magit-generate-buffer-name-default-function mode + + This function returns a buffer name suitable for a buffer whose + major-mode is MODE and which shows information about the repository + in which ‘default-directory’ is located. + + This function uses ‘magit-buffer-name-format’ and supporting all of + the %-sequences mentioned the documentation of that option. It + also respects the option ‘magit-uniquify-buffer-names’. + + -- User Option: magit-buffer-name-format + + The format string used to name Magit buffers. + + At least the following %-sequences are supported: + + • ‘%m’ + + The name of the major-mode, but with the ‘-mode’ suffix + removed. + + • ‘%M’ + + Like ‘%m’ but abbreviate ‘magit-status-mode’ as ‘magit’. + + • ‘%v’ + + The value the buffer is locked to, in parentheses, or an empty + string if the buffer is not locked to a value. + + • ‘%V’ + + Like ‘%v’, but the string is prefixed with a space, unless it + is an empty string. + + • ‘%t’ + + The top-level directory of the working tree of the repository, + or if ‘magit-uniquify-buffer-names’ is non-nil an abbreviation + of that. + + • ‘%x’ + + If ‘magit-uniquify-buffer-names’ is nil "*", otherwise the + empty string. Due to limitations of the ‘uniquify’ package, + buffer names must end with the path. + + • ‘%T’ + + Obsolete, use "%t%x" instead. Like ‘%t’, but append an + asterisk if and only if ‘magit-uniquify-buffer-names’ is nil. + + The value should always contain ‘%m’ or ‘%M’, ‘%v’ or ‘%V’, and + ‘%t’ (or the obsolete ‘%T’). If ‘magit-uniquify-buffer-names’ is + non-nil, then the value must end with ‘%t’ or ‘%t%x’ (or the + obsolete ‘%T’). See issue #2841. + + -- User Option: magit-uniquify-buffer-names + + This option controls whether the names of Magit buffers are + uniquified. If the names are not being uniquified, then they + contain the full path of the top-level of the working tree of the + corresponding repository. If they are being uniquified, then they + end with the basename of the top-level, or if that would conflict + with the name used for other buffers, then the names of all these + buffers are adjusted until they no longer conflict. + + This is done using the ‘uniquify’ package; customize its options to + control how buffer names are uniquified. + + +File: magit.info, Node: Quitting Windows, Next: Automatic Refreshing of Magit Buffers, Prev: Naming Buffers, Up: Modes and Buffers + +4.1.3 Quitting Windows +---------------------- + +‘q’ (‘magit-mode-bury-buffer’) + + This command buries the current Magit buffer. + + With a prefix argument, it instead kills the buffer. With a double + prefix argument, also kills all other Magit buffers associated with + the current project. + + -- User Option: magit-bury-buffer-function + + The function used to actually bury or kill the current buffer. + + ‘magit-mode-bury-buffer’ calls this function with one argument. If + the argument is non-nil, then the function has to kill the current + buffer. Otherwise it has to bury it alive. The default value + currently is ‘magit-restore-window-configuration’. + + -- Function: magit-restore-window-configuration kill-buffer + + Bury or kill the current buffer using ‘quit-window’, which is + called with KILL-BUFFER as first and the selected window as second + argument. + + Then restore the window configuration that existed right before the + current buffer was displayed in the selected frame. Unfortunately + that also means that point gets adjusted in all the buffers, which + are being displayed in the selected frame. + + -- Function: magit-mode-quit-window kill-buffer + + Bury or kill the current buffer using ‘quit-window’, which is + called with KILL-BUFFER as first and the selected window as second + argument. + + Then, if the window was originally created to display a Magit + buffer and the buried buffer was the last remaining Magit buffer + that was ever displayed in the window, then that is deleted. + + +File: magit.info, Node: Automatic Refreshing of Magit Buffers, Next: Automatic Saving of File-Visiting Buffers, Prev: Quitting Windows, Up: Modes and Buffers + +4.1.4 Automatic Refreshing of Magit Buffers +------------------------------------------- + +After running a command which may change the state of the current +repository, the current Magit buffer and the corresponding status buffer +are refreshed. The status buffer can be automatically refreshed +whenever a buffer is saved to a file inside the respective repository by +adding a hook, like so: + + (add-hook 'after-save-hook 'magit-after-save-refresh-status t) + + Automatically refreshing Magit buffers ensures that the displayed +information is up-to-date most of the time but can lead to a noticeable +delay in big repositories. Other Magit buffers are not refreshed to +keep the delay to a minimum and also because doing so can sometimes be +undesirable. + + Buffers can also be refreshed explicitly, which is useful in buffers +that weren’t current during the last refresh and after changes were made +to the repository outside of Magit. + +‘g’ (‘magit-refresh’) + + This command refreshes the current buffer if its major mode derives + from ‘magit-mode’ as well as the corresponding status buffer. + + If the option ‘magit-revert-buffers’ calls for it, then it also + reverts all unmodified buffers that visit files being tracked in + the current repository. + +‘G’ (‘magit-refresh-all’) + + This command refreshes all Magit buffers belonging to the current + repository and also reverts all unmodified buffers that visit files + being tracked in the current repository. + + The file-visiting buffers are always reverted, even if + ‘magit-revert-buffers’ is nil. + + -- User Option: magit-refresh-buffer-hook + + This hook is run in each Magit buffer that was refreshed during the + current refresh - normally the current buffer and the status + buffer. + + -- User Option: magit-refresh-status-buffer + + When this option is non-nil, then the status buffer is + automatically refreshed after running git for side-effects, in + addition to the current Magit buffer, which is always refreshed + automatically. + + Only set this to nil after exhausting all other options to improve + performance. + + -- Function: magit-after-save-refresh-status + + This function is intended to be added to ‘after-save-hook’. After + doing that the corresponding status buffer is refreshed whenever a + buffer is saved to a file inside a repository. + + Note that refreshing a Magit buffer is done by re-creating its + contents from scratch, which can be slow in large repositories. If + you are not satisfied with Magit’s performance, then you should + obviously not add this function to that hook. + + +File: magit.info, Node: Automatic Saving of File-Visiting Buffers, Next: Automatic Reverting of File-Visiting Buffers, Prev: Automatic Refreshing of Magit Buffers, Up: Modes and Buffers + +4.1.5 Automatic Saving of File-Visiting Buffers +----------------------------------------------- + +File-visiting buffers are by default saved at certain points in time. +This doesn’t guarantee that Magit buffers are always up-to-date, but, +provided one only edits files by editing them in Emacs and uses only +Magit to interact with Git, one can be fairly confident. When in doubt +or after outside changes, type ‘g’ (‘magit-refresh’) to save and refresh +explicitly. + + -- User Option: magit-save-repository-buffers + + This option controls whether file-visiting buffers are saved before + certain events. + + If this is non-nil then all modified file-visiting buffers + belonging to the current repository may be saved before running + commands, before creating new Magit buffers, and before explicitly + refreshing such buffers. If this is ‘dontask’ then this is done + without user intervention. If it is ‘t’ then the user has to + confirm each save. + + +File: magit.info, Node: Automatic Reverting of File-Visiting Buffers, Prev: Automatic Saving of File-Visiting Buffers, Up: Modes and Buffers + +4.1.6 Automatic Reverting of File-Visiting Buffers +-------------------------------------------------- + +By default Magit automatically reverts buffers that are visiting files +that are being tracked in a Git repository, after they have changed on +disk. When using Magit one often changes files on disk by running Git, +i.e. "outside Emacs", making this a rather important feature. + + For example, if you discard a change in the status buffer, then that +is done by running ‘git apply --reverse ...’, and Emacs considers the +file to have "changed on disk". If Magit did not automatically revert +the buffer, then you would have to type ‘M-x revert-buffer RET RET’ in +the visiting buffer before you could continue making changes. + + -- User Option: magit-auto-revert-mode + + When this mode is enabled, then buffers that visit tracked files + are automatically reverted after the visited files change on disk. + + -- User Option: global-auto-revert-mode + + When this mode is enabled, then any file-visiting buffer is + automatically reverted after the visited file changes on disk. + + If you like buffers that visit tracked files to be automatically + reverted, then you might also like any buffer to be reverted, not + just those visiting tracked files. If that is the case, then + enable this mode _instead of_ ‘magit-auto-revert-mode’. + + -- User Option: magit-auto-revert-immediately + + This option controls whether Magit reverts buffers immediately. + + If this is non-nil and either ‘global-auto-revert-mode’ or + ‘magit-auto-revert-mode’ is enabled, then Magit immediately reverts + buffers by explicitly calling ‘auto-revert-buffers’ after running + Git for side-effects. + + If ‘auto-revert-use-notify’ is non-nil (and file notifications are + actually supported), then ‘magit-auto-revert-immediately’ does not + have to be non-nil, because the reverts happen immediately anyway. + + If ‘magit-auto-revert-immediately’ and ‘auto-revert-use-notify’ are + both ‘nil’, then reverts happen after ‘auto-revert-interval’ + seconds of user inactivity. That is not desirable. + + -- User Option: auto-revert-use-notify + + This option controls whether file notification functions should be + used. Note that this variable unfortunately defaults to ‘t’ even + on systems on which file notifications cannot be used. + + -- User Option: magit-auto-revert-tracked-only + + This option controls whether ‘magit-auto-revert-mode’ only reverts + tracked files or all files that are located inside Git + repositories, including untracked files and files located inside + Git’s control directory. + + -- User Option: auto-revert-mode + + The global mode ‘magit-auto-revert-mode’ works by turning on this + local mode in the appropriate buffers (but + ‘global-auto-revert-mode’ is implemented differently). You can + also turn it on or off manually, which might be necessary if Magit + does not notice that a previously untracked file now is being + tracked or vice-versa. + + -- User Option: auto-revert-stop-on-user-input + + This option controls whether the arrival of user input suspends the + automatic reverts for ‘auto-revert-interval’ seconds. + + -- User Option: auto-revert-interval + + This option controls how many seconds Emacs waits for before + resuming suspended reverts. + + -- User Option: auto-revert-buffer-list-filter + + This option specifies an additional filter used by + ‘auto-revert-buffers’ to determine whether a buffer should be + reverted or not. + + This option is provided by Magit, which also advises + ‘auto-revert-buffers’ to respect it. Magit users who do not turn + on the local mode ‘auto-revert-mode’ themselves, are best served by + setting the value to ‘magit-auto-revert-repository-buffer-p’. + + However the default is nil, so as not to disturb users who do use + the local mode directly. If you experience delays when running + Magit commands, then you should consider using one of the + predicates provided by Magit - especially if you also use Tramp. + + Users who do turn on ‘auto-revert-mode’ in buffers in which Magit + doesn’t do that for them, should likely not use any filter. Users + who turn on ‘global-auto-revert-mode’, do not have to worry about + this option, because it is disregarded if the global mode is + enabled. + + -- User Option: auto-revert-verbose + + This option controls whether Emacs reports when a buffer has been + reverted. + + The options with the ‘auto-revert-’ prefix are located in the Custom +group named ‘auto-revert’. The other, Magit-specific, options are +located in the ‘magit’ group. + +* Menu: + +* Risk of Reverting Automatically:: + + +File: magit.info, Node: Risk of Reverting Automatically, Up: Automatic Reverting of File-Visiting Buffers + +Risk of Reverting Automatically +............................... + +For the vast majority of users, automatically reverting file-visiting +buffers after they have changed on disk is harmless. + + If a buffer is modified (i.e. it contains changes that haven’t been +saved yet), then Emacs will refuse to automatically revert it. If you +save a previously modified buffer, then that results in what is seen by +Git as an uncommitted change. Git will then refuse to carry out any +commands that would cause these changes to be lost. In other words, if +there is anything that could be lost, then either Git or Emacs will +refuse to discard the changes. + + However, if you use file-visiting buffers as a sort of ad hoc +"staging area", then the automatic reverts could potentially cause data +loss. So far I have heard from only one user who uses such a workflow. + + An example: You visit some file in a buffer, edit it, and save the +changes. Then, outside of Emacs (or at least not using Magit or by +saving the buffer) you change the file on disk again. At this point the +buffer is the only place where the intermediate version still exists. +You have saved the changes to disk, but that has since been overwritten. +Meanwhile Emacs considers the buffer to be unmodified (because you have +not made any changes to it since you last saved it to the visited file) +and therefore would not object to it being automatically reverted. At +this point an Auto-Revert mode would kick in. It would check whether +the buffer is modified and since that is not the case it would revert +it. The intermediate version would be lost. (Actually you could still +get it back using the ‘undo’ command.) + + If your workflow depends on Emacs preserving the intermediate version +in the buffer, then you have to disable all Auto-Revert modes. But +please consider that such a workflow would be dangerous even without +using an Auto-Revert mode, and should therefore be avoided. If Emacs +crashes or if you quit Emacs by mistake, then you would also lose the +buffer content. There would be no autosave file still containing the +intermediate version (because that was deleted when you saved the +buffer) and you would not be asked whether you want to save the buffer +(because it isn’t modified). + + +File: magit.info, Node: Sections, Next: Transient Commands, Prev: Modes and Buffers, Up: Interface Concepts + +4.2 Sections +============ + +Magit buffers are organized into nested sections, which can be collapsed +and expanded, similar to how sections are handled in Org mode. Each +section also has a type, and some sections also have a value. For each +section type there can also be a local keymap, shared by all sections of +that type. + + Taking advantage of the section value and type, many commands operate +on the current section, or when the region is active and selects +sections of the same type, all of the selected sections. Commands that +only make sense for a particular section type (as opposed to just +behaving differently depending on the type) are usually bound in section +type keymaps. + +* Menu: + +* Section Movement:: +* Section Visibility:: +* Section Hooks:: +* Section Types and Values:: +* Section Options:: + + +File: magit.info, Node: Section Movement, Next: Section Visibility, Up: Sections + +4.2.1 Section Movement +---------------------- + +To move within a section use the usual keys (‘C-p’, ‘C-n’, ‘C-b’, ‘C-f’ +etc), whose global bindings are not shadowed. To move to another +section use the following commands. + +‘p’ (‘magit-section-backward’) + + When not at the beginning of a section, then move to the beginning + of the current section. At the beginning of a section, instead + move to the beginning of the previous visible section. + +‘n’ (‘magit-section-forward’) + + Move to the beginning of the next visible section. + +‘M-p’ (‘magit-section-backward-siblings’) + + Move to the beginning of the previous sibling section. If there is + no previous sibling section, then move to the parent section + instead. + +‘M-n’ (‘magit-section-forward-siblings’) + + Move to the beginning of the next sibling section. If there is no + next sibling section, then move to the parent section instead. + +‘^’ (‘magit-section-up’) + + Move to the beginning of the parent of the current section. + + The above commands all call the hook ‘magit-section-movement-hook’. +Any of the functions listed below can be used as members of this hook. + + You might want to remove some of the functions that Magit adds using +‘add-hook’. In doing so you have to make sure you do not attempt to +remove function that haven’t even been added yet, for example: + + (with-eval-after-load 'magit-diff + (remove-hook 'magit-section-movement-hook + 'magit-hunk-set-window-start)) + + -- Variable: magit-section-movement-hook + + This hook is run by all of the above movement commands, after + arriving at the destination. + + -- Function: magit-hunk-set-window-start + + This hook function ensures that the beginning of the current + section is visible, provided it is a ‘hunk’ section. Otherwise, it + does nothing. + + Loading ‘magit-diff’ adds this function to the hook. + + -- Function: magit-section-set-window-start + + This hook function ensures that the beginning of the current + section is visible, regardless of the section’s type. If you add + this to ‘magit-section-movement-hook’, then you must remove the + hunk-only variant in turn. + + -- Function: magit-log-maybe-show-more-commits + + This hook function only has an effect in log buffers, and ‘point’ + is on the "show more" section. If that is the case, then it + doubles the number of commits that are being shown. + + Loading ‘magit-log’ adds this function to the hook. + + -- Function: magit-log-maybe-update-revision-buffer + + When moving inside a log buffer, then this function updates the + revision buffer, provided it is already being displayed in another + window of the same frame. + + Loading ‘magit-log’ adds this function to the hook. + + -- Function: magit-log-maybe-update-blob-buffer + + When moving inside a log buffer and another window of the same + frame displays a blob buffer, then this function instead displays + the blob buffer for the commit at point in that window. + + -- Function: magit-status-maybe-update-revision-buffer + + When moving inside a status buffer, then this function updates the + revision buffer, provided it is already being displayed in another + window of the same frame. + + -- Function: magit-status-maybe-update-stash-buffer + + When moving inside a status buffer, then this function updates the + stash buffer, provided it is already being displayed in another + window of the same frame. + + -- Function: magit-status-maybe-update-blob-buffer + + When moving inside a status buffer and another window of the same + frame displays a blob buffer, then this function instead displays + the blob buffer for the commit at point in that window. + + -- Function: magit-stashes-maybe-update-stash-buffer + + When moving inside a buffer listing stashes, then this function + updates the stash buffer, provided it is already being displayed in + another window of the same frame. + + -- User Option: magit-update-other-window-delay + + Delay before automatically updating the other window. + + When moving around in certain buffers, then certain other buffers, + which are being displayed in another window, may optionally be + updated to display information about the section at point. + + When holding down a key to move by more than just one section, then + that would update that buffer for each section on the way. To + prevent that, updating the revision buffer is delayed, and this + option controls for how long. For optimal experience you might + have to adjust this delay and/or the keyboard repeat rate and delay + of your graphical environment or operating system. + + +File: magit.info, Node: Section Visibility, Next: Section Hooks, Prev: Section Movement, Up: Sections + +4.2.2 Section Visibility +------------------------ + +Magit provides many commands for changing the visibility of sections, +but all you need to get started are the next two. + +‘TAB’ (‘magit-section-toggle’) + + Toggle the visibility of the body of the current section. + +‘C-’ (‘magit-section-cycle’) + + Cycle the visibility of current section and its children. + +‘M-’ (‘magit-section-cycle-diffs’) + + Cycle the visibility of diff-related sections in the current + buffer. + +‘S-’ (‘magit-section-cycle-global’) + + Cycle the visibility of all sections in the current buffer. + +‘1’ (‘magit-section-show-level-1’) +‘2’ (‘magit-section-show-level-2’) +‘3’ (‘magit-section-show-level-3’) +‘4’ (‘magit-section-show-level-4’) + + Show sections surrounding the current section up to level N. + +‘M-1’ (‘magit-section-show-level-1-all’) +‘M-2’ (‘magit-section-show-level-2-all’) +‘M-3’ (‘magit-section-show-level-3-all’) +‘M-4’ (‘magit-section-show-level-4-all’) + + Show all sections up to level N. + + Some functions, which are used to implement the above commands, are +also exposed as commands themselves. By default no keys are bound to +these commands, as they are generally perceived to be much less useful. +But your mileage may vary. + + -- Command: magit-section-show + + Show the body of the current section. + + -- Command: magit-section-hide + + Hide the body of the current section. + + -- Command: magit-section-show-headings + + Recursively show headings of children of the current section. Only + show the headings. Previously shown text-only bodies are hidden. + + -- Command: magit-section-show-children + + Recursively show the bodies of children of the current section. + With a prefix argument show children down to the level of the + current section, and hide deeper children. + + -- Command: magit-section-hide-children + + Recursively hide the bodies of children of the current section. + + -- Command: magit-section-toggle-children + + Toggle visibility of bodies of children of the current section. + + When a buffer is first created then some sections are shown expanded +while others are not. This is hard coded. When a buffer is refreshed +then the previous visibility is preserved. The initial visibility of +certain sections can also be overwritten using the hook +‘magit-section-set-visibility-hook’. + + -- User Option: magit-section-initial-visibility-alist + + This options can be used to override the initial visibility of + sections. In the future it will also be used to define the + defaults, but currently a section’s default is still hardcoded. + + The value is an alist. Each element maps a section type or lineage + to the initial visibility state for such sections. The state has + to be one of ‘show’ or ‘hide’, or a function that returns one of + these symbols. A function is called with the section as the only + argument. + + Use the command ‘magit-describe-section-briefly’ to determine a + section’s lineage or type. The vector in the output is the section + lineage and the type is the first element of that vector. + Wildcards can be used, see ‘magit-section-match’. + + -- User Option: magit-section-cache-visibility + + This option controls for which sections the previous visibility + state should be restored if a section disappears and later appears + again. The value is a boolean or a list of section types. If t, + then the visibility of all sections is cached. Otherwise this is + only done for sections whose type matches one of the listed types. + + This requires that the function ‘magit-section-cached-visibility’ + is a member of ‘magit-section-set-visibility-hook’. + + -- Variable: magit-section-set-visibility-hook + + This hook is run when first creating a buffer and also when + refreshing an existing buffer, and is used to determine the + visibility of the section currently being inserted. + + Each function is called with one argument, the section being + inserted. It should return ‘hide’ or ‘show’, or to leave the + visibility undefined ‘nil’. If no function decides on the + visibility and the buffer is being refreshed, then the visibility + is preserved; or if the buffer is being created, then the hard + coded default is used. + + Usually this should only be used to set the initial visibility but + not during refreshes. If ‘magit-insert-section--oldroot’ is + non-nil, then the buffer is being refreshed and these functions + should immediately return ‘nil’. + + -- User Option: magit-section-visibility-indicator + + This option controls whether and how to indicate that a section can + be expanded/collapsed. + + If nil, then no visibility indicators are shown. Otherwise the + value has to have one of these two forms: + + • ‘(EXPANDABLE-BITMAP . COLLAPSIBLE-BITMAP)’ + + Both values have to be variables whose values are fringe + bitmaps. In this case every section that can be expanded or + collapsed gets an indicator in the left fringe. + + To provide extra padding around the indicator, set + ‘left-fringe-width’ in ‘magit-mode-hook’, e.g.: + + (add-hook 'magit-mode-hook (lambda () + (setq left-fringe-width 20))) + + • ‘(STRING . BOOLEAN)’ + + In this case STRING (usually an ellipsis) is shown at the end + of the heading of every collapsed section. Expanded sections + get no indicator. The cdr controls whether the appearance of + these ellipsis take section highlighting into account. Doing + so might potentially have an impact on performance, while not + doing so is kinda ugly. + + +File: magit.info, Node: Section Hooks, Next: Section Types and Values, Prev: Section Visibility, Up: Sections + +4.2.3 Section Hooks +------------------- + +Which sections are inserted into certain buffers is controlled with +hooks. This includes the status and the refs buffers. For other +buffers, e.g. log and diff buffers, this is not possible. The command +‘magit-describe-section’ can be used to see which hook (if any) was +responsible for inserting the section at point. + + For buffers whose sections can be customized by the user, a hook +variable called ‘magit-TYPE-sections-hook’ exists. This hook should be +changed using ‘magit-add-section-hook’. Avoid using ‘add-hooks’ or the +Custom interface. + + The various available section hook variables are described later in +this manual along with the appropriate "section inserter functions". + + -- Function: magit-add-section-hook hook function &optional at append + local + + Add the function FUNCTION to the value of section hook HOOK. + + Add FUNCTION at the beginning of the hook list unless optional + APPEND is non-nil, in which case FUNCTION is added at the end. If + FUNCTION already is a member then move it to the new location. + + If optional AT is non-nil and a member of the hook list, then add + FUNCTION next to that instead. Add before or after AT, or replace + AT with FUNCTION depending on APPEND. If APPEND is the symbol + ‘replace’, then replace AT with FUNCTION. For any other non-nil + value place FUNCTION right after AT. If nil, then place FUNCTION + right before AT. If FUNCTION already is a member of the list but + AT is not, then leave FUNCTION where ever it already is. + + If optional LOCAL is non-nil, then modify the hook’s buffer-local + value rather than its global value. This makes the hook local by + copying the default value. That copy is then modified. + + HOOK should be a symbol. If HOOK is void, it is first set to nil. + HOOK’s value must not be a single hook function. FUNCTION should + be a function that takes no arguments and inserts one or multiple + sections at point, moving point forward. FUNCTION may choose not + to insert its section(s), when doing so would not make sense. It + should not be abused for other side-effects. + + To remove a function from a section hook, use ‘remove-hook’. + + +File: magit.info, Node: Section Types and Values, Next: Section Options, Prev: Section Hooks, Up: Sections + +4.2.4 Section Types and Values +------------------------------ + +Each section has a type, for example ‘hunk’, ‘file’, and ‘commit’. +Instances of certain section types also have a value. The value of a +section of type ‘file’, for example, is a file name. + + Users usually do not have to worry about a section’s type and value, +but knowing them can be handy at times. + +‘M-x magit-describe-section-briefly’ (‘magit-describe-section-briefly’) + + Show information about the section at point in the echo area, as + "#". + + Many commands behave differently depending on the type of the section +at point and/or somehow consume the value of that section. But that is +only one of the reasons why the same key may do something different, +depending on what section is current. + + Additionally for each section type a keymap *might* be defined, named +‘magit-TYPE-section-map’. That keymap is used as text property keymap +of all text belonging to any section of the respective type. If such a +map does not exist for a certain type, then you can define it yourself, +and it will automatically be used. + + +File: magit.info, Node: Section Options, Prev: Section Types and Values, Up: Sections + +4.2.5 Section Options +--------------------- + +This section describes options that have an effect on more than just a +certain type of sections. As you can see there are not many of those. + + -- User Option: magit-section-show-child-count + + Whether to append the number of children to section headings. This + only affects sections that could benefit from this information. + + +File: magit.info, Node: Transient Commands, Next: Transient Arguments and Buffer Variables, Prev: Sections, Up: Interface Concepts + +4.3 Transient Commands +====================== + +Many Magit commands are implemented as *transient* commands. First the +user invokes a *prefix* command, which causes its *infix* arguments and +*suffix* commands to be displayed in the echo area. The user then +optionally sets some infix arguments and finally invokes one of the +suffix commands. + + This is implemented in the library ‘transient’. Earlier Magit +releases used the package ‘magit-popup’ and even earlier versions +library ‘magit-key-mode’. + + Transient is documented in *note (transient)Top::. + +‘C-c C-c’ (‘magit-dispatch’) + + This transient prefix command binds most of Magit’s other prefix + commands as suffix commands and displays them in a temporary buffer + until one of them is invoked. Invoking such a sub-prefix causes + the suffixes of that command to be bound and displayed instead of + those of ‘magit-dispatch’. + + This command is also, or especially, useful outside Magit buffers, so +you should setup a global binding: + + (global-set-key (kbd "C-x M-g") 'magit-dispatch) + + +File: magit.info, Node: Transient Arguments and Buffer Variables, Next: Completion Confirmation and the Selection, Prev: Transient Commands, Up: Interface Concepts + +4.4 Transient Arguments and Buffer Variables +============================================ + +The infix arguments of many of Magit’s transient prefix commands cease +to have an effect once the ‘git’ command that is called with those +arguments has returned. Commands that create a commit are a good +example for this. If the user changes the arguments, then that only +affects the next invocation of a suffix command. If the same transient +prefix command is later invoked again, then the arguments are initially +reset to the default value. This default value can be set for the +current Emacs session or saved permanently, see *note (transient)Saving +Values::. It is also possible to cycle through previously used sets of +arguments using ‘M-p’ and ‘M-n’, see *note (transient)Using History::. + + However the infix arguments of many other transient commands continue +to have an effect even after the ‘git’ command that was called with +those arguments has returned. The most important commands like this are +those that display a diff or log in a dedicated buffer. Their arguments +obviously continue to have an effect for as long as the respective diff +or log is being displayed. Furthermore the used arguments are stored in +buffer-local variables for future reference. + + For commands in the second group it isn’t always desirable to reset +their arguments to the global value when the transient prefix command is +invoked again. + + As mentioned above, it is possible to cycle through previously used +sets of arguments while a transient popup is visible. That means that +we could always reset the infix arguments to the default because the set +of arguments that is active in the existing buffer is only a few ‘M-p’ +away. Magit can be configured to behave like that, but because I expect +that most users would not find that very convenient, it is not the +default. + + Also note that it is possible to change the diff and log arguments +used in the current buffer (including the status buffer, which contains +both diff and log sections) using the respective "refresh" transient +prefix commands on ‘D’ and ‘L’. (‘d’ and ‘l’ on the other hand are +intended to change *what* diff or log is being displayed. It is +possible to also change *how* the diff or log is being displayed at the +same time, but if you only want to do the latter, then you should use +the refresh variants.) Because these secondary diff and log transient +prefixes are about *changing* the arguments used in the current buffer, +they *always* start out with the set of arguments that are currently in +effect in that buffer. + + Some commands are usually invoked directly even though they can also +be invoked as the suffix of a transient prefix command. Most +prominently ‘magit-show-commit’ is usually invoked by typing ‘RET’ while +point is on a commit in a log, but it can also be invoked from the +‘magit-diff’ transient prefix. + + When such a command is invoked directly, then it is important to +reuse the arguments as specified by the respective buffer-local values, +instead of using the default arguments. Imagine you press ‘RET’ in a +log to display the commit at point in a different buffer and then use +‘D’ to change how the diff is displayed in that buffer. And then you +press ‘RET’ on another commit to show that instead and the diff +arguments are reset to the default. Not cool; so Magit does not do that +by default. + + -- User Option: magit-prefix-use-buffer-arguments + + This option controls whether the infix arguments initially shown in + certain transient prefix commands are based on the arguments that + are currently in effect in the buffer that their suffixes update. + + The ‘magit-diff’ and ‘magit-log’ transient prefix commands are + affected by this option. + + -- User Option: magit-direct-use-buffer-arguments + + This option controls whether certain commands, when invoked + directly (i.e. not as the suffix of a transient prefix command), + use the arguments that are currently active in the buffer that they + are about to update. The alternative is to use the default value + for these arguments, which might change the arguments that are used + in the buffer. + +Valid values for both of the above options are: + + • ‘always’: Always use the set of arguments that is currently active + in the respective buffer, provided that buffer exists of course. + + • ‘selected’ or ‘t’: Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default for both variables. + + • ‘current’: Use the set of arguments from the respective buffer, but + only if it is the current buffer. + + • ‘never’: Never use the set of arguments from the respective buffer. + +I am afraid it gets more complicated still: + + • The global diff and log arguments are set for each support mode + individually. The diff arguments for example have different values + in ‘magit-diff-mode’, ‘magit-revision-mode’, + ‘magit-merge-preview-mode’ and ‘magit-status-mode’ buffers. + Setting or saving the value for one mode does not change the value + for other modes. The history however is shared. + + • When ‘magit-show-commit’ is invoked directly from a log buffer, + then the file filter is picked up from that buffer, not from the + revision buffer and or the mode’s global diff arguments. + + • Even though they are suffixes of the diff prefix + ‘magit-show-commit’ and ‘magit-stash-show’ do not use the diff + buffer used by the diff commands, instead they use the dedicated + revision and stash buffers. + + At the time you invoke the diff prefix it is unknown to Magit which + of the suffix commands you are going to invoke. While not certain, + more often than not users invoke one of the commands that use the + diff buffer, so the initial infix arguments are those used in that + buffer. However if you invoke one of these commands directly, then + Magit knows that it should use the arguments from the revision + resp. stash buffer. + + • The log prefix also features reflog commands, but these commands do + not use the log arguments. + + • If ‘magit-show-refs’ is invoked from a ‘magit-refs-mode’ buffer, + then it acts as a refresh prefix and therefore unconditionally uses + the buffer’s arguments as initial arguments. If it is invoked + elsewhere with a prefix argument, then it acts as regular prefix + and therefore respects ‘magit-prefix-use-buffer-arguments’. If it + is invoked elsewhere without a prefix argument, then it acts as a + direct command and therefore respects + ‘magit-direct-use-buffer-arguments’. + + +File: magit.info, Node: Completion Confirmation and the Selection, Next: Running Git, Prev: Transient Arguments and Buffer Variables, Up: Interface Concepts + +4.5 Completion, Confirmation and the Selection +============================================== + +* Menu: + +* Action Confirmation:: +* Completion and Confirmation:: +* The Selection:: +* The hunk-internal region:: +* Support for Completion Frameworks:: +* Additional Completion Options:: + + +File: magit.info, Node: Action Confirmation, Next: Completion and Confirmation, Up: Completion Confirmation and the Selection + +4.5.1 Action Confirmation +------------------------- + +By default many actions that could potentially lead to data loss have to +be confirmed. This includes many very common actions, so this can +quickly become annoying. Many of these actions can be undone and if you +have thought about how to undo certain mistakes, then it should be safe +to disable confirmation for the respective actions. + + The option ‘magit-no-confirm’ can be used to tell Magit to perform +certain actions without the user having to confirm them. Note that +while this option can only be used to disable confirmation for a +specific set of actions, the next section explains another way of +telling Magit to ask fewer questions. + + -- User Option: magit-no-confirm + + The value of this option is a list of symbols, representing actions + that do not have to be confirmed by the user before being carried + out. + + By default many potentially dangerous commands ask the user for + confirmation. Each of the below symbols stands for an action + which, when invoked unintentionally or without being fully aware of + the consequences, could lead to tears. In many cases there are + several commands that perform variations of a certain action, so we + don’t use the command names but more generic symbols. + + • Applying changes: + + • ‘discard’ Discarding one or more changes (i.e. hunks or + the complete diff for a file) loses that change, + obviously. + + • ‘reverse’ Reverting one or more changes can usually be + undone by reverting the reversion. + + • ‘stage-all-changes’, ‘unstage-all-changes’ When there are + both staged and unstaged changes, then un-/staging + everything would destroy that distinction. Of course + that also applies when un-/staging a single change, but + then less is lost and one does that so often that having + to confirm every time would be unacceptable. + + • Files: + + • ‘delete’ When a file that isn’t yet tracked by Git is + deleted, then it is completely lost, not just the last + changes. Very dangerous. + + • ‘trash’ Instead of deleting a file it can also be move to + the system trash. Obviously much less dangerous than + deleting it. + + Also see option ‘magit-delete-by-moving-to-trash’. + + • ‘resurrect’ A deleted file can easily be resurrected by + "deleting" the deletion, which is done using the same + command that was used to delete the same file in the + first place. + + • ‘untrack’ Untracking a file can be undone by tracking it + again. + + • ‘rename’ Renaming a file can easily be undone. + + • Sequences: + + • ‘reset-bisect’ Aborting (known to Git as "resetting") a + bisect operation loses all information collected so far. + + • ‘abort-rebase’ Aborting a rebase throws away all already + modified commits, but it’s possible to restore those from + the reflog. + + • ‘abort-merge’ Aborting a merge throws away all conflict + resolutions which have already been carried out by the + user. + + • ‘merge-dirty’ Merging with a dirty worktree can make it + hard to go back to the state before the merge was + initiated. + + • References: + + • ‘delete-unmerged-branch’ Once a branch has been deleted, + it can only be restored using low-level recovery tools + provided by Git. And even then the reflog is gone. The + user always has to confirm the deletion of a branch by + accepting the default choice (or selecting another + branch), but when a branch has not been merged yet, also + make sure the user is aware of that. + + • ‘delete-pr-remote’ When deleting a branch that was + created from a pull-request and if no other branches + still exist on that remote, then ‘magit-branch-delete’ + offers to delete the remote as well. This should be safe + because it only happens if no other refs exist in the + remotes namespace, and you can recreate the remote if + necessary. + + • ‘drop-stashes’ Dropping a stash is dangerous because Git + stores stashes in the reflog. Once a stash is removed, + there is no going back without using low-level recovery + tools provided by Git. When a single stash is dropped, + then the user always has to confirm by accepting the + default (or selecting another). This action only + concerns the deletion of multiple stashes at once. + + • Edit published history: + + Without adding these symbols here, you will be warned before + editing commits that have already been pushed to one of the + branches listed in ‘magit-published-branches’. + + • ‘amend-published’ Affects most commands that amend to + "HEAD". + + • ‘rebase-published’ Affects commands that perform + interactive rebases. This includes commands from the + commit transient that modify a commit other than "HEAD", + namely the various fixup and squash variants. + + • ‘edit-published’ Affects the commands + ‘magit-edit-line-commit’ and + ‘magit-diff-edit-hunk-commit’. These two commands make + it quite easy to accidentally edit a published commit, so + you should think twice before configuring them not to ask + for confirmation. + + To disable confirmation completely, add all three symbols here + or set ‘magit-published-branches’ to ‘nil’. + + • Various: + + • ‘kill-process’ There seldom is a reason to kill a + process. + + • Global settings: + + Instead of adding all of the above symbols to the value of + this option, you can also set it to the atom ‘t’, which has + the same effect as adding all of the above symbols. Doing + that most certainly is a bad idea, especially because other + symbols might be added in the future. So even if you don’t + want to be asked for confirmation for any of these actions, + you are still better of adding all of the respective symbols + individually. + + When ‘magit-wip-before-change-mode’ is enabled, then the + following actions can be undone fairly easily: ‘discard’, + ‘reverse’, ‘stage-all-changes’, and ‘unstage-all-changes’. If + and only if this mode is enabled, then ‘safe-with-wip’ has the + same effect as adding all of these symbols individually. + + +File: magit.info, Node: Completion and Confirmation, Next: The Selection, Prev: Action Confirmation, Up: Completion Confirmation and the Selection + +4.5.2 Completion and Confirmation +--------------------------------- + +Many Magit commands ask the user to select from a list of possible +things to act on, while offering the most likely choice as the default. +For many of these commands the default is the thing at point, provided +that it actually is a valid thing to act on. For many commands that act +on a branch, the current branch serves as the default if there is no +branch at point. + + These commands combine asking for confirmation and asking for a +target to act on into a single action. The user can confirm the default +target using ‘RET’ or abort using ‘C-g’. This is similar to a +‘y-or-n-p’ prompt, but the keys to confirm or abort differ. + + At the same time the user is also given the opportunity to select +another target, which is useful because for some commands and/or in some +situations you might want to select the action before selecting the +target by moving to it. + + However you might find that for some commands you always want to use +the default target, if any, or even that you want the command to act on +the default without requiring any confirmation at all. The option +‘magit-dwim-selection’ can be used to configure certain commands to that +effect. + + Note that when the region is active then many commands act on the +things that are selected using a mechanism based on the region, in many +cases after asking for confirmation. This region-based mechanism is +called the "selection" and is described in detail in the next section. +When a selection exists that is valid for the invoked command, then that +command never offers to act on something else, and whether it asks for +confirmation is not controlled by this option. + + Also note that Magit asks for confirmation of certain actions that +are not coupled with completion (or the selection). Such dialogs are +also not affected by this option and are described in the previous +section. + + -- User Option: magit-dwim-selection + + This option can be used to tell certain commands to use the thing at +point instead of asking the user to select a candidate to act on, with +or without confirmation. + + The value has the form ‘((COMMAND nil|PROMPT DEFAULT)...)’. + + • COMMAND is the command that should not prompt for a choice. To + have an effect, the command has to use the function + ‘magit-completing-read’ or a utility function which in turn uses + that function. + + • If the command uses ‘magit-completing-read’ multiple times, then + PROMPT can be used to only affect one of these uses. PROMPT, if + non-nil, is a regular expression that is used to match against the + PROMPT argument passed to ‘magit-completing-read’. + + • DEFAULT specifies how to use the default. If it is ‘t’, then the + DEFAULT argument passed to ‘magit-completing-read’ is used without + confirmation. If it is ‘ask’, then the user is given a chance to + abort. DEFAULT can also be ‘nil’, in which case the entry has no + effect. + + +File: magit.info, Node: The Selection, Next: The hunk-internal region, Prev: Completion and Confirmation, Up: Completion Confirmation and the Selection + +4.5.3 The Selection +------------------- + +If the region is active, then many Magit commands act on the things that +are selected using a mechanism based on the region instead of one single +thing. When the region is not active, then these commands act on the +thing at point or read a single thing to act on. This is described in +the previous section — this section only covers how multiple things are +selected, how that is visualized, and how certain commands behave when +that is the case. + + Magit’s mechanism for selecting multiple things, or rather sections +that represent these things, is based on the Emacs region, but the area +that Magit considers to be selected is typically larger than the region +and additional restrictions apply. + + Magit makes a distinction between a region that qualifies as forming +a valid Magit selection and a region that does not. If the region does +not qualify, then it is displayed as it is in other Emacs buffers. If +the region does qualify as a Magit selection, then the selection is +always visualized, while the region itself is only visualized if it +begins and ends on the same line. + + For a region to qualify as a Magit selection, it must begin in the +heading of one section and end in the heading of a sibling section. +Note that if the end of the region is at the very beginning of section +heading (i.e. at the very beginning of a line) then that section is +considered to be *inside* the selection. + + This is not consistent with how the region is normally treated in +Emacs — if the region ends at the beginning of a line, then that line is +outside the region. Due to how Magit visualizes the selection, it +should be obvious that this difference exists. + + Not every command acts on every valid selection. Some commands do +not even consider the location of point, others may act on the section +at point but not support acting on the selection, and even commands that +do support the selection of course only do so if it selects things that +they can act on. + + This is the main reason why the selection must include the section at +point. Even if a selection exists, the invoked command may disregard +it, in which case it may act on the current section only. It is much +safer to only act on the current section but not the other selected +sections than it is to act on the current section *instead* of the +selected sections. The latter would be much more surprising and if the +current section always is part of the selection, then that cannot +happen. + + -- Variable: magit-keep-region-overlay + + This variable controls whether the region is visualized as usual + even when a valid Magit selection or a hunk-internal region exists. + See the doc-string for more information. + + +File: magit.info, Node: The hunk-internal region, Next: Support for Completion Frameworks, Prev: The Selection, Up: Completion Confirmation and the Selection + +4.5.4 The hunk-internal region +------------------------------ + +Somewhat related to the Magit selection described in the previous +section is the hunk-internal region. + + Like the selection, the hunk-internal region is based on the Emacs +region but causes that region to not be visualized as it would in other +Emacs buffers, and includes the line on which the region ends even if it +ends at the very beginning of that line. + + Unlike the selection, which is based on a region that must begin in +the heading of one section and ends in the section of a sibling section, +the hunk-internal region must begin inside the *body* of a hunk section +and end in the body of the *same* section. + + The hunk-internal region is honored by "apply" commands, which can, +among other targets, act on a hunk. If the hunk-internal region is +active, then such commands act only on the marked part of the hunk +instead of on the complete hunk. + + +File: magit.info, Node: Support for Completion Frameworks, Next: Additional Completion Options, Prev: The hunk-internal region, Up: Completion Confirmation and the Selection + +4.5.5 Support for Completion Frameworks +--------------------------------------- + +The built-in option ‘completing-read-function’ specifies the low-level +function used by ‘completing-read’ to ask a user to select from a list +of choices. Its default value is ‘completing-read-default’. +Alternative completion frameworks typically activate themselves by +substituting their own implementation. + + Mostly for historic reasons Magit provides a similar option named +‘magit-completing-read-function’, which only controls the low-level +function used by ‘magit-completing-read’. This option also makes it +possible to use a different completing mechanism for Magit than for the +rest of Emacs, but doing that is not recommend. + + You most likely don’t have to customize the magit-specific option to +use an alternative completion framework. For example, if you enable +‘ivy-mode’, then Magit will respect that, and if you enable ‘helm-mode’, +then you are done too. + + However if you want to use Ido, then ‘ido-mode’ won’t do the trick. +You will also have to install the ‘ido-completing-read+’ package and use +‘magit-ido-completing-read’ as ‘magit-completing-read-function’. + + -- User Option: magit-completing-read-function + + The value of this variable is the low-level function used to + perform completion by code that uses ‘magit-completing-read’ (as + opposed to the built-in ‘completing-read’). + + The default value, ‘magit-builtin-completing-read’, is suitable for + the standard completion mechanism, ‘ivy-mode’, and ‘helm-mode’ at + least. + + The built-in ‘completing-read’ and ‘completing-read-default’ are + *not* suitable to be used here. ‘magit-builtin-completing-read’ + performs some additional work, and any function used in its place + has to do the same. + + -- Function: magit-builtin-completing-read prompt choices &optional + predicate require-match initial-input hist def + + This function performs completion using the built-in + ‘completing-read’ and does some additional magit-specific work. + + -- Function: magit-ido-completing-read prompt choices &optional + predicate require-match initial-input hist def + + This function performs completion using ‘ido-completing-read+’ from + the package by the same name (which you have to explicitly install) + and does some additional magit-specific work. + + We have to use ‘ido-completing-read+’ instead of the + ‘ido-completing-read’ that comes with Ido itself, because the + latter, while intended as a drop-in replacement, cannot serve that + purpose because it violates too many of the implicit conventions. + + -- Function: magit-completing-read prompt choices &optional predicate + require-match initial-input hist def fallback + + This is the function that Magit commands use when they need the + user to select a single thing to act on. The arguments have the + same meaning as for ‘completing-read’, except for FALLBACK, which + is unique to this function and is described below. + + Instead of asking the user to choose from a list of possible + candidates, this function may just return the default specified by + DEF, with or without requiring user confirmation. Whether that is + the case depends on PROMPT, ‘this-command’ and + ‘magit-dwim-selection’. See the documentation of the latter for + more information. + + If it does read a value in the minibuffer, then this function acts + similar to ‘completing-read’, except for the following: + + • COLLECTION must be a list of choices. A function is not + supported. + + • If REQUIRE-MATCH is ‘nil’ and the user exits without a choice, + then ‘nil’ is returned instead of an empty string. + + • If REQUIRE-MATCH is non-nil and the users exits without a + choice, an user-error is raised. + + • FALLBACK specifies a secondary default that is only used if + the primary default DEF is ‘nil’. The secondary default is + not subject to ‘magit-dwim-selection’ — if DEF is ‘nil’ but + FALLBACK is not, then this function always asks the user to + choose a candidate, just as if both defaults were ‘nil’. + + • ": " is appended to PROMPT. + + • PROMPT is modified to end with \" (default DEF|FALLBACK): \" + provided that DEF or FALLBACK is non-nil, that neither + ‘ivy-mode’ nor ‘helm-mode’ is enabled, and that + ‘magit-completing-read-function’ is set to its default value + of ‘magit-builtin-completing-read’. + + +File: magit.info, Node: Additional Completion Options, Prev: Support for Completion Frameworks, Up: Completion Confirmation and the Selection + +4.5.6 Additional Completion Options +----------------------------------- + + -- User Option: magit-list-refs-sortby + + For many commands that read a ref or refs from the user, the value + of this option can be used to control the order of the refs. Valid + values include any key accepted by the ‘--sort’ flag of ‘git + for-each-ref’. By default, refs are sorted alphabetically by their + full name (e.g., "refs/heads/master"). + + +File: magit.info, Node: Running Git, Prev: Completion Confirmation and the Selection, Up: Interface Concepts + +4.6 Running Git +=============== + +* Menu: + +* Viewing Git Output:: +* Git Process Status:: +* Running Git Manually:: +* Git Executable:: +* Global Git Arguments:: + + +File: magit.info, Node: Viewing Git Output, Next: Git Process Status, Up: Running Git + +4.6.1 Viewing Git Output +------------------------ + +Magit runs Git either for side-effects (e.g. when pushing) or to get +some value (e.g. the name of the current branch). + + When Git is run for side-effects, the process output is logged in a +per-repository log buffer, which can be consulted using the +‘magit-process’ command when things don’t go as expected. + + The output/errors for up to ‘magit-process-log-max’ Git commands are +retained. + +‘$’ (‘magit-process’) + + This commands displays the process buffer for the current + repository. + + Inside that buffer, the usual key bindings for navigating and showing +sections are available. There is one additional command. + +‘k’ (‘magit-process-kill’) + + This command kills the process represented by the section at point. + + -- User Option: magit-git-debug + + When this is non-nil then the output of all calls to git are logged + in the process buffer. This is useful when debugging, otherwise it + just negatively affects performance. + + +File: magit.info, Node: Git Process Status, Next: Running Git Manually, Prev: Viewing Git Output, Up: Running Git + +4.6.2 Git Process Status +------------------------ + +When a Git process is running for side-effects, Magit displays an +indicator in the mode line, using the ‘magit-mode-line-process’ face. + + If the Git process exits successfully, the process indicator is +removed from the mode line immediately. + + In the case of a Git error, the process indicator is not removed, but +is instead highlighted with the ‘magit-mode-line-process-error’ face, +and the error details from the process buffer are provided as a tooltip +for mouse users. This error indicator persists in the mode line until +the next magit buffer refresh. + + If you do not wish process errors to be indicated in the mode line, +customize the ‘magit-process-display-mode-line-error’ user option. + + Process errors are additionally indicated at the top of the status +buffer. + + +File: magit.info, Node: Running Git Manually, Next: Git Executable, Prev: Git Process Status, Up: Running Git + +4.6.3 Running Git Manually +-------------------------- + +While Magit provides many Emacs commands to interact with Git, it does +not cover everything. In those cases your existing Git knowledge will +come in handy. Magit provides some commands for running arbitrary Git +commands by typing them into the minibuffer, instead of having to switch +to a shell. + +‘!’ (‘magit-run’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +‘! !’ (‘magit-git-command-topdir’) + + This command reads a command from the user and executes it in the + top-level directory of the current working tree. + + The string "git " is used as initial input when prompting the user + for the command. It can be removed to run another command. + +‘! p’ (‘magit-git-command’) + + This command reads a command from the user and executes it in + ‘default-directory’. With a prefix argument the command is + executed in the top-level directory of the current working tree + instead. + + The string "git " is used as initial input when prompting the user + for the command. It can be removed to run another command. + +‘! s’ (‘magit-shell-command-topdir’) + + This command reads a command from the user and executes it in the + top-level directory of the current working tree. + +‘! S’ (‘magit-shell-command’) + + This command reads a command from the user and executes it in + ‘default-directory’. With a prefix argument the command is + executed in the top-level directory of the current working tree + instead. + + -- User Option: magit-shell-command-verbose-prompt + + Whether the prompt, used by the above commands when reading a shell + command, shows the directory in which it will be run. + + These suffix commands start external gui tools. + +‘! k’ (‘magit-run-gitk’) + + This command runs ‘gitk’ in the current repository. + +‘! a’ (‘magit-run-gitk-all’) + + This command runs ‘gitk --all’ in the current repository. + +‘! b’ (‘magit-run-gitk-branches’) + + This command runs ‘gitk --branches’ in the current repository. + +‘! g’ (‘magit-run-git-gui’) + + This command runs ‘git gui’ in the current repository. + + +File: magit.info, Node: Git Executable, Next: Global Git Arguments, Prev: Running Git Manually, Up: Running Git + +4.6.4 Git Executable +-------------------- + +Except on MS Windows, Magit defaults to running Git without specifying +the path to the git executable. Instead the first executable found by +Emacs on ‘exec-path’ is used (whose value in turn is set based on the +value of the environment variable ‘$PATH’ when Emacs was started). + + This has the advantage that it continues to work even when using +Tramp to connect to a remote machine on which the executable is found in +a different place. The downside is that if you have multiple versions +of Git installed, then you might end up using another version than the +one you think you are using. + +‘M-x magit-version’ (‘magit-version’) + + This command shows the currently used versions of Magit, Git, and + Emacs in the echo area. Non-interactively this just returns the + Magit version. + + When the ‘system-type’ is ‘windows-nt’, then ‘magit-git-executable’ +is set to an absolute path when Magit is first loaded. This is +necessary because Git on that platform comes with several wrapper +scripts for the actual git binary, which are also placed on ‘$PATH’, and +using one of these wrappers instead of the binary would degrade +performance horribly. + + If Magit doesn’t find the correct executable then you *can* work +around that by setting ‘magit-git-executable’ to an absolute path. But +note that doing so is a kludge. It is better to make sure the order in +the environment variable ‘$PATH’ is correct, and that Emacs is started +with that environment in effect. The command +‘magit-debug-git-executable’ can be useful to find out where Emacs is +searching for git. If you have to connect from Windows to a non-Windows +machine, then you must change the value to "git". + + -- User Option: magit-git-executable + + The git executable used by Magit, either the full path to the + executable or the string "git" to let Emacs find the executable + itself, using the standard mechanism for doing such things. + +‘M-x magit-debug-git-executable’ (‘magit-debug-git-executable’) + + Display a buffer with information about ‘magit-git-executable’. + + +File: magit.info, Node: Global Git Arguments, Prev: Git Executable, Up: Running Git + +4.6.5 Global Git Arguments +-------------------------- + + -- User Option: magit-git-global-arguments + + The arguments set here are used every time the git executable is + run as a subprocess. They are placed right after the executable + itself and before the git command - as in ‘git HERE... COMMAND + REST’. For valid arguments see *note (gitman)git::. + + Be careful what you add here, especially if you are using Tramp to + connect to servers with ancient Git versions. Never remove + anything that is part of the default value, unless you really know + what you are doing. And think very hard before adding something; + it will be used every time Magit runs Git for any purpose. + + +File: magit.info, Node: Inspecting, Next: Manipulating, Prev: Interface Concepts, Up: Top + +5 Inspecting +************ + +The functionality provided by Magit can be roughly divided into three +groups: inspecting existing data, manipulating existing data or adding +new data, and transferring data. Of course that is a rather crude +distinction that often falls short, but it’s more useful than no +distinction at all. This section is concerned with inspecting data, the +next two with manipulating and transferring it. Then follows a section +about miscellaneous functionality, which cannot easily be fit into this +distinction. + + Of course other distinctions make sense too, e.g. Git’s distinction +between porcelain and plumbing commands, which for the most part is +equivalent to Emacs’ distinction between interactive commands and +non-interactive functions. All of the sections mentioned before are +mainly concerned with the porcelain – Magit’s plumbing layer is +described later. + +* Menu: + +* Status Buffer:: +* Repository List:: +* Logging:: +* Diffing:: +* Ediffing:: +* References Buffer:: +* Bisecting:: +* Visiting Files and Blobs:: +* Blaming:: + + +File: magit.info, Node: Status Buffer, Next: Repository List, Up: Inspecting + +5.1 Status Buffer +================= + +While other Magit buffers contain e.g. one particular diff or one +particular log, the status buffer contains the diffs for staged and +unstaged changes, logs for unpushed and unpulled commits, lists of +stashes and untracked files, and information related to the current +branch. + + During certain incomplete operations – for example when a merge +resulted in a conflict – additional information is displayed that helps +proceeding with or aborting the operation. + + The command ‘magit-status’ displays the status buffer belonging to +the current repository in another window. This command is used so often +that it should be bound globally. We recommend using ‘C-x g’: + + (global-set-key (kbd "C-x g") 'magit-status) + +‘C-x g’ (‘magit-status’) + + When invoked from within an existing Git repository, then this + command shows the status of that repository in a buffer. + + If the current directory isn’t located within a Git repository, + then this command prompts for an existing repository or an + arbitrary directory, depending on the option + ‘magit-repository-directories’, and the status for the selected + repository is shown instead. + + • If that option specifies any existing repositories, then the + user is asked to select one of them. + + • Otherwise the user is asked to select an arbitrary directory + using regular file-name completion. If the selected directory + is the top-level directory of an existing working tree, then + the status buffer for that is shown. + + • Otherwise the user is offered to initialize the selected + directory as a new repository. After creating the repository + its status buffer is shown. + + These fallback behaviors can also be forced using one or more + prefix arguments: + + • With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) an arbitrary directory is read, which + is then acted on as described above. The same could be + accomplished using the command ‘magit-init’. + + • With a single prefix argument an existing repository is read + from the user, or if no repository can be found based on the + value of ‘magit-repository-directories’, then the behavior is + the same as with two prefix arguments. + + -- User Option: magit-repository-directories + + List of directories that are Git repositories or contain Git + repositories. + + Each element has the form ‘(DIRECTORY . DEPTH)’. DIRECTORY has to + be a directory or a directory file-name, a string. DEPTH, an + integer, specifies the maximum depth to look for Git repositories. + If it is 0, then only add DIRECTORY itself. + + This option controls which repositories are being listed by + ‘magit-list-repositories’. It also affects ‘magit-status’ (which + see) in potentially surprising ways (see above). + + -- Command: ido-enter-magit-status + + From an Ido prompt used to open a file, instead drop into + ‘magit-status’. This is similar to ‘ido-magic-delete-char’, which, + despite its name, usually causes a Dired buffer to be created. + + To make this command available, use something like: + + (add-hook 'ido-setup-hook + (lambda () + (define-key ido-completion-map + (kbd \"C-x g\") 'ido-enter-magit-status))) + + Starting with Emacs 25.1 the Ido keymaps are defined just once + instead of every time Ido is invoked, so now you can modify it like + pretty much every other keymap: + + (define-key ido-common-completion-map + (kbd \"C-x g\") 'ido-enter-magit-status) + +* Menu: + +* Status Sections:: +* Status Header Sections:: +* Status Module Sections:: +* Status Options:: + + +File: magit.info, Node: Status Sections, Next: Status Header Sections, Up: Status Buffer + +5.1.1 Status Sections +--------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’. See *note Section Hooks:: to learn about +such hooks and how to customize them. + + -- User Option: magit-status-sections-hook + + Hook run to insert sections into a status buffer. + + The first function on that hook by default is +‘magit-insert-status-headers’; it is described in the next section. By +default the following functions are also members of that hook: + + -- Function: magit-insert-merge-log + + Insert section for the on-going merge. Display the heads that are + being merged. If no merge is in progress, do nothing. + + -- Function: magit-insert-rebase-sequence + + Insert section for the on-going rebase sequence. If no such + sequence is in progress, do nothing. + + -- Function: magit-insert-am-sequence + + Insert section for the on-going patch applying sequence. If no + such sequence is in progress, do nothing. + + -- Function: magit-insert-sequencer-sequence + + Insert section for the on-going cherry-pick or revert sequence. If + no such sequence is in progress, do nothing. + + -- Function: magit-insert-bisect-output + + While bisecting, insert section with output from ‘git bisect’. + + -- Function: magit-insert-bisect-rest + + While bisecting, insert section visualizing the bisect state. + + -- Function: magit-insert-bisect-log + + While bisecting, insert section logging bisect progress. + + -- Function: magit-insert-untracked-files + + Maybe insert a list or tree of untracked files. + + Do so depending on the value of ‘status.showUntrackedFiles’. Note + that even if the value is ‘all’, Magit still initially only shows + directories. But the directory sections can then be expanded using + ‘TAB’. + + -- Function: magit-insert-unstaged-changes + + Insert section showing unstaged changes. + + -- Function: magit-insert-staged-changes + + Insert section showing staged changes. + + -- Function: magit-insert-stashes &optional ref heading + + Insert the ‘stashes’ section showing reflog for "refs/stash". If + optional REF is non-nil show reflog for that instead. If optional + HEADING is non-nil use that as section heading instead of + "Stashes:". + + -- Function: magit-insert-unpulled-from-upstream + + Insert section showing commits that haven’t been pulled from the + upstream branch yet. + + -- Function: magit-insert-unpulled-from-pushremote + + Insert section showing commits that haven’t been pulled from the + push-remote branch yet. + + -- Function: magit-insert-unpushed-to-upstream + + Insert section showing commits that haven’t been pushed to the + upstream yet. + + -- Function: magit-insert-unpushed-to-pushremote + + Insert section showing commits that haven’t been pushed to the + push-remote yet. + + The following functions can also be added to the above hook: + + -- Function: magit-insert-tracked-files + + Insert a tree of tracked files. + + -- Function: magit-insert-ignored-files + + Insert a tree of ignored files. Its possible to limit the logs in + the current buffer to a certain directory using ‘D = f + RET g’. If you do that, then that that also affects this command. + + The log filter can be used to limit to multiple files. In that + case this function only respects the first of the files and only if + it is a directory. + + -- Function: magit-insert-skip-worktree-files + + Insert a tree of skip-worktree files. If the first element of + ‘magit-buffer-diff-files’ is a directory, then limit the list to + files below that. The value of that variable can be set using ‘D + -- DIRECTORY RET g’. + + -- Function: magit-insert-assumed-unchanged-files + + Insert a tree of files that are assumed to be unchanged. If the + first element of ‘magit-buffer-diff-files’ is a directory, then + limit the list to files below that. The value of that variable can + be set using ‘D -- DIRECTORY RET g’. + + -- Function: magit-insert-unpulled-or-recent-commits + + Insert section showing unpulled or recent commits. If an upstream + is configured for the current branch and it is ahead of the current + branch, then show the missing commits. Otherwise, show the last + ‘magit-log-section-commit-count’ commits. + + -- Function: magit-insert-recent-commits + + Insert section showing the last ‘magit-log-section-commit-count’ + commits. + + -- User Option: magit-log-section-commit-count + + How many recent commits ‘magit-insert-recent-commits’ and + ‘magit-insert-unpulled-or-recent-commits’ (provided there are no + unpulled commits) show. + + -- Function: magit-insert-unpulled-cherries + + Insert section showing unpulled commits. Like + ‘magit-insert-unpulled-commits’ but prefix each commit that has not + been applied yet (i.e. a commit with a patch-id not shared with + any local commit) with "+", and all others with "-". + + -- Function: magit-insert-unpushed-cherries + + Insert section showing unpushed commits. Like + ‘magit-insert-unpushed-commits’ but prefix each commit which has + not been applied to upstream yet (i.e. a commit with a patch-id + not shared with any upstream commit) with "+" and all others with + "-". + + See *note References Buffer:: for some more section inserters, which +could be used here. + + +File: magit.info, Node: Status Header Sections, Next: Status Module Sections, Prev: Status Sections, Up: Status Buffer + +5.1.2 Status Header Sections +---------------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’ (see *note Status Sections::). + + By default ‘magit-insert-status-headers’ is the first member of that +hook variable. + + -- Function: magit-insert-status-headers + + Insert headers sections appropriate for ‘magit-status-mode’ + buffers. The sections are inserted by running the functions on the + hook ‘magit-status-headers-hook’. + + -- User Option: magit-status-headers-hook + + Hook run to insert headers sections into the status buffer. + + This hook is run by ‘magit-insert-status-headers’, which in turn + has to be a member of ‘magit-status-sections-hook’ to be used at + all. + + By default the following functions are members of the above hook: + + -- Function: magit-insert-error-header + + Insert a header line showing the message about the Git error that + just occurred. + + This function is only aware of the last error that occur when Git + was run for side-effects. If, for example, an error occurs while + generating a diff, then that error won’t be inserted. Refreshing + the status buffer causes this section to disappear again. + + -- Function: magit-insert-diff-filter-header + + Insert a header line showing the effective diff filters. + + -- Function: magit-insert-head-branch-header + + Insert a header line about the current branch or detached ‘HEAD’. + + -- Function: magit-insert-upstream-branch-header + + Insert a header line about the branch that is usually pulled into + the current branch. + + -- Function: magit-insert-push-branch-header + + Insert a header line about the branch that the current branch is + usually pushed to. + + -- Function: magit-insert-tags-header + + Insert a header line about the current and/or next tag, along with + the number of commits between the tag and ‘HEAD’. + + The following functions can also be added to the above hook: + + -- Function: magit-insert-repo-header + + Insert a header line showing the path to the repository top-level. + + -- Function: magit-insert-remote-header + + Insert a header line about the remote of the current branch. + + If no remote is configured for the current branch, then fall back + showing the "origin" remote, or if that does not exist the first + remote in alphabetic order. + + -- Function: magit-insert-user-header + + Insert a header line about the current user. + + +File: magit.info, Node: Status Module Sections, Next: Status Options, Prev: Status Header Sections, Up: Status Buffer + +5.1.3 Status Module Sections +---------------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’ (see *note Status Sections::). + + By default ‘magit-insert-modules’ is _not_ a member of that hook +variable. + + -- Function: magit-insert-modules + + Insert submodule sections. + + Hook ‘magit-module-sections-hook’ controls which module sections + are inserted, and option ‘magit-module-sections-nested’ controls + whether they are wrapped in an additional section. + + -- User Option: magit-module-sections-hook + + Hook run by ‘magit-insert-modules’. + + -- User Option: magit-module-sections-nested + + This option controls whether ‘magit-insert-modules’ wraps inserted + sections in an additional section. + + If this is non-nil, then only a single top-level section is + inserted. If it is nil, then all sections listed in + ‘magit-module-sections-hook’ become top-level sections. + + -- Function: magit-insert-modules-overview + + Insert sections for all submodules. For each section insert the + path, the branch, and the output of ‘git describe --tags’, or, + failing that, the abbreviated HEAD commit hash. + + Press ‘RET’ on such a submodule section to show its own status + buffer. Press ‘RET’ on the "Modules" section to display a list of + submodules in a separate buffer. This shows additional information + not displayed in the super-repository’s status buffer. + + -- Function: magit-insert-modules-unpulled-from-upstream + + Insert sections for modules that haven’t been pulled from the + upstream yet. These sections can be expanded to show the + respective commits. + + -- Function: magit-insert-modules-unpulled-from-pushremote + + Insert sections for modules that haven’t been pulled from the + push-remote yet. These sections can be expanded to show the + respective commits. + + -- Function: magit-insert-modules-unpushed-to-upstream + + Insert sections for modules that haven’t been pushed to the + upstream yet. These sections can be expanded to show the + respective commits. + + -- Function: magit-insert-modules-unpushed-to-pushremote + + Insert sections for modules that haven’t been pushed to the + push-remote yet. These sections can be expanded to show the + respective commits. + + +File: magit.info, Node: Status Options, Prev: Status Module Sections, Up: Status Buffer + +5.1.4 Status Options +-------------------- + + -- User Option: magit-status-refresh-hook + + Hook run after a status buffer has been refreshed. + + -- User Option: magit-status-margin + + This option specifies whether the margin is initially shown in + Magit-Status mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + Also see the proceeding section for more options concerning status +buffers. + + +File: magit.info, Node: Repository List, Next: Logging, Prev: Status Buffer, Up: Inspecting + +5.2 Repository List +=================== + + -- Command: magit-list-repositories + + This command displays a list of repositories in a separate buffer. + + The options ‘magit-repository-directories’ and + ‘magit-repository-directories-depth’ control which repositories are + displayed. + + -- User Option: magit-repolist-columns + + This option controls what columns are displayed by the command + ‘magit-list-repositories’ and how they are displayed. + + Each element has the form ‘(HEADER WIDTH FORMAT PROPS)’. + + HEADER is the string displayed in the header. WIDTH is the width + of the column. FORMAT is a function that is called with one + argument, the repository identification (usually its basename), and + with ‘default-directory’ bound to the toplevel of its working tree. + It has to return a string to be inserted or nil. PROPS is an alist + that supports the keys ‘:right-align’ and ‘:pad-right’. + + The following functions can be added to the above option: + + -- Function: magit-repolist-column-ident + + This function inserts the identification of the repository. + Usually this is just its basename. + + -- Function: magit-repolist-column-path + + This function inserts the absolute path of the repository. + + -- Function: magit-repolist-column-version + + This function inserts a description of the repository’s ‘HEAD’ + revision. + + -- Function: magit-repolist-column-branch + + This function inserts the name of the current branch. + + -- Function: magit-repolist-column-upstream + + This function inserts the name of the upstream branch of the + current branch. + + -- Function: magit-repolist-column-branches + + This function inserts the number of branches. + + -- Function: magit-repolist-column-stashes + + This function inserts the number of stashes. + + -- Function: magit-repolist-column-flag + + This function inserts a flag as specified by + ‘magit-repolist-column-flag-alist’. + + By default this indicates whether there are uncommitted changes. + + • ‘N’ if there is at least one untracked file. + + • ‘U’ if there is at least one unstaged file. + + • ‘S’ if there is at least one staged file. + + Only the first one of these that applies is shown. + + -- Function: magit-repolist-column-unpulled-from-upstream + + This function inserts the number of upstream commits not in the + current branch. + + -- Function: magit-repolist-column-unpulled-from-pushremote + + This function inserts the number of commits in the push branch but + not the current branch. + + -- Function: magit-repolist-column-unpushed-to-upstream + + This function inserts the number of commits in the current branch + but not its upstream. + + -- Function: magit-repolist-column-unpushed-to-pushremote + + This function inserts the number of commits in the current branch + but not its push branch. + + +File: magit.info, Node: Logging, Next: Diffing, Prev: Repository List, Up: Inspecting + +5.3 Logging +=========== + +The status buffer contains logs for the unpushed and unpulled commits, +but that obviously isn’t enough. The transient prefix command +‘magit-log’, on ‘l’, features several suffix commands, which show a +specific log in a separate log buffer. + + Like other transient prefix commands, ‘magit-log’ also features +several infix arguments that can be changed before invoking one of the +suffix commands. However, in the case of the log transient, these +arguments may be taken from those currently in use in the current +repository’s log buffer, depending on the value of +‘magit-prefix-use-buffer-arguments’ (see *note Transient Arguments and +Buffer Variables::). + + For information about the various arguments, see *note +(gitman)git-log::. + + The switch ‘++order=VALUE’ is converted to one of +‘--author-date-order’, ‘--date-order’, or ‘--topo-order’ before being +passed to ‘git log’. + + The log transient also features several reflog commands. See *note +Reflog::. + +‘l’ (‘magit-log’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘l l’ (‘magit-log-current’) + + Show log for the current branch. When ‘HEAD’ is detached or with a + prefix argument, show log for one or more revs read from the + minibuffer. + +‘l o’ (‘magit-log-other’) + + Show log for one or more revs read from the minibuffer. The user + can input any revision or revisions separated by a space, or even + ranges, but only branches, tags, and a representation of the commit + at point are available as completion candidates. + +‘l h’ (‘magit-log-head’) + + Show log for ‘HEAD’. + +‘l L’ (‘magit-log-branches’) + + Show log for all local branches and ‘HEAD’. + +‘l b’ (‘magit-log-all-branches’) + + Show log for all local and remote branches and ‘HEAD’. + +‘l a’ (‘magit-log-all’) + + Show log for all references and ‘HEAD’. + + Two additional commands that show the log for the file or blob that +is being visited in the current buffer exists, see *note Minor Mode for +Buffers Visiting Files::. The command ‘magit-cherry’ also shows a log, +see *note Cherries::. + +* Menu: + +* Refreshing Logs:: +* Log Buffer:: +* Log Margin:: +* Select from Log:: +* Reflog:: +* Cherries:: + + +File: magit.info, Node: Refreshing Logs, Next: Log Buffer, Up: Logging + +5.3.1 Refreshing Logs +--------------------- + +The transient prefix command ‘magit-log-refresh’, on ‘L’, can be used to +change the log arguments used in the current buffer, without changing +which log is shown. This works in dedicated log buffers, but also in +the status buffer. + +‘L’ (‘magit-log-refresh’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘L g’ (‘magit-log-refresh’) + + This suffix command sets the local log arguments for the current + buffer. + +‘L s’ (‘magit-log-set-default-arguments’) + + This suffix command sets the default log arguments for buffers of + the same type as that of the current buffer. Other existing + buffers of the same type are not affected because their local + values have already been initialized. + +‘L w’ (‘magit-log-save-default-arguments’) + + This suffix command sets the default log arguments for buffers of + the same type as that of the current buffer, and saves the value + for future sessions. Other existing buffers of the same type are + not affected because their local values have already been + initialized. + +‘L t’ (‘magit-toggle-margin’) + + Show or hide the margin. + + +File: magit.info, Node: Log Buffer, Next: Log Margin, Prev: Refreshing Logs, Up: Logging + +5.3.2 Log Buffer +---------------- + +‘L’ (‘magit-log-refresh’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + See *note Refreshing Logs::. + +‘q’ (‘magit-log-bury-buffer’) + + Bury the current buffer or the revision buffer in the same frame. + Like ‘magit-mode-bury-buffer’ (which see) but with a negative + prefix argument instead bury the revision buffer, provided it is + displayed in the current frame. + +‘C-c C-b’ (‘magit-go-backward’) + + Move backward in current buffer’s history. + +‘C-c C-f’ (‘magit-go-forward’) + + Move forward in current buffer’s history. + +‘C-c C-n’ (‘magit-log-move-to-parent’) + + Move to a parent of the current commit. By default, this is the + first parent, but a numeric prefix can be used to specify another + parent. + +‘SPC’ (‘magit-diff-show-or-scroll-up’) + + Update the commit or diff buffer for the thing at point. + + Either show the commit or stash at point in the appropriate buffer, + or if that buffer is already being displayed in the current frame + and contains information about that commit or stash, then instead + scroll the buffer up. If there is no commit or stash at point, + then prompt for a commit. + +‘DEL’ (‘magit-diff-show-or-scroll-down’) + + Update the commit or diff buffer for the thing at point. + + Either show the commit or stash at point in the appropriate buffer, + or if that buffer is already being displayed in the current frame + and contains information about that commit or stash, then instead + scroll the buffer down. If there is no commit or stash at point, + then prompt for a commit. + +‘=’ (‘magit-log-toggle-commit-limit’) + + Toggle the number of commits the current log buffer is limited to. + If the number of commits is currently limited, then remove that + limit. Otherwise set it to 256. + +‘+’ (‘magit-log-double-commit-limit’) + + Double the number of commits the current log buffer is limited to. + +‘-’ (‘magit-log-half-commit-limit’) + + Half the number of commits the current log buffer is limited to. + + -- User Option: magit-log-auto-more + + Insert more log entries automatically when moving past the last + entry. Only considered when moving past the last entry with + ‘magit-goto-*-section’ commands. + + -- User Option: magit-log-show-refname-after-summary + + Whether to show the refnames after the commit summaries. This is + useful if you use really long branch names. + + Magit displays references in logs a bit differently from how Git does +it. + + Local branches are blue and remote branches are green. Of course +that depends on the used theme, as do the colors used for other types of +references. The current branch has a box around it, as do remote +branches that are their respective remote’s ‘HEAD’ branch. + + If a local branch and its push-target point at the same commit, then +their names are combined to preserve space and to make that relationship +visible. For example: + + origin/feature + [green][blue-] + + instead of + + feature origin/feature + [blue-] [green-------] + + Also note that while the transient features the ‘--show-signature’ +argument, that won’t actually be used when enabled, because Magit +defaults to use just one line per commit. Instead the commit colorized +to indicate the validity of the signed commit object, using the faces +named ‘magit-signature-*’ (which see). + + For a description of ‘magit-log-margin’ see *note Log Margin::. + + +File: magit.info, Node: Log Margin, Next: Select from Log, Prev: Log Buffer, Up: Logging + +5.3.3 Log Margin +---------------- + +In buffers which show one or more logs, it is possible to show +additional information about each commit in the margin. The options +used to configure the margin are named ‘magit-INFIX-margin’, where INFIX +is the same as in the respective major-mode ‘magit-INFIX-mode’. In +regular log buffers that would be ‘magit-log-margin’. + + -- User Option: magit-log-margin + + This option specifies whether the margin is initially shown in + Magit-Log mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + You can change the STYLE and AUTHOR-WIDTH of all ‘magit-INFIX-margin’ +options to the same values by customizing ‘magit-log-margin’ *before* +‘magit’ is loaded. If you do that, then the respective values for the +other options will default to what you have set for that variable. +Likewise if you set INIT in ‘magit-log-margin’ to ‘nil’, then that is +used in the default of all other options. But setting it to ‘t’, i.e. +re-enforcing the default for that option, does not carry to other +options. + + -- User Option: magit-log-margin-show-committer-date + + This option specifies whether to show the committer date in the + margin. This option only controls whether the committer date is + displayed instead of the author date. Whether some date is + displayed in the margin and whether the margin is displayed at all + is controlled by other options. + +‘L’ (‘magit-margin-settings’) + + This transient prefix command binds the following suffix commands, + each of which changes the appearance of the margin in some way. + + In some buffers that support the margin, ‘L’ is instead bound to +‘magit-log-refresh’, but that transient features the same commands, and +then some other unrelated commands. + +‘L L’ (‘magit-toggle-margin’) + + This command shows or hides the margin. + +‘L l’ (‘magit-cycle-margin-style’) + + This command cycles the style used for the margin. + +‘L d’ (‘magit-toggle-margin-details’) + + This command shows or hides details in the margin. + + +File: magit.info, Node: Select from Log, Next: Reflog, Prev: Log Margin, Up: Logging + +5.3.4 Select from Log +--------------------- + +When the user has to select a recent commit that is reachable from +‘HEAD’, using regular completion would be inconvenient (because most +humans cannot remember hashes or "HEAD~5", at least not without double +checking). Instead a log buffer is used to select the commit, which has +the advantage that commits are presented in order and with the commit +message. + + Such selection logs are used when selecting the beginning of a rebase +and when selecting the commit to be squashed into. + + In addition to the key bindings available in all log buffers, the +following additional key bindings are available in selection log +buffers: + +‘C-c C-c’ (‘magit-log-select-pick’) + + Select the commit at point and act on it. Call + ‘magit-log-select-pick-function’ with the selected commit as + argument. + +‘C-c C-k’ (‘magit-log-select-quit’) + + Abort selecting a commit, don’t act on any commit. + + -- User Option: magit-log-select-margin + + This option specifies whether the margin is initially shown in + Magit-Log-Select mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: magit.info, Node: Reflog, Next: Cherries, Prev: Select from Log, Up: Logging + +5.3.5 Reflog +------------ + +Also see *note (gitman)git-reflog::. + + These reflog commands are available from the log transient. See +*note Logging::. + +‘l r’ (‘magit-reflog-current’) + + Display the reflog of the current branch. + +‘l O’ (‘magit-reflog-other’) + + Display the reflog of a branch or another ref. + +‘l H’ (‘magit-reflog-head’) + + Display the ‘HEAD’ reflog. + + -- User Option: magit-reflog-margin + + This option specifies whether the margin is initially shown in + Magit-Reflog mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: magit.info, Node: Cherries, Prev: Reflog, Up: Logging + +5.3.6 Cherries +-------------- + +Cherries are commits that haven’t been applied upstream (yet), and are +usually visualized using a log. Each commit is prefixed with ‘-’ if it +has an equivalent in the upstream and ‘+’ if it does not, i.e. if it is +a cherry. + + The command ‘magit-cherry’ shows cherries for a single branch, but +the references buffer (see *note References Buffer::) can show cherries +for multiple "upstreams" at once. + + Also see *note (gitman)git-reflog::. + +‘Y’ (‘magit-cherry’) + + Show commits that are in a certain branch but that have not been + merged in the upstream branch. + + -- User Option: magit-cherry-margin + + This option specifies whether the margin is initially shown in + Magit-Cherry mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: magit.info, Node: Diffing, Next: Ediffing, Prev: Logging, Up: Inspecting + +5.4 Diffing +=========== + +The status buffer contains diffs for the staged and unstaged commits, +but that obviously isn’t enough. The transient prefix command +‘magit-diff’, on ‘d’, features several suffix commands, which show a +specific diff in a separate diff buffer. + + Like other transient prefix commands, ‘magit-diff’ also features +several infix arguments that can be changed before invoking one of the +suffix commands. However, in the case of the diff transient, these +arguments may be taken from those currently in use in the current +repository’s diff buffer, depending on the value of +‘magit-prefix-use-buffer-arguments’ (see *note Transient Arguments and +Buffer Variables::). + + Also see *note (gitman)git-diff::. + +‘d’ (‘magit-diff’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘d d’ (‘magit-diff-dwim’) + + Show changes for the thing at point. + +‘d r’ (‘magit-diff-range’) + + Show differences between two commits. + + RANGE should be a range (A..B or A...B) but can also be a single + commit. If one side of the range is omitted, then it defaults to + ‘HEAD’. If just a commit is given, then changes in the working + tree relative to that commit are shown. + + If the region is active, use the revisions on the first and last + line of the region. With a prefix argument, instead of diffing the + revisions, choose a revision to view changes along, starting at the + common ancestor of both revisions (i.e., use a "..." range). + +‘d w’ (‘magit-diff-working-tree’) + + Show changes between the current working tree and the ‘HEAD’ + commit. With a prefix argument show changes between the working + tree and a commit read from the minibuffer. + +‘d s’ (‘magit-diff-staged’) + + Show changes between the index and the ‘HEAD’ commit. With a + prefix argument show changes between the index and a commit read + from the minibuffer. + +‘d u’ (‘magit-diff-unstaged’) + + Show changes between the working tree and the index. + +‘d p’ (‘magit-diff-paths’) + + Show changes between any two files on disk. + + All of the above suffix commands update the repository’s diff buffer. +The diff transient also features two commands which show differences in +another buffer: + +‘d c’ (‘magit-show-commit’) + + Show the commit at point. If there is no commit at point or with a + prefix argument, prompt for a commit. + +‘d t’ (‘magit-stash-show’) + + Show all diffs of a stash in a buffer. + + Two additional commands that show the diff for the file or blob that +is being visited in the current buffer exists, see *note Minor Mode for +Buffers Visiting Files::. + +* Menu: + +* Refreshing Diffs:: +* Commands Available in Diffs:: +* Diff Options:: +* Revision Buffer:: + + +File: magit.info, Node: Refreshing Diffs, Next: Commands Available in Diffs, Up: Diffing + +5.4.1 Refreshing Diffs +---------------------- + +The transient prefix command ‘magit-diff-refresh’, on ‘D’, can be used +to change the diff arguments used in the current buffer, without +changing which diff is shown. This works in dedicated diff buffers, but +also in the status buffer. + +‘D’ (‘magit-diff-refresh’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘D g’ (‘magit-diff-refresh’) + + This suffix command sets the local diff arguments for the current + buffer. + +‘D s’ (‘magit-diff-set-default-arguments’) + + This suffix command sets the default diff arguments for buffers of + the same type as that of the current buffer. Other existing + buffers of the same type are not affected because their local + values have already been initialized. + +‘D w’ (‘magit-diff-save-default-arguments’) + + This suffix command sets the default diff arguments for buffers of + the same type as that of the current buffer, and saves the value + for future sessions. Other existing buffers of the same type are + not affected because their local values have already been + initialized. + +‘D t’ (‘magit-diff-toggle-refine-hunk’) + + This command toggles hunk refinement on or off. + +‘D r’ (‘magit-diff-switch-range-type’) + + This command converts the diff range type from "revA..revB" to + "revB...revA", or vice versa. + +‘D f’ (‘magit-diff-flip-revs’) + + This command swaps revisions in the diff range from "revA..revB" to + "revB..revA", or vice versa. + +‘D F’ (‘magit-diff-toggle-file-filter’) + + This command toggles the file restriction of the diffs in the + current buffer, allowing you to quickly switch between viewing all + the changes in the commit and the restricted subset. As a special + case, when this command is called from a log buffer, it toggles the + file restriction in the repository’s revision buffer, which is + useful when you display a revision from a log buffer that is + restricted to a file or files. + + In addition to the above transient, which allows changing any of the +supported arguments, there also exist some commands that change only a +particular argument. + +‘-’ (‘magit-diff-less-context’) + + This command decreases the context for diff hunks by COUNT lines. + +‘+’ (‘magit-diff-more-context’) + + This command increases the context for diff hunks by COUNT lines. + +‘0’ (‘magit-diff-default-context’) + + This command resets the context for diff hunks to the default + height. + + The following commands quickly change what diff is being displayed +without having to using one of the diff transient. + +‘C-c C-d’ (‘magit-diff-while-committing’) + + While committing, this command shows the changes that are about to + be committed. While amending, invoking the command again toggles + between showing just the new changes or all the changes that will + be committed. + + This binding is available in the diff buffer as well as the commit + message buffer. + +‘C-c C-b’ (‘magit-go-backward’) + + This command moves backward in current buffer’s history. + +‘C-c C-f’ (‘magit-go-forward’) + + This command moves forward in current buffer’s history. + + +File: magit.info, Node: Commands Available in Diffs, Next: Diff Options, Prev: Refreshing Diffs, Up: Diffing + +5.4.2 Commands Available in Diffs +--------------------------------- + +Some commands are only available if point is inside a diff. + + ‘magit-diff-visit-file’ and related commands visit the appropriate +version of the file that the diff at point is about. Likewise +‘magit-diff-visit-worktree-file’ and related commands visit the worktree +version of the file that the diff at point is about. See *note Visiting +Files and Blobs from a Diff:: for more information and the key bindings. + +‘C-c C-t’ (‘magit-diff-trace-definition’) + + This command shows a log for the definition at point. + + -- User Option: magit-log-trace-definition-function + + The function specified by this option is used by + ‘magit-log-trace-definition’ to determine the function at point. + For major-modes that have special needs, you could set the local + value using the mode’s hook. + +‘C-c C-e’ (‘magit-diff-edit-hunk-commit’) + + From a hunk, this command edits the respective commit and visits + the file. + + First it visits the file being modified by the hunk at the correct + location using ‘magit-diff-visit-file’. This actually visits a + blob. When point is on a diff header, not within an individual + hunk, then this visits the blob the first hunk is about. + + Then it invokes ‘magit-edit-line-commit’, which uses an interactive + rebase to make the commit editable, or if that is not possible + because the commit is not reachable from ‘HEAD’ by checking out + that commit directly. This also causes the actual worktree file to + be visited. + + Neither the blob nor the file buffer are killed when finishing the + rebase. If that is undesirable, then it might be better to use + ‘magit-rebase-edit-command’ instead of this command. + +‘j’ (‘magit-jump-to-diffstat-or-diff’) + + This command jumps to the diffstat or diff. When point is on a + file inside the diffstat section, then jump to the respective diff + section. Otherwise, jump to the diffstat section or a child + thereof. + + The next two commands are not specific to Magit-Diff mode (or and +Magit buffer for that matter), but it might be worth pointing out that +they are available here too. + +‘SPC’ (‘scroll-up’) + + This command scrolls text upward. + +‘DEL’ (‘scroll-down’) + + This command scrolls text downward. + + +File: magit.info, Node: Diff Options, Next: Revision Buffer, Prev: Commands Available in Diffs, Up: Diffing + +5.4.3 Diff Options +------------------ + + -- User Option: magit-diff-refine-hunk + + Whether to show word-granularity differences within diff hunks. + + • ‘nil’ Never show fine differences. + + • ‘t’ Show fine differences for the current diff hunk only. + + • ‘all’ Show fine differences for all displayed diff hunks. + + -- User Option: magit-diff-refine-ignore-whitespace + + Whether to ignore whitespace changes in word-granularity + differences. + + -- User Option: magit-diff-adjust-tab-width + + Whether to adjust the width of tabs in diffs. + + Determining the correct width can be expensive if it requires + opening large and/or many files, so the widths are cached in the + variable ‘magit-diff--tab-width-cache’. Set that to nil to + invalidate the cache. + + • ‘nil’ Never adjust tab width. Use ‘tab-width’s value from the + Magit buffer itself instead. + + • ‘t’ If the corresponding file-visiting buffer exits, then use + ‘tab-width’’s value from that buffer. Doing this is cheap, so + this value is used even if a corresponding cache entry exists. + + • ‘always’ If there is no such buffer, then temporarily visit + the file to determine the value. + + • NUMBER Like ‘always’, but don’t visit files larger than NUMBER + bytes. + + -- User Option: magit-diff-paint-whitespace + + Specify where to highlight whitespace errors. + + See ‘magit-diff-highlight-trailing’, + ‘magit-diff-highlight-indentation’. The symbol ‘t’ means in all + diffs, ‘status’ means only in the status buffer, and nil means + nowhere. + + • ‘nil’ Never highlight whitespace errors. + + • ‘t’ Highlight whitespace errors everywhere. + + • ‘uncommitted’ Only highlight whitespace errors in diffs + showing uncommitted changes. For backward compatibility + ‘status’ is treated as a synonym. + + -- User Option: magit-diff-paint-whitespace-lines + + Specify in what kind of lines to highlight whitespace errors. + + • ‘t’ Highlight only in added lines. + + • ‘both’ Highlight in added and removed lines. + + • ‘all’ Highlight in added, removed and context lines. + + -- User Option: magit-diff-highlight-trailing + + Whether to highlight whitespace at the end of a line in diffs. + Used only when ‘magit-diff-paint-whitespace’ is non-nil. + + -- User Option: magit-diff-highlight-indentation + + This option controls whether to highlight the indentation in case + it used the "wrong" indentation style. Indentation is only + highlighted if ‘magit-diff-paint-whitespace’ is also non-nil. + + The value is an alist of the form ‘((REGEXP . INDENT)...)’. The + path to the current repository is matched against each element in + reverse order. Therefore if a REGEXP matches, then earlier + elements are not tried. + + If the used INDENT is ‘tabs’, highlight indentation with tabs. If + INDENT is an integer, highlight indentation with at least that many + spaces. Otherwise, highlight neither. + + -- User Option: magit-diff-hide-trailing-cr-characters + + Whether to hide ^M characters at the end of a line in diffs. + + -- User Option: magit-diff-highlight-hunk-region-functions + + This option specifies the functions used to highlight the + hunk-internal region. + + ‘magit-diff-highlight-hunk-region-dim-outside’ overlays the outside + of the hunk internal selection with a face that causes the added + and removed lines to have the same background color as context + lines. This function should not be removed from the value of this + option. + + ‘magit-diff-highlight-hunk-region-using-overlays’ and + ‘magit-diff-highlight-hunk-region-using-underline’ emphasize the + region by placing delimiting horizontal lines before and after it. + Both of these functions have glitches which cannot be fixed due to + limitations of Emacs’ display engine. For more information see + ff. + + Instead of, or in addition to, using delimiting horizontal lines, + to emphasize the boundaries, you may which to emphasize the text + itself, using ‘magit-diff-highlight-hunk-region-using-face’. + + In terminal frames it’s not possible to draw lines as the overlay + and underline variants normally do, so there they fall back to + calling the face function instead. + + -- User Option: magit-diff-unmarked-lines-keep-foreground + + This option controls whether added and removed lines outside the + hunk-internal region only lose their distinct background color or + also the foreground color. Whether the outside of the region is + dimmed at all depends on + ‘magit-diff-highlight-hunk-region-functions’. + + +File: magit.info, Node: Revision Buffer, Prev: Diff Options, Up: Diffing + +5.4.4 Revision Buffer +--------------------- + + -- User Option: magit-revision-insert-related-refs + + Whether to show related branches in revision buffers. + + • ‘nil’ Don’t show any related branches. + + • ‘t’ Show related local branches. + + • ‘all’ Show related local and remote branches. + + • ‘mixed’ Show all containing branches and local merged + branches. + + -- User Option: magit-revision-show-gravatars + + Whether to show gravatar images in revision buffers. + + If ‘nil’, then don’t insert any gravatar images. If ‘t’, then + insert both images. If ‘author’ or ‘committer’, then insert only + the respective image. + + If you have customized the option ‘magit-revision-headers-format’ + and want to insert the images then you might also have to specify + where to do so. In that case the value has to be a cons-cell of + two regular expressions. The car specifies where to insert the + author’s image. The top half of the image is inserted right after + the matched text, the bottom half on the next line in the same + column. The cdr specifies where to insert the committer’s image, + accordingly. Either the car or the cdr may be nil." + + -- User Option: magit-revision-use-hash-sections + + Whether to turn hashes inside the commit message into sections. + + If non-nil, then hashes inside the commit message are turned into + ‘commit’ sections. There is a trade off to be made between + performance and reliability: + + • ‘slow’ calls git for every word to be absolutely sure. + + • ‘quick’ skips words less than seven characters long. + + • ‘quicker’ additionally skips words that don’t contain a + number. + + • ‘quickest’ uses all words that are at least seven characters + long and which contain at least one number as well as at least + one letter. + + If nil, then no hashes are turned into sections, but you can still + visit the commit at point using "RET". + + The diffs shown in the revision buffer may be automatically +restricted to a subset of the changed files. If the revision buffer is +displayed from a log buffer, the revision buffer will share the same +file restriction as that log buffer (also see the command +‘magit-diff-toggle-file-filter’). + + -- User Option: magit-revision-filter-files-on-follow + + Whether showing a commit from a log buffer honors the log’s file + filter when the log arguments include ‘--follow’. + + When this option is nil, displaying a commit from a log ignores the + log’s file filter if the log arguments include ‘--follow’. Doing + so avoids showing an empty diff in revision buffers for commits + before a rename event. In such cases, the ‘--patch’ argument of + the log transient can be used to show the file-restricted diffs + inline. + + Set this option to non-nil to keep the log’s file restriction even + if ‘--follow’ is present in the log arguments. + + If the revision buffer is not displayed from a log buffer, the file +restriction is determined as usual (see *note Transient Arguments and +Buffer Variables::). + + +File: magit.info, Node: Ediffing, Next: References Buffer, Prev: Diffing, Up: Inspecting + +5.5 Ediffing +============ + +This section describes how to enter Ediff from Magit buffers. For +information on how to use Ediff itself, see *note (ediff)Top::. + +‘e’ (‘magit-ediff-dwim’) + + Compare, stage, or resolve using Ediff. + + This command tries to guess what file, and what commit or range the + user wants to compare, stage, or resolve using Ediff. It might + only be able to guess either the file, or range/commit, in which + case the user is asked about the other. It might not always guess + right, in which case the appropriate ‘magit-ediff-*’ command has to + be used explicitly. If it cannot read the user’s mind at all, then + it asks the user for a command to run. + +‘E’ (‘magit-ediff’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +‘E r’ (‘magit-ediff-compare’) + + Compare two revisions of a file using Ediff. + + If the region is active, use the revisions on the first and last + line of the region. With a prefix argument, instead of diffing the + revisions, choose a revision to view changes along, starting at the + common ancestor of both revisions (i.e., use a "..." range). + +‘E m’ (‘magit-ediff-resolve’) + + Resolve outstanding conflicts in a file using Ediff, defaulting to + the file at point. + + Provided that the value of ‘merge.conflictstyle’ is ‘diff3’, you + can view the file’s merge-base revision using ‘/’ in the Ediff + control buffer. + + In the rare event that you want to manually resolve all conflicts, + including those already resolved by Git, use + ‘ediff-merge-revisions-with-ancestor’. + +‘E s’ (‘magit-ediff-stage’) + + Stage and unstage changes to a file using Ediff, defaulting to the + file at point. + +‘E u’ (‘magit-ediff-show-unstaged’) + + Show unstaged changes to a file using Ediff. + +‘E i’ (‘magit-ediff-show-staged’) + + Show staged changes to a file using Ediff. + +‘E w’ (‘magit-ediff-show-working-tree’) + + Show changes in a file between ‘HEAD’ and working tree using Ediff. + +‘E c’ (‘magit-ediff-show-commit’) + + Show changes to a file introduced by a commit using Ediff. + +‘E z’ (‘magit-ediff-show-stash’) + + Show changes to a file introduced by a stash using Ediff. + + -- User Option: magit-ediff-dwim-show-on-hunks + + This option controls what command ‘magit-ediff-dwim’ calls when + point is on uncommitted hunks. When nil, always run + ‘magit-ediff-stage’. Otherwise, use ‘magit-ediff-show-staged’ and + ‘magit-ediff-show-unstaged’ to show staged and unstaged changes, + respectively. + + -- User Option: magit-ediff-show-stash-with-index + + This option controls whether ‘magit-ediff-show-stash’ includes a + buffer containing the file’s state in the index at the time the + stash was created. This makes it possible to tell which changes in + the stash were staged. + + -- User Option: magit-ediff-quit-hook + + This hook is run after quitting an Ediff session that was created + using a Magit command. The hook functions are run inside the Ediff + control buffer, and should not change the current buffer. + + This is similar to ‘ediff-quit-hook’ but takes the needs of Magit + into account. The regular ‘ediff-quit-hook’ is ignored by Ediff + sessions that were created using a Magit command. + + +File: magit.info, Node: References Buffer, Next: Bisecting, Prev: Ediffing, Up: Inspecting + +5.6 References Buffer +===================== + +‘y’ (‘magit-show-refs’) + + This command lists branches and tags in a dedicated buffer. + + However if this command is invoked again from this buffer or if it + is invoked with a prefix argument, then it acts as a transient + prefix command, which binds the following suffix commands and some + infix arguments. + + All of the following suffix commands list exactly the same branches +and tags. The only difference the optional feature that can be enabled +by changing the value of ‘magit-refs-show-commit-count’ (see below). +These commands specify a different branch or commit against which all +the other references are compared. + +‘y y’ (‘magit-show-refs-head’) + + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with ‘HEAD’. + +‘y c’ (‘magit-show-refs-current’) + + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with the current branch or ‘HEAD’ if it + is detached. + +‘y o’ (‘magit-show-refs-other’) + + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with a branch read from the user. + + -- User Option: magit-refs-show-commit-count + + Whether to show commit counts in Magit-Refs mode buffers. + + • ‘all’ Show counts for branches and tags. + + • ‘branch’ Show counts for branches only. + + • ‘nil’ Never show counts. + + The default is ‘nil’ because anything else can be very expensive. + + -- User Option: magit-refs-pad-commit-counts + + Whether to pad all commit counts on all sides in Magit-Refs mode + buffers. + + If this is nil, then some commit counts are displayed right next to + one of the branches that appear next to the count, without any + space in between. This might look bad if the branch name faces + look too similar to ‘magit-dimmed’. + + If this is non-nil, then spaces are placed on both sides of all + commit counts. + + -- User Option: magit-refs-show-remote-prefix + + Whether to show the remote prefix in lists of remote branches. + + Showing the prefix is redundant because the name of the remote is + already shown in the heading preceding the list of its branches. + + -- User Option: magit-refs-primary-column-width + + Width of the primary column in ‘magit-refs-mode’ buffers. The + primary column is the column that contains the name of the branch + that the current row is about. + + If this is an integer, then the column is that many columns wide. + Otherwise it has to be a cons-cell of two integers. The first + specifies the minimal width, the second the maximal width. In that + case the actual width is determined using the length of the names + of the shown local branches. (Remote branches and tags are not + taken into account when calculating to optimal width.) + + -- User Option: magit-refs-focus-column-width + + Width of the focus column in ‘magit-refs-mode’ buffers. + + The focus column is the first column, which marks one branch + (usually the current branch) as the focused branch using ‘*’ or + ‘@’. For each other reference, this column optionally shows how + many commits it is ahead of the focused branch and ‘<’, or if it + isn’t ahead then the commits it is behind and ‘>’, or if it isn’t + behind either, then a ‘=’. + + This column may also display only ‘*’ or ‘@’ for the focused + branch, in which case this option is ignored. Use ‘L v’ to change + the verbosity of this column. + + -- User Option: magit-refs-margin + + This option specifies whether the margin is initially shown in + Magit-Refs mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + -- User Option: magit-refs-margin-for-tags + + This option specifies whether to show information about tags in the + margin. This is disabled by default because it is slow if there + are many tags. + + The following variables control how individual refs are displayed. +If you change one of these variables (especially the "%c" part), then +you should also change the others to keep things aligned. The following +%-sequences are supported: + + • ‘%a’ Number of commits this ref has over the one we compare to. + + • ‘%b’ Number of commits the ref we compare to has over this one. + + • ‘%c’ Number of commits this ref has over the one we compare to. + For the ref which all other refs are compared this is instead "@", + if it is the current branch, or "#" otherwise. + + • ‘%C’ For the ref which all other refs are compared this is "@", if + it is the current branch, or "#" otherwise. For all other refs " + ". + + • ‘%h’ Hash of this ref’s tip. + + • ‘%m’ Commit summary of the tip of this ref. + + • ‘%n’ Name of this ref. + + • ‘%u’ Upstream of this local branch. + + • ‘%U’ Upstream of this local branch and additional local vs. + upstream information. + + -- User Option: magit-refs-filter-alist + + The purpose of this option is to forgo displaying certain refs + based on their name. If you want to not display any refs of a + certain type, then you should remove the appropriate function from + ‘magit-refs-sections-hook’ instead. + + This alist controls which tags and branches are omitted from being + displayed in ‘magit-refs-mode’ buffers. If it is ‘nil’, then all + refs are displayed (subject to ‘magit-refs-sections-hook’). + + All keys are tried in order until one matches. Then its value is + used and subsequent elements are ignored. If the value is non-nil, + then the reference is displayed, otherwise it is not. If no + element matches, then the reference is displayed. + + A key can either be a regular expression that the refname has to + match, or a function that takes the refname as only argument and + returns a boolean. A remote branch such as "origin/master" is + displayed as just "master", however for this comparison the former + is used. + +‘RET’ (‘magit-visit-ref’) + + This command visits the reference or revision at point in another + buffer. If there is no revision at point or with a prefix argument + then it prompts for a revision. + + This command behaves just like ‘magit-show-commit’ as described + above, except if point is on a reference in a ‘magit-refs-mode’ + buffer, in which case the behavior may be different, but only if + you have customized the option ‘magit-visit-ref-behavior’. + + -- User Option: magit-visit-ref-behavior + + This option controls how ‘magit-visit-ref’ behaves in + ‘magit-refs-mode’ buffers. + + By default ‘magit-visit-ref’ behaves like ‘magit-show-commit’, in + all buffers, including ‘magit-refs-mode’ buffers. When the type of + the section at point is ‘commit’ then "RET" is bound to + ‘magit-show-commit’, and when the type is either ‘branch’ or ‘tag’ + then it is bound to ‘magit-visit-ref’. + + "RET" is one of Magit’s most essential keys and at least by default + it should behave consistently across all of Magit, especially + because users quickly learn that it does something very harmless; + it shows more information about the thing at point in another + buffer. + + However "RET" used to behave differently in ‘magit-refs-mode’ + buffers, doing surprising things, some of which cannot really be + described as "visit this thing". If you’ve grown accustomed this + behavior, you can restore it by adding one or more of the below + symbols to the value of this option. But keep in mind that by + doing so you don’t only introduce inconsistencies, you also lose + some functionality and might have to resort to ‘M-x + magit-show-commit’ to get it back. + + ‘magit-visit-ref’ looks for these symbols in the order in which + they are described here. If the presence of a symbol applies to + the current situation, then the symbols that follow do not affect + the outcome. + + • ‘focus-on-ref’ + + With a prefix argument update the buffer to show commit counts + and lists of cherry commits relative to the reference at point + instead of relative to the current buffer or ‘HEAD’. + + Instead of adding this symbol, consider pressing "C-u y o + RET". + + • ‘create-branch’ + + If point is on a remote branch, then create a new local branch + with the same name, use the remote branch as its upstream, and + then check out the local branch. + + Instead of adding this symbol, consider pressing "b c RET + RET", like you would do in other buffers. + + • ‘checkout-any’ + + Check out the reference at point. If that reference is a tag + or a remote branch, then this results in a detached ‘HEAD’. + + Instead of adding this symbol, consider pressing "b b RET", + like you would do in other buffers. + + • ‘checkout-branch’ + + Check out the local branch at point. + + Instead of adding this symbol, consider pressing "b b RET", + like you would do in other buffers. + +* Menu: + +* References Sections:: + + +File: magit.info, Node: References Sections, Up: References Buffer + +5.6.1 References Sections +------------------------- + +The contents of references buffers is controlled using the hook +‘magit-refs-sections-hook’. See *note Section Hooks:: to learn about +such hooks and how to customize them. All of the below functions are +members of the default value. Note that it makes much less sense to +customize this hook than it does for the respective hook used for the +status buffer. + + -- User Option: magit-refs-sections-hook + + Hook run to insert sections into a references buffer. + + -- Function: magit-insert-local-branches + + Insert sections showing all local branches. + + -- Function: magit-insert-remote-branches + + Insert sections showing all remote-tracking branches. + + -- Function: magit-insert-tags + + Insert sections showing all tags. + + +File: magit.info, Node: Bisecting, Next: Visiting Files and Blobs, Prev: References Buffer, Up: Inspecting + +5.7 Bisecting +============= + +Also see *note (gitman)git-bisect::. + +‘B’ (‘magit-bisect’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + When bisecting is not in progress, then the transient features the +following suffix commands. + +‘B B’ (‘magit-bisect-start’) + + Start a bisect session. + + Bisecting a bug means to find the commit that introduced it. This + command starts such a bisect session by asking for a known good and + a bad commit. + +‘B s’ (‘magit-bisect-run’) + + Bisect automatically by running commands after each step. + + When bisecting in progress, then the transient instead features the +following suffix commands. + +‘B b’ (‘magit-bisect-bad’) + + Mark the current commit as bad. Use this after you have asserted + that the commit does contain the bug in question. + +‘B g’ (‘magit-bisect-good’) + + Mark the current commit as good. Use this after you have asserted + that the commit does not contain the bug in question. + +‘B k’ (‘magit-bisect-skip’) + + Skip the current commit. Use this if for some reason the current + commit is not a good one to test. This command lets Git choose a + different one. + +‘B r’ (‘magit-bisect-reset’) + + After bisecting, cleanup bisection state and return to original + ‘HEAD’. + + By default the status buffer shows information about the ongoing +bisect session. + + -- User Option: magit-bisect-show-graph + + This option controls whether a graph is displayed for the log of + commits that still have to be bisected. + + +File: magit.info, Node: Visiting Files and Blobs, Next: Blaming, Prev: Bisecting, Up: Inspecting + +5.8 Visiting Files and Blobs +============================ + +Magit provides several commands that visit a file or blob (the version +of a file that is stored in a certain commit). Actually it provides +several *groups* of such commands and the several *variants* within each +group. + +* Menu: + +* General-Purpose Visit Commands:: +* Visiting Files and Blobs from a Diff:: + + +File: magit.info, Node: General-Purpose Visit Commands, Next: Visiting Files and Blobs from a Diff, Up: Visiting Files and Blobs + +5.8.1 General-Purpose Visit Commands +------------------------------------ + +These commands can be used anywhere to open any blob. Currently no keys +are bound to these commands by default, but that is likely to change. + + -- Command: magit-find-file + + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in the + selected window. + + -- Command: magit-find-file-other-window + + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in + another window. + + -- Command: magit-find-file-other-frame + + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in + another frame. + + +File: magit.info, Node: Visiting Files and Blobs from a Diff, Prev: General-Purpose Visit Commands, Up: Visiting Files and Blobs + +5.8.2 Visiting Files and Blobs from a Diff +------------------------------------------ + +These commands can only be used when point is inside a diff. + +‘RET’ (‘magit-diff-visit-file’) + + This command visits the appropriate version of the file that the + diff at point is about. + + This commands visits the worktree version of the appropriate file. + The location of point inside the diff determines which file is + being visited. The visited version depends on what changes the + diff is about. + + • If the diff shows uncommitted changes (i.e. staged or + unstaged changes), then visit the file in the working tree + (i.e. the same "real" file that ‘find-file’ would visit. In + all other cases visit a "blob" (i.e. the version of a file as + stored in some commit). + + • If point is on a removed line, then visit the blob for the + first parent of the commit that removed that line, i.e. the + last commit where that line still exists. + + • If point is on an added or context line, then visit the blob + that adds that line, or if the diff shows from more than a + single commit, then visit the blob from the last of these + commits. + + In the file-visiting buffer this command goes to the line that + corresponds to the line that point is on in the diff. + + The buffer is displayed in the selected window. With a prefix + argument the buffer is displayed in another window instead. + + -- User Option: magit-diff-visit-previous-blob + + This option controls whether ‘magit-diff-visit-file’ may visit the + previous blob. When this is ‘t’ (the default) and point is on a + removed line in a diff for a committed change, then + ‘magit-diff-visit-file’ visits the blob from the last revision + which still had that line. + + Currently this is only supported for committed changes, for staged + and unstaged changes ‘magit-diff-visit-file’ always visits the file + in the working tree. + +‘C-’ (‘magit-diff-visit-file-worktree’) + + This command visits the worktree version of the appropriate file. + The location of point inside the diff determines which file is + being visited. Unlike ‘magit-diff-visit-file’ it always visits the + "real" file in the working tree, i.e the "current version" of the + file. + + In the file-visiting buffer this command goes to the line that + corresponds to the line that point is on in the diff. Lines that + were added or removed in the working tree, the index and other + commits in between are automatically accounted for. + + The buffer is displayed in the selected window. With a prefix + argument the buffer is displayed in another window instead. + + Variants of the above two commands exist that instead visit the file +in another window or in another frame. If you prefer such behavior, +then you may want to change the above key bindings, but note that the +above commands also use another window when invoked with a prefix +argument. + + -- Command: magit-diff-visit-file-other-window + -- Command: magit-diff-visit-file-other-frame + -- Command: magit-diff-visit-worktree-file-other-window + -- Command: magit-diff-visit-worktree-file-other-frame + + +File: magit.info, Node: Blaming, Prev: Visiting Files and Blobs, Up: Inspecting + +5.9 Blaming +=========== + +Also see *note (gitman)git-blame::. + + To start blaming invoke the ‘magit-file-dispatch’ transient prefix +command by pressing ‘C-c M-g’. (This is only the default binding and +the recommended binding is ‘C-c g’. Also neither binding may be +available if you disabled ‘global-magit-file-mode’. Also see *note +Minor Mode for Buffers Visiting Files::.) + + The blaming suffix commands can be invoked from the dispatch +transient. However if you want to set an infix argument, then you have +to enter the blaming sub-transient first. + + The key bindings shown below assume that you enter the dispatch +transient using the default binding. + +‘C-c M-g B’ (‘magit-blame’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + Note that not all of the following suffixes are available at all +times. For example if ‘magit-blame-mode’ is not enabled, then the +command whose purpose is to turn off that mode would not be of any use +and therefore isn’t available. + +‘C-c M-g b’ (‘magit-blame-addition’) +‘C-c M-g B b’ (‘magit-blame-addition’) + + This command augments each line or chunk of lines in the current + file-visiting or blob-visiting buffer with information about what + commits last touched these lines. + + If the buffer visits a revision of that file, then history up to + that revision is considered. Otherwise, the file’s full history is + considered, including uncommitted changes. + + If Magit-Blame mode is already turned on in the current buffer then + blaming is done recursively, by visiting REVISION:FILE (using + ‘magit-find-file’), where REVISION is a parent of the revision that + added the current line or chunk of lines. + +‘C-c M-g r’ (‘magit-blame-removal’) +‘C-c M-g B r’ (‘magit-blame-removal’) + + This command augments each line or chunk of lines in the current + blob-visiting buffer with information about the revision that + removes it. It cannot be used in file-visiting buffers. + + Like ‘magit-blame-addition’, this command can be used recursively. + +‘C-c M-g f’ (‘magit-blame-reverse’) +‘C-c M-g B f’ (‘magit-blame-reverse’) + + This command augments each line or chunk of lines in the current + file-visiting or blob-visiting buffer with information about the + last revision in which a line still existed. + + Like ‘magit-blame-addition’, this command can be used recursively. + +‘C-c M-g e’ (‘magit-blame-echo’) +‘C-c M-g B e’ (‘magit-blame-echo’) + + This command is like ‘magit-blame-addition’ except that it doesn’t + turn on ‘read-only-mode’ and that it initially uses the + visualization style specified by option ‘magit-blame-echo-style’. + + The following key bindings are available when Magit-Blame mode is +enabled and Read-Only mode is not enabled. These commands are also +available in other buffers; here only the behavior is described that is +relevant in file-visiting buffers that are being blamed. + +‘RET’ (‘magit-show-commit’) + + This command shows the commit that last touched the line at point. + +‘SPC’ (‘magit-diff-show-or-scroll-up’) + + This command updates the commit buffer. + + This either shows the commit that last touched the line at point in + the appropriate buffer, or if that buffer is already being + displayed in the current frame and if that buffer contains + information about that commit, then the buffer is scrolled up + instead. + +‘DEL’ (‘magit-diff-show-or-scroll-down’) + + This command updates the commit buffer. + + This either shows the commit that last touched the line at point in + the appropriate buffer, or if that buffer is already being + displayed in the current frame and if that buffer contains + information about that commit, then the buffer is scrolled down + instead. + + The following key bindings are available when both Magit-Blame mode +and Read-Only mode are enabled. + +‘b’ (‘magit-blame’) + + See above. + +‘n’ (‘magit-blame-next-chunk’) + + This command moves to the next chunk. + +‘N’ (‘magit-blame-next-chunk-same-commit’) + + This command moves to the next chunk from the same commit. + +‘p’ (‘magit-blame-previous-chunk’) + + This command moves to the previous chunk. + +‘P’ (‘magit-blame-previous-chunk-same-commit’) + + This command moves to the previous chunk from the same commit. + +‘q’ (‘magit-blame-quit’) + + This command turns off Magit-Blame mode. If the buffer was created + during a recursive blame, then it also kills the buffer. + +‘M-w’ (‘magit-blame-copy-hash’) + + This command saves the hash of the current chunk’s commit to the + kill ring. + + When the region is active, the command saves the region’s content + instead of the hash, like ‘kill-ring-save’ would. + +‘c’ (‘magit-blame-cycle-style’) + + This command changes how blame information is visualized in the + current buffer by cycling through the styles specified using the + option ‘magit-blame-styles’. + + Blaming is also controlled using the following options. + + -- User Option: magit-blame-styles + + This option defines a list of styles used to visualize blame + information. For now see its doc-string to learn more. + + -- User Option: magit-blame-echo-style + + This option specifies the blame visualization style used by the + command ‘magit-blame-echo’. This must be a symbol that is used as + the identifier for one of the styles defined in + ‘magit-blame-styles’. + + -- User Option: magit-blame-time-format + + This option specifies the format string used to display times when + showing blame information. + + -- User Option: magit-blame-read-only + + This option controls whether blaming a buffer also makes + temporarily read-only. + + -- User Option: magit-blame-disable-modes + + This option lists incompatible minor-modes that should be disabled + temporarily when a buffer contains blame information. They are + enabled again when the buffer no longer shows blame information. + + -- User Option: magit-blame-goto-chunk-hook + + This hook is run when moving between chunks. + + +File: magit.info, Node: Manipulating, Next: Transferring, Prev: Inspecting, Up: Top + +6 Manipulating +************** + +* Menu: + +* Creating Repository:: +* Cloning Repository:: +* Staging and Unstaging:: +* Applying:: +* Committing:: +* Branching:: +* Merging:: +* Resolving Conflicts:: +* Rebasing:: +* Cherry Picking:: +* Resetting:: +* Stashing:: + + +File: magit.info, Node: Creating Repository, Next: Cloning Repository, Up: Manipulating + +6.1 Creating Repository +======================= + +‘M-x magit-init’ (‘magit-init’) + + This command initializes a repository and then shows the status + buffer for the new repository. + + If the directory is below an existing repository, then the user has + to confirm that a new one should be created inside. If the + directory is the root of the existing repository, then the user has + to confirm that it should be reinitialized. + + +File: magit.info, Node: Cloning Repository, Next: Staging and Unstaging, Prev: Creating Repository, Up: Manipulating + +6.2 Cloning Repository +====================== + +To clone a remote or local repository use ‘C’, which is bound to the +command ‘magit-clone’. This command either act as a transient prefix +command, which binds several infix arguments and suffix commands, or it +can invoke ‘git clone’ directly, depending on whether a prefix argument +is used and on the value of ‘magit-clone-always-transient’. + + -- User Option: magit-clone-always-transient + + This option controls whether the command ‘magit-clone’ always acts + as a transient prefix command, regardless of whether a prefix + argument is used or not. If ‘t’, then that command always acts as + a transient prefix. If ‘nil’, then a prefix argument has to be + used for it to act as a transient. + +‘C’ (‘magit-clone’) + + This command either acts as a transient prefix command as described + above or does the same thing as ‘transient-clone-regular’ as + described below. + + If it acts as a transient prefix, then it binds the following + suffix commands and several infix arguments. + +‘C C’ (‘magit-clone-regular’) + + This command creates a regular clone of an existing repository. + The repository and the target directory are read from the user. + +‘C s’ (‘magit-clone-shallow’) + + This command creates a shallow clone of an existing repository. + The repository and the target directory are read from the user. By + default the depth of the cloned history is a single commit, but + with a prefix argument the depth is read from the user. + +‘C b’ (‘magit-clone-bare’) + + This command creates a bare clone of an existing repository. The + repository and the target directory are read from the user. + +‘C m’ (‘magit-clone-mirror’) + + This command creates a mirror of an existing repository. The + repository and the target directory are read from the user. + + The following suffixes are disabled by default. See *note +(transient)Enabling and Disabling Suffixes:: for how to enable them. + +‘C d’ (‘magit-clone-shallow-since’) + + This command creates a shallow clone of an existing repository. + Only commits that were committed after a date are cloned, which is + read from the user. The repository and the target directory are + also read from the user. + +‘C e’ (‘magit-clone-shallow-exclude’) + + This command creates a shallow clone of an existing repository. + This reads a branch or tag from the user. Commits that are + reachable from that are not cloned. The repository and the target + directory are also read from the user. + + -- User Option: magit-clone-set-remote-head + + This option controls whether cloning causes the reference + ‘refs/remotes//HEAD’ to be created in the clone. The + default is to do so. + + Actually ‘git clone’ itself does that and cannot be told to not do + it. Therefore setting this to ‘nil’ causes Magit to remove that + reference after cloning. + + -- User Option: magit-clone-set-remote.pushDefault + + This option controls whether the value of the Git variable + ‘remote.pushDefault’ is set after cloning. + + • If ‘t’, then it is always set without asking. + + • If ‘ask’, then the users are asked every time they clone a + repository. + + • If ‘nil’, then it is never set. + + -- User Option: magit-clone-default-directory + + This option control the default directory name used when reading + the destination for a cloning operation. + + • If ‘nil’ (the default), then the value of ‘default-directory’ + is used. + + • If a directory, then that is used. + + • If a function, then that is called with the remote url as the + only argument and the returned value is used. + + -- User Option: magit-clone-name-alist + + This option maps regular expressions, which match repository names, + to repository urls, making it possible for users to enter short + names instead of urls when cloning repositories. + + Each element has the form ‘(REGEXP HOSTNAME USER)’. When the user + enters a name when a cloning command asks for a name or url, then + that is looked up in this list. The first element whose REGEXP + matches is used. + + The format specified by option ‘magit-clone-url-format’ is used to + turn the name into an url, using HOSTNAME and the repository name. + If the provided name contains a slash, then that is used. + Otherwise if the name omits the owner of the repository, then the + default user specified in the matched entry is used. + + If USER contains a dot, then it is treated as a Git variable and + the value of that is used as the username. Otherwise it is used as + the username itself. + + -- User Option: magit-clone-url-format + + The format specified by this option is used when turning repository + names into urls. ‘%h’ is the hostname and ‘%n’ is the repository + name, including the name of the owner. + + +File: magit.info, Node: Staging and Unstaging, Next: Applying, Prev: Cloning Repository, Up: Manipulating + +6.3 Staging and Unstaging +========================= + +Like Git, Magit can of course stage and unstage complete files. Unlike +Git, it also allows users to gracefully un-/stage individual hunks and +even just part of a hunk. To stage individual hunks and parts of hunks +using Git directly, one has to use the very modal and rather clumsy +interface of a ‘git add --interactive’ session. + + With Magit, on the other hand, one can un-/stage individual hunks by +just moving point into the respective section inside a diff displayed in +the status buffer or a separate diff buffer and typing ‘s’ or ‘u’. To +operate on just parts of a hunk, mark the changes that should be +un-/staged using the region and then press the same key that would be +used to un-/stage. To stage multiple files or hunks at once use a +region that starts inside the heading of such a section and ends inside +the heading of a sibling section of the same type. + + Besides staging and unstaging, Magit also provides several other +"apply variants" that can also operate on a file, multiple files at +once, a hunk, multiple hunks at once, and on parts of a hunk. These +apply variants are described in the next section. + + You can also use Ediff to stage and unstage. See *note Ediffing::. + +‘s’ (‘magit-stage’) + + Add the change at point to the staging area. + + With a prefix argument and an untracked file (or files) at point, + stage the file but not its content. This makes it possible to + stage only a subset of the new file’s changes. + +‘S’ (‘magit-stage-modified’) + + Stage all changes to files modified in the worktree. Stage all new + content of tracked files and remove tracked files that no longer + exist in the working tree from the index also. With a prefix + argument also stage previously untracked (but not ignored) files. + +‘u’ (‘magit-unstage’) + + Remove the change at point from the staging area. + + Only staged changes can be unstaged. But by default this command + performs an action that is somewhat similar to unstaging, when it + is called on a committed change: it reverses the change in the + index but not in the working tree. + +‘U’ (‘magit-unstage-all’) + + Remove all changes from the staging area. + + -- User Option: magit-unstage-committed + + This option controls whether ‘magit-unstage’ "unstages" committed + changes by reversing them in the index but not the working tree. + The alternative is to raise an error. + +‘M-x magit-reverse-in-index’ (‘magit-reverse-in-index’) + + This command reverses the committed change at point in the index + but not the working tree. By default no key is bound directly to + this command, but it is indirectly called when ‘u’ + (‘magit-unstage’) is pressed on a committed change. + + This allows extracting a change from ‘HEAD’, while leaving it in + the working tree, so that it can later be committed using a + separate commit. A typical workflow would be: + + • Optionally make sure that there are no uncommitted changes. + + • Visit the ‘HEAD’ commit and navigate to the change that should + not have been included in that commit. + + • Type ‘u’ (‘magit-unstage’) to reverse it in the index. This + assumes that ‘magit-unstage-committed-changes’ is non-nil. + + • Type ‘c e’ to extend ‘HEAD’ with the staged changes, including + those that were already staged before. + + • Optionally stage the remaining changes using ‘s’ or ‘S’ and + then type ‘c c’ to create a new commit. + +‘M-x magit-reset-index’ (‘magit-reset-index’) + + Reset the index to some commit. The commit is read from the user + and defaults to the commit at point. If there is no commit at + point, then it defaults to ‘HEAD’. + +* Menu: + +* Staging from File-Visiting Buffers:: + + +File: magit.info, Node: Staging from File-Visiting Buffers, Up: Staging and Unstaging + +6.3.1 Staging from File-Visiting Buffers +---------------------------------------- + +Fine-grained un-/staging has to be done from the status or a diff +buffer, but it’s also possible to un-/stage all changes made to the file +visited in the current buffer right from inside that buffer. + +‘M-x magit-stage-file’ (‘magit-stage-file’) + + When invoked inside a file-visiting buffer, then stage all changes + to that file. In a Magit buffer, stage the file at point if any. + Otherwise prompt for a file to be staged. With a prefix argument + always prompt the user for a file, even in a file-visiting buffer + or when there is a file section at point. + +‘M-x magit-unstage-file’ (‘magit-unstage-file’) + + When invoked inside a file-visiting buffer, then unstage all + changes to that file. In a Magit buffer, unstage the file at point + if any. Otherwise prompt for a file to be unstaged. With a prefix + argument always prompt the user for a file, even in a file-visiting + buffer or when there is a file section at point. + + +File: magit.info, Node: Applying, Next: Committing, Prev: Staging and Unstaging, Up: Manipulating + +6.4 Applying +============ + +Magit provides several "apply variants": stage, unstage, discard, +reverse, and "regular apply". At least when operating on a hunk they +are all implemented using ‘git apply’, which is why they are called +"apply variants". + + • Stage. Apply a change from the working tree to the index. The + change also remains in the working tree. + + • Unstage. Remove a change from the index. The change remains in + the working tree. + + • Discard. On a staged change, remove it from the working tree and + the index. On an unstaged change, remove it from the working tree + only. + + • Reverse. Reverse a change in the working tree. Both committed and + staged changes can be reversed. Unstaged changes cannot be + reversed. Discard them instead. + + • Apply. Apply a change to the working tree. Both committed and + staged changes can be applied. Unstaged changes cannot be applied + - as they already have been applied. + + The previous section described the staging and unstaging commands. +What follows are the commands which implement the remaining apply +variants. + +‘a’ (‘magit-apply’) + + Apply the change at point to the working tree. + + With a prefix argument fallback to a 3-way merge. Doing so causes + the change to be applied to the index as well. + +‘k’ (‘magit-discard’) + + Remove the change at point from the working tree. + +‘v’ (‘magit-reverse’) + + Reverse the change at point in the working tree. + + With a prefix argument fallback to a 3-way merge. Doing so causes + the change to be applied to the index as well. + + With a prefix argument all apply variants attempt a 3-way merge when +appropriate (i.e. when ‘git apply’ is used internally). + + +File: magit.info, Node: Committing, Next: Branching, Prev: Applying, Up: Manipulating + +6.5 Committing +============== + +When the user initiates a commit, Magit calls ‘git commit’ without any +arguments, so Git has to get it from the user. It creates the file +‘.git/COMMIT_EDITMSG’ and then opens that file in an editor. Magit +arranges for that editor to be the Emacsclient. Once the user finishes +the editing session, the Emacsclient exits and Git creates the commit +using the file’s content as message. + +* Menu: + +* Initiating a Commit:: +* Editing Commit Messages:: + + +File: magit.info, Node: Initiating a Commit, Next: Editing Commit Messages, Up: Committing + +6.5.1 Initiating a Commit +------------------------- + +Also see *note (gitman)git-commit::. + +‘c’ (‘magit-commit’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘c c’ (‘magit-commit-create’) + + Create a new commit on ‘HEAD’. With a prefix argument amend to the + commit at ‘HEAD’ instead. + +‘c a’ (‘magit-commit-amend’) + + Amend the last commit. + +‘c e’ (‘magit-commit-extend’) + + Amend the last commit, without editing the message. With a prefix + argument keep the committer date, otherwise change it. The option + ‘magit-commit-extend-override-date’ can be used to inverse the + meaning of the prefix argument. + + Non-interactively respect the optional OVERRIDE-DATE argument and + ignore the option. + +‘c w’ (‘magit-commit-reword’) + + Reword the last commit, ignoring staged changes. With a prefix + argument keep the committer date, otherwise change it. The option + ‘magit-commit-reword-override-date’ can be used to inverse the + meaning of the prefix argument. + + Non-interactively respect the optional OVERRIDE-DATE argument and + ignore the option. + +‘c f’ (‘magit-commit-fixup’) + + Create a fixup commit. + + With a prefix argument the target commit has to be confirmed. + Otherwise the commit at point may be used without confirmation + depending on the value of option ‘magit-commit-squash-confirm’. + +‘c F’ (‘magit-commit-instant-fixup’) + + Create a fixup commit and instantly rebase. + +‘c s’ (‘magit-commit-squash’) + + Create a squash commit, without editing the squash message. + + With a prefix argument the target commit has to be confirmed. + Otherwise the commit at point may be used without confirmation + depending on the value of option ‘magit-commit-squash-confirm’. + +‘c S’ (‘magit-commit-instant-squash’) + + Create a squash commit and instantly rebase. + +‘c A’ (‘magit-commit-augment’) + + Create a squash commit, editing the squash message. + + With a prefix argument the target commit has to be confirmed. + Otherwise the commit at point may be used without confirmation + depending on the value of option ‘magit-commit-squash-confirm’. + + -- User Option: magit-commit-ask-to-stage + + Whether to ask to stage all unstaged changes when committing and + nothing is staged. + + -- User Option: magit-commit-extend-override-date + + Whether using ‘magit-commit-extend’ changes the committer date. + + -- User Option: magit-commit-reword-override-date + + Whether using ‘magit-commit-reword’ changes the committer date. + + -- User Option: magit-commit-squash-confirm + + Whether the commit targeted by squash and fixup has to be + confirmed. When non-nil then the commit at point (if any) is used + as default choice. Otherwise it has to be confirmed. This option + only affects ‘magit-commit-squash’ and ‘magit-commit-fixup’. The + "instant" variants always require confirmation because making an + error while using those is harder to recover from. + + +File: magit.info, Node: Editing Commit Messages, Prev: Initiating a Commit, Up: Committing + +6.5.2 Editing Commit Messages +----------------------------- + +After initiating a commit as described in the previous section, two new +buffers appear. One shows the changes that are about to be committed, +while the other is used to write the message. + + Commit messages are edited in an edit session - in the background +‘git’ is waiting for the editor, in our case ‘emacsclient’, to save the +commit message in a file (in most cases ‘.git/COMMIT_EDITMSG’) and then +return. If the editor returns with a non-zero exit status then ‘git’ +does not create the commit. So the most important commands are those +for finishing and aborting the commit. + +‘C-c C-c’ (‘with-editor-finish’) + + Finish the current editing session by returning with exit code 0. + Git then creates the commit using the message it finds in the file. + +‘C-c C-k’ (‘with-editor-cancel’) + + Cancel the current editing session by returning with exit code 1. + Git then cancels the commit, but leaves the file untouched. + + In addition to being used by ‘git commit’, messages may also be +stored in a ring that persists until Emacs is closed. By default the +message is stored at the beginning and the end of an edit session +(regardless of whether the session is finished successfully or was +canceled). It is sometimes useful to bring back messages from that +ring. + +‘C-c M-s’ (‘git-commit-save-message’) + + Save the current buffer content to the commit message ring. + +‘M-p’ (‘git-commit-prev-message’) + + Cycle backward through the commit message ring, after saving the + current message to the ring. With a numeric prefix ARG, go back + ARG comments. + +‘M-n’ (‘git-commit-next-message’) + + Cycle forward through the commit message ring, after saving the + current message to the ring. With a numeric prefix ARG, go back + ARG comments. + + By default the diff for the changes that are about to be committed +are automatically shown when invoking the commit. To prevent that, +remove ‘magit-commit-diff’ from ‘server-switch-hook’. + + When amending to an existing commit it may be useful to show either +the changes that are about to be added to that commit or to show those +changes alongside those that have already been committed. + +‘C-c C-d’ (‘magit-diff-while-committing’) + + While committing, show the changes that are about to be committed. + While amending, invoking the command again toggles between showing + just the new changes or all the changes that will be committed. + +* Menu: + +* Using the Revision Stack:: +* Commit Pseudo Headers:: +* Commit Mode and Hooks:: +* Commit Message Conventions:: + + +File: magit.info, Node: Using the Revision Stack, Next: Commit Pseudo Headers, Up: Editing Commit Messages + +Using the Revision Stack +........................ + +‘C-c C-w’ (‘magit-pop-revision-stack’) + + This command inserts a representation of a revision into the + current buffer. It can be used inside buffers used to write commit + messages but also in other buffers such as buffers used to edit + emails or ChangeLog files. + + By default this command pops the revision which was last added to + the ‘magit-revision-stack’ and inserts it into the current buffer + according to ‘magit-pop-revision-stack-format’. Revisions can be + put on the stack using ‘magit-copy-section-value’ and + ‘magit-copy-buffer-revision’. + + If the stack is empty or with a prefix argument it instead reads a + revision in the minibuffer. By using the minibuffer history this + allows selecting an item which was popped earlier or to insert an + arbitrary reference or revision without first pushing it onto the + stack. + + When reading the revision from the minibuffer, then it might not be + possible to guess the correct repository. When this command is + called inside a repository (e.g. while composing a commit + message), then that repository is used. Otherwise (e.g. while + composing an email) then the repository recorded for the top + element of the stack is used (even though we insert another + revision). If not called inside a repository and with an empty + stack, or with two prefix arguments, then read the repository in + the minibuffer too. + + -- User Option: magit-pop-revision-stack-format + + This option controls how the command ‘magit-pop-revision-stack’ + inserts a revision into the current buffer. + + The entries on the stack have the format ‘(HASH TOPLEVEL)’ and this + option has the format ‘(POINT-FORMAT EOB-FORMAT INDEX-REGEXP)’, all + of which may be nil or a string (though either one of EOB-FORMAT or + POINT-FORMAT should be a string, and if INDEX-REGEXP is non-nil, + then the two formats should be too). + + First INDEX-REGEXP is used to find the previously inserted entry, + by searching backward from point. The first submatch must match + the index number. That number is incremented by one, and becomes + the index number of the entry to be inserted. If you don’t want to + number the inserted revisions, then use nil for INDEX-REGEXP. + + If INDEX-REGEXP is non-nil then both POINT-FORMAT and EOB-FORMAT + should contain \"%N\", which is replaced with the number that was + determined in the previous step. + + Both formats, if non-nil and after removing %N, are then expanded + using ‘git show --format=FORMAT ...’ inside TOPLEVEL. + + The expansion of POINT-FORMAT is inserted at point, and the + expansion of EOB-FORMAT is inserted at the end of the buffer (if + the buffer ends with a comment, then it is inserted right before + that). + + +File: magit.info, Node: Commit Pseudo Headers, Next: Commit Mode and Hooks, Prev: Using the Revision Stack, Up: Editing Commit Messages + +Commit Pseudo Headers +..................... + +Some projects use pseudo headers in commit messages. Magit colorizes +such headers and provides some commands to insert such headers. + + -- User Option: git-commit-known-pseudo-headers + + A list of Git pseudo headers to be highlighted. + +‘C-c C-i’ (‘git-commit-insert-pseudo-header’) + + Insert a commit message pseudo header. + +‘C-c C-a’ (‘git-commit-ack’) + + Insert a header acknowledging that you have looked at the commit. + +‘C-c C-r’ (‘git-commit-review’) + + Insert a header acknowledging that you have reviewed the commit. + +‘C-c C-s’ (‘git-commit-signoff’) + + Insert a header to sign off the commit. + +‘C-c C-t’ (‘git-commit-test’) + + Insert a header acknowledging that you have tested the commit. + +‘C-c C-o’ (‘git-commit-cc’) + + Insert a header mentioning someone who might be interested. + +‘C-c C-p’ (‘git-commit-reported’) + + Insert a header mentioning the person who reported the issue being + fixed by the commit. + +‘C-c M-i’ (‘git-commit-suggested’) + + Insert a header mentioning the person who suggested the change. + + +File: magit.info, Node: Commit Mode and Hooks, Next: Commit Message Conventions, Prev: Commit Pseudo Headers, Up: Editing Commit Messages + +Commit Mode and Hooks +..................... + +‘git-commit-mode’ is a minor mode that is only used to establish certain +key bindings. This makes it possible to use an arbitrary major mode in +buffers used to edit commit messages. It is even possible to use +different major modes in different repositories, which is useful when +different projects impose different commit message conventions. + + -- User Option: git-commit-major-mode + + The value of this option is the major mode used to edit Git commit + messages. + + Because ‘git-commit-mode’ is a minor mode, we don’t use its mode hook +to setup the buffer, except for the key bindings. All other setup +happens in the function ‘git-commit-setup’, which among other things +runs the hook ‘git-commit-setup-hook’. + + -- User Option: git-commit-setup-hook + + Hook run at the end of ‘git-commit-setup’. + +The following functions are suitable for this hook: + + -- Function: git-commit-save-message + + Save the current buffer content to the commit message ring. + + -- Function: git-commit-setup-changelog-support + + After this function is called, ChangeLog entries are treated as + paragraphs. + + -- Function: git-commit-turn-on-auto-fill + + Turn on ‘auto-fill-mode’ and set ‘fill-column’ to the value of + ‘git-commit-fill-column’. + + -- Function: git-commit-turn-on-flyspell + + Turn on Flyspell mode. Also prevent comments from being checked + and finally check current non-comment text. + + -- Function: git-commit-propertize-diff + + Propertize the diff shown inside the commit message buffer. Git + inserts such diffs into the commit message template when the + ‘--verbose’ argument is used. ‘magit-commit’ by default does not + offer that argument because the diff that is shown in a separate + buffer is more useful. But some users disagree, which is why this + function exists. + + -- Function: bug-reference-mode + + Hyperlink bug references in the buffer. + + -- Function: with-editor-usage-message + + Show usage information in the echo area. + + -- User Option: git-commit-setup-hook + + Hook run after the user finished writing a commit message. + + This hook is only run after pressing ‘C-c C-c’ in a buffer used to + edit a commit message. If a commit is created without the user + typing a message into a buffer, then this hook is not run. + + This hook is not run until the new commit has been created. If + doing so takes Git longer than one second, then this hook isn’t run + at all. For certain commands such as ‘magit-rebase-continue’ this + hook is never run because doing so would lead to a race condition. + + This hook is only run if ‘magit’ is available. + + Also see ‘magit-post-commit-hook’. + + +File: magit.info, Node: Commit Message Conventions, Prev: Commit Mode and Hooks, Up: Editing Commit Messages + +Commit Message Conventions +.......................... + +Git-Commit highlights certain violations of commonly accepted commit +message conventions. Certain violations even cause Git-Commit to ask +you to confirm that you really want to do that. This nagging can of +course be turned off, but the result of doing that usually is that +instead of some code it’s now the human who is reviewing your commits +who has to waste some time telling you to fix your commits. + + -- User Option: git-commit-summary-max-length + + The intended maximal length of the summary line of commit messages. + Characters beyond this column are colorized to indicate that this + preference has been violated. + + -- User Option: git-commit-fill-column + + Column beyond which automatic line-wrapping should happen in commit + message buffers. + + -- User Option: git-commit-finish-query-functions + + List of functions called to query before performing commit. + + The commit message buffer is current while the functions are + called. If any of them returns nil, then the commit is not + performed and the buffer is not killed. The user should then fix + the issue and try again. + + The functions are called with one argument. If it is non-nil then + that indicates that the user used a prefix argument to force + finishing the session despite issues. Functions should usually + honor this wish and return non-nil. + + By default the only member is ‘git-commit-check-style-conventions’. + + -- Function: git-commit-check-style-conventions + + This function checks for violations of certain basic style + conventions. For each violation it asks users if they want to + proceed anyway. + + -- User Option: git-commit-style-convention-checks + + This option controls what conventions the function by the same name + tries to enforce. The value is a list of self-explanatory symbols + identifying certain conventions; ‘non-empty-second-line’ and + ‘overlong-summary-line’. + + +File: magit.info, Node: Branching, Next: Merging, Prev: Committing, Up: Manipulating + +6.6 Branching +============= + +* Menu: + +* The Two Remotes:: +* Branch Commands:: +* Branch Git Variables:: +* Auxiliary Branch Commands:: + + +File: magit.info, Node: The Two Remotes, Next: Branch Commands, Up: Branching + +6.6.1 The Two Remotes +--------------------- + +The upstream branch of some local branch is the branch into which the +commits on that local branch should eventually be merged, usually +something like ‘origin/master’. For the ‘master’ branch itself the +upstream branch and the branch it is being pushed to, are usually the +same remote branch. But for a feature branch the upstream branch and +the branch it is being pushed to should differ. + + The commits on feature branches too should _eventually_ end up in a +remote branch such as ‘origin/master’ or ‘origin/maint’. Such a branch +should therefore be used as the upstream. But feature branches +shouldn’t be pushed directly to such branches. Instead a feature branch +‘my-feature’ is usually pushed to ‘my-fork/my-feature’ or if you are a +contributor ‘origin/my-feature’. After the new feature has been +reviewed, the maintainer merges the feature into ‘master’. And finally +‘master’ (not ‘my-feature’ itself) is pushed to ‘origin/master’. + + But new features seldom are perfect on the first try, and so feature +branches usually have to be reviewed, improved, and re-pushed several +times. Pushing should therefore be easy to do, and for that reason many +Git users have concluded that it is best to use the remote branch to +which the local feature branch is being pushed as its upstream. + + But luckily Git has long ago gained support for a push-remote which +can be configured separately from the upstream branch, using the +variables ‘branch..pushRemote’ and ‘remote.pushDefault’. So we no +longer have to choose which of the two remotes should be used as "the +remote". + + Each of the fetching, pulling, and pushing transient commands +features three suffix commands that act on the current branch and some +other branch. Of these, ‘p’ is bound to a command which acts on the +push-remote, ‘u’ is bound to a command which acts on the upstream, and +‘e’ is bound to a command which acts on any other branch. The status +buffer shows unpushed and unpulled commits for both the push-remote and +the upstream. + + It’s fairly simple to configure these two remotes. The values of all +the variables that are related to fetching, pulling, and pushing (as +well as some other branch-related variables) can be inspected and +changed using the command ‘magit-branch-configure’, which is available +from many transient prefix commands that deal with branches. It is also +possible to set the push-remote or upstream while pushing (see *note +Pushing::). + + +File: magit.info, Node: Branch Commands, Next: Branch Git Variables, Prev: The Two Remotes, Up: Branching + +6.6.2 Branch Commands +--------------------- + +The transient prefix command ‘magit-branch’ is used to create and +checkout branches, and to make changes to existing branches. It is not +used to fetch, pull, merge, rebase, or push branches, i.e. this command +deals with branches themselves, not with the commits reachable from +them. Those features are available from separate transient command. + +‘b’ (‘magit-branch’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + By default it also binds and displays the values of some + branch-related Git variables and allows changing their values. + + -- User Option: magit-branch-direct-configure + + This option controls whether the transient command ‘magit-branch’ + can be used directly change the values Git variables. This + defaults to ‘t’ (to avoid changing key bindings). When set to + ‘nil’, then no variables are displayed by that transient command, + and its suffix command ‘magit-branch-configure’ has to be used + instead to view and change branch related variables. + +‘b C’ (‘magit-branch-configure’) +‘f C’ (‘magit-branch-configure’) +‘F C’ (‘magit-branch-configure’) +‘P C’ (‘magit-branch-configure’) + + This transient prefix command binds commands that set the value of + branch-related variables and displays them in a temporary buffer + until the transient is exited. + + With a prefix argument, this command always prompts for a branch. + + Without a prefix argument this depends on whether it was invoked as + a suffix of ‘magit-branch’ and on the + ‘magit-branch-direct-configure’ option. If ‘magit-branch’ already + displays the variables for the current branch, then it isn’t useful + to invoke another transient that displays them for the same branch. + In that case this command prompts for a branch. + + The variables are described in *note Branch Git Variables::. + +‘b b’ (‘magit-checkout’) + + Checkout a revision read in the minibuffer and defaulting to the + branch or arbitrary revision at point. If the revision is a local + branch then that becomes the current branch. If it is something + else then ‘HEAD’ becomes detached. Checkout fails if the working + tree or the staging area contain changes. + +‘b n’ (‘magit-branch-create’) + + Create a new branch. The user is asked for a branch or arbitrary + revision to use as the starting point of the new branch. When a + branch name is provided, then that becomes the upstream branch of + the new branch. The name of the new branch is also read in the + minibuffer. + + Also see option ‘magit-branch-prefer-remote-upstream’. + +‘b c’ (‘magit-branch-and-checkout’) + + This command creates a new branch like ‘magit-branch’, but then + also checks it out. + + Also see option ‘magit-branch-prefer-remote-upstream’. + +‘b l’ (‘magit-branch-checkout’) + + This command checks out an existing or new local branch. It reads + a branch name from the user offering all local branches and a + subset of remote branches as candidates. Remote branches for which + a local branch by the same name exists are omitted from the list of + candidates. The user can also enter a completely new branch name. + + • If the user selects an existing local branch, then that is + checked out. + + • If the user selects a remote branch, then it creates and + checks out a new local branch with the same name, and + configures the selected remote branch as the push target. + + • If the user enters a new branch name, then it creates and + checks that out, after also reading the starting-point from + the user. + + In the latter two cases the upstream is also set. Whether it is + set to the chosen starting point or something else depends on the + value of ‘magit-branch-adjust-remote-upstream-alist’. + +‘b s’ (‘magit-branch-spinoff’) + + This command creates and checks out a new branch starting at and + tracking the current branch. That branch in turn is reset to the + last commit it shares with its upstream. If the current branch has + no upstream or no unpushed commits, then the new branch is created + anyway and the previously current branch is not touched. + + This is useful to create a feature branch after work has already + began on the old branch (likely but not necessarily "master"). + + If the current branch is a member of the value of option + ‘magit-branch-prefer-remote-upstream’ (which see), then the current + branch will be used as the starting point as usual, but the + upstream of the starting-point may be used as the upstream of the + new branch, instead of the starting-point itself. + + If optional FROM is non-nil, then the source branch is reset to + ‘FROM~’, instead of to the last commit it shares with its upstream. + Interactively, FROM is only ever non-nil, if the region selects + some commits, and among those commits, FROM is the commit that is + the fewest commits ahead of the source branch. + + The commit at the other end of the selection actually does not + matter, all commits between FROM and ‘HEAD’ are moved to the new + branch. If FROM is not reachable from ‘HEAD’ or is reachable from + the source branch’s upstream, then an error is raised. + +‘b S’ (‘magit-branch-spinout’) + + This command behaves like ‘magit-branch-spinoff’, except that it + does not change the current branch. If there are any uncommitted + changes, then it behaves exactly like ‘magit-branch-spinoff’. + +‘b x’ (‘magit-branch-reset’) + + This command resets a branch, defaulting to the branch at point, to + the tip of another branch or any other commit. + + When the branch being reset is the current branch, then a hard + reset is performed. If there are any uncommitted changes, then the + user has to confirm the reset because those changes would be lost. + + This is useful when you have started work on a feature branch but + realize it’s all crap and want to start over. + + When resetting to another branch and a prefix argument is used, + then the target branch is set as the upstream of the branch that is + being reset. + +‘b k’ (‘magit-branch-delete’) + + Delete one or multiple branches. If the region marks multiple + branches, then offer to delete those. Otherwise, prompt for a + single branch to be deleted, defaulting to the branch at point. + +‘b r’ (‘magit-branch-rename’) + + Rename a branch. The branch and the new name are read in the + minibuffer. With prefix argument the branch is renamed even if + that name conflicts with an existing branch. + + -- User Option: magit-branch-read-upstream-first + + When creating a branch, whether to read the upstream branch before + the name of the branch that is to be created. The default is + ‘nil’, and I recommend you leave it at that. + + -- User Option: magit-branch-prefer-remote-upstream + + This option specifies whether remote upstreams are favored over + local upstreams when creating new branches. + + When a new branch is created, then the branch, commit, or stash at + point is suggested as the starting point of the new branch, or if + there is no such revision at point the current branch. In either + case the user may choose another starting point. + + If the chosen starting point is a branch, then it may also be set + as the upstream of the new branch, depending on the value of the + Git variable ‘branch.autoSetupMerge’. By default this is done for + remote branches, but not for local branches. + + You might prefer to always use some remote branch as upstream. If + the chosen starting point is (1) a local branch, (2) whose name + matches a member of the value of this option, (3) the upstream of + that local branch is a remote branch with the same name, and (4) + that remote branch can be fast-forwarded to the local branch, then + the chosen branch is used as starting point, but its own upstream + is used as the upstream of the new branch. + + Members of this option’s value are treated as branch names that + have to match exactly unless they contain a character that makes + them invalid as a branch name. Recommended characters to use to + trigger interpretation as a regexp are "*" and "^". Some other + characters which you might expect to be invalid, actually are not, + e.g. ".+$" are all perfectly valid. More precisely, if ‘git + check-ref-format --branch STRING’ exits with a non-zero status, + then treat STRING as a regexp. + + Assuming the chosen branch matches these conditions you would end + up with with e.g.: + + feature --upstream--> origin/master + + instead of + + feature --upstream--> master --upstream--> origin/master + + Which you prefer is a matter of personal preference. If you do + prefer the former, then you should add branches such as ‘master’, + ‘next’, and ‘maint’ to the value of this options. + + -- User Option: magit-branch-adjust-remote-upstream-alist + + The value of this option is an alist of branches to be used as the + upstream when branching a remote branch. + + When creating a local branch from an ephemeral branch located on a + remote, e.g. a feature or hotfix branch, then that remote branch + should usually not be used as the upstream branch, since the + push-remote already allows accessing it and having both the + upstream and the push-remote reference the same related branch + would be wasteful. Instead a branch like "maint" or "master" + should be used as the upstream. + + This option allows specifying the branch that should be used as the + upstream when branching certain remote branches. The value is an + alist of the form ‘((UPSTREAM . RULE)...)’. The first matching + element is used, the following elements are ignored. + + UPSTREAM is the branch to be used as the upstream for branches + specified by RULE. It can be a local or a remote branch. + + RULE can either be a regular expression, matching branches whose + upstream should be the one specified by UPSTREAM. Or it can be a + list of the only branches that should *not* use UPSTREAM; all other + branches will. Matching is done after stripping the remote part of + the name of the branch that is being branched from. + + If you use a finite set of non-ephemeral branches across all your + repositories, then you might use something like: + + (("origin/master" "master" "next" "maint")) + + Or if the names of all your ephemeral branches contain a slash, at + least in some repositories, then a good value could be: + + (("origin/master" . "/")) + + Of course you can also fine-tune: + + (("origin/maint" . "\\`hotfix/") + ("origin/master" . "\\`feature/")) + + -- Command: magit-branch-orphan + + This command creates and checks out a new orphan branch with + contents from a given revision. + + -- Command: magit-branch-or-checkout + + This command is a hybrid between ‘magit-checkout’ and + ‘magit-branch-and-checkout’ and is intended as a replacement for + the former in ‘magit-branch’. + + It first asks the user for an existing branch or revision. If the + user input actually can be resolved as a branch or revision, then + it checks that out, just like ‘magit-checkout’ would. + + Otherwise it creates and checks out a new branch using the input as + its name. Before doing so it reads the starting-point for the new + branch. This is similar to what ‘magit-branch-and-checkout’ does. + + To use this command instead of ‘magit-checkout’ add this to your + init file: + + (transient-replace-suffix 'magit-branch 'magit-checkout + '("b" "dwim" magit-branch-or-checkout)) + + +File: magit.info, Node: Branch Git Variables, Next: Auxiliary Branch Commands, Prev: Branch Commands, Up: Branching + +6.6.3 Branch Git Variables +-------------------------- + +These variables can be set from the transient prefix command +‘magit-branch-configure’. By default they can also be set from +‘magit-branch’. See *note Branch Commands::. + + -- Variable: branch.NAME.merge + + Together with ‘branch.NAME.remote’ this variable defines the + upstream branch of the local branch named NAME. The value of this + variable is the full reference of the upstream _branch_. + + -- Variable: branch.NAME.remote + + Together with ‘branch.NAME.merge’ this variable defines the + upstream branch of the local branch named NAME. The value of this + variable is the name of the upstream _remote_. + + -- Variable: branch.NAME.rebase + + This variable controls whether pulling into the branch named NAME + is done by rebasing or by merging the fetched branch. + + • When ‘true’ then pulling is done by rebasing. + + • When ‘false’ then pulling is done by merging. + + • When undefined then the value of ‘pull.rebase’ is used. The + default of that variable is ‘false’. + + -- Variable: branch.NAME.pushRemote + + This variable specifies the remote that the branch named NAME is + usually pushed to. The value has to be the name of an existing + remote. + + It is not possible to specify the name of _branch_ to push the + local branch to. The name of the remote branch is always the same + as the name of the local branch. + + If this variable is undefined but ‘remote.pushDefault’ is defined, + then the value of the latter is used. By default + ‘remote.pushDefault’ is undefined. + + -- Variable: branch.NAME.description + + This variable can be used to describe the branch named NAME. That + description is used e.g. when turning the branch into a series of + patches. + + The following variables specify defaults which are used if the above +branch-specific variables are not set. + + -- Variable: pull.rebase + + This variable specifies whether pulling is done by rebasing or by + merging. It can be overwritten using ‘branch.NAME.rebase’. + + • When ‘true’ then pulling is done by rebasing. + + • When ‘false’ (the default) then pulling is done by merging. + + Since it is never a good idea to merge the upstream branch into a + feature or hotfix branch and most branches are such branches, you + should consider setting this to ‘true’, and ‘branch.master.rebase’ + to ‘false’. + + -- Variable: remote.pushDefault + + This variable specifies what remote the local branches are usually + pushed to. This can be overwritten per branch using + ‘branch.NAME.pushRemote’. + + The following variables are used during the creation of a branch and +control whether the various branch-specific variables are automatically +set at this time. + + -- Variable: branch.autoSetupMerge + + This variable specifies under what circumstances creating a branch + NAME should result in the variables ‘branch.NAME.merge’ and + ‘branch.NAME.remote’ being set according to the starting point used + to create the branch. If the starting point isn’t a branch, then + these variables are never set. + + • When ‘always’ then the variables are set regardless of whether + the starting point is a local or a remote branch. + + • When ‘true’ (the default) then the variables are set when the + starting point is a remote branch, but not when it is a local + branch. + + • When ‘false’ then the variables are never set. + + -- Variable: branch.autoSetupRebase + + This variable specifies whether creating a branch NAME should + result in the variable ‘branch.NAME.rebase’ being set to ‘true’. + + • When ‘always’ then the variable is set regardless of whether + the starting point is a local or a remote branch. + + • When ‘local’ then the variable are set when the starting point + is a local branch, but not when it is a remote branch. + + • When ‘remote’ then the variable are set when the starting + point is a remote branch, but not when it is a local branch. + + • When ‘never’ (the default) then the variable is never set. + + Note that the respective commands always change the repository-local +values. If you want to change the global value, which is used when the +local value is undefined, then you have to do so on the command line, +e.g.: + + git config --global remote.autoSetupMerge always + + For more information about these variables you should also see + + *note (gitman)git-config::. Also see *note (gitman)git-branch::. , +*note (gitman)git-checkout::. and *note Pushing::. + + -- User Option: magit-prefer-remote-upstream + + This option controls whether commands that read a branch from the + user and then set it as the upstream branch, offer a local or a + remote branch as default completion candidate, when they have the + choice. + + This affects all commands that use ‘magit-read-upstream-branch’ or + ‘magit-read-starting-point’, which includes all commands that + change the upstream and many which create new branches. + + +File: magit.info, Node: Auxiliary Branch Commands, Prev: Branch Git Variables, Up: Branching + +6.6.4 Auxiliary Branch Commands +------------------------------- + +These commands are not available from the transient ‘magit-branch’ by +default. + + -- Command: magit-branch-shelve + + This command shelves a branch. This is done by deleting the + branch, and creating a new reference "refs/shelved/BRANCH-NAME" + pointing at the same commit as the branch pointed at. If the + deleted branch had a reflog, then that is preserved as the reflog + of the new reference. + + This is useful if you want to move a branch out of sight, but are + not ready to completely discard it yet. + + -- Command: magit-branch-unshelve + + This command unshelves a branch that was previously shelved using + ‘magit-branch-shelve’. This is done by deleting the reference + "refs/shelved/BRANCH-NAME" and creating a branch "BRANCH-NAME" + pointing at the same commit as the deleted reference pointed at. + If the deleted reference had a reflog, then that is restored as the + reflog of the branch. + + +File: magit.info, Node: Merging, Next: Resolving Conflicts, Prev: Branching, Up: Manipulating + +6.7 Merging +=========== + +Also see *note (gitman)git-merge::. For information on how to resolve +merge conflicts see the next section. + +‘m’ (‘magit-merge’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no merge is in progress, then the transient features the +following suffix commands. + +‘m m’ (‘magit-merge-plain’) + + This command merges another branch or an arbitrary revision into + the current branch. The branch or revision to be merged is read in + the minibuffer and defaults to the branch at point. + + Unless there are conflicts or a prefix argument is used, then the + resulting merge commit uses a generic commit message, and the user + does not get a chance to inspect or change it before the commit is + created. With a prefix argument this does not actually create the + merge commit, which makes it possible to inspect how conflicts were + resolved and to adjust the commit message. + +‘m e’ (‘magit-merge-editmsg’) + + This command merges another branch or an arbitrary revision into + the current branch and opens a commit message buffer, so that the + user can make adjustments. The commit is not actually created + until the user finishes with ‘C-c C-c’. + +‘m n’ (‘magit-merge-nocommit’) + + This command merges another branch or an arbitrary revision into + the current branch, but does not actually create the merge commit. + The user can then further adjust the merge, even when automatic + conflict resolution succeeded and/or adjust the commit message. + +‘m a’ (‘magit-merge-absorb’) + + This command merges another local branch into the current branch + and then removes the former. + + Before the source branch is merged, it is first force pushed to its + push-remote, provided the respective remote branch already exists. + This ensures that the respective pull-request (if any) won’t get + stuck on some obsolete version of the commits that are being + merged. Finally, if ‘magit-branch-pull-request’ was used to create + the merged branch, then the respective remote branch is also + removed. + +‘m i’ (‘magit-merge-into’) + + This command merges the current branch into another local branch + and then removes the former. The latter becomes the new current + branch. + + Before the source branch is merged, it is first force pushed to its + push-remote, provided the respective remote branch already exists. + This ensures that the respective pull-request (if any) won’t get + stuck on some obsolete version of the commits that are being + merged. Finally, if ‘magit-branch-pull-request’ was used to create + the merged branch, then the respective remote branch is also + removed. + +‘m s’ (‘magit-merge-squash’) + + This command squashes the changes introduced by another branch or + an arbitrary revision into the current branch. This only applies + the changes made by the squashed commits. No information is + preserved that would allow creating an actual merge commit. + Instead of this command you should probably use a command from the + apply transient. + +‘m p’ (‘magit-merge-preview’) + + This command shows a preview of merging another branch or an + arbitrary revision into the current branch. + + When a merge is in progress, then the transient instead features the +following suffix commands. + +‘m m’ (‘magit-merge’) + + After the user resolved conflicts, this command proceeds with the + merge. If some conflicts weren’t resolved, then this command + fails. + +‘m a’ (‘magit-merge-abort’) + + This command aborts the current merge operation. + + +File: magit.info, Node: Resolving Conflicts, Next: Rebasing, Prev: Merging, Up: Manipulating + +6.8 Resolving Conflicts +======================= + +When merging branches (or otherwise combining or changing history) +conflicts can occur. If you edited two completely different parts of +the same file in two branches and then merge one of these branches into +the other, then Git can resolve that on its own, but if you edit the +same area of a file, then a human is required to decide how the two +versions, or "sides of the conflict", are to be combined into one. + + Here we can only provide a brief introduction to the subject and +point you toward some tools that can help. If you are new to this, then +please also consult Git’s own documentation as well as other resources. + + If a file has conflicts and Git cannot resolve them by itself, then +it puts both versions into the affected file along with special markers +whose purpose is to denote the boundaries of the unresolved part of the +file and between the different versions. These boundary lines begin +with the strings consisting of six times the same character, one of ‘<’, +‘|’, ‘=’ and ‘>’ and are followed by information about the source of the +respective versions, e.g.: + + <<<<<<< HEAD + Take the blue pill. + ======= + Take the red pill. + >>>>>>> feature + + In this case you have chosen to take the red pill on one branch and +on another you picked the blue pill. Now that you are merging these two +diverging branches, Git cannot possibly know which pill you want to +take. + + To resolve that conflict you have to create a version of the affected +area of the file by keeping only one of the sides, possibly by editing +it in order to bring in the changes from the other side, remove the +other versions as well as the markers, and then stage the result. A +possible resolution might be: + + Take both pills. + + Often it is useful to see not only the two sides of the conflict but +also the "original" version from before the same area of the file was +modified twice on different branches. Instruct Git to insert that +version as well by running this command once: + + git config --global merge.conflictStyle diff3 + + The above conflict might then have looked like this: + + <<<<<<< HEAD + Take the blue pill. + ||||||| merged common ancestors + Take either the blue or the red pill, but not both. + ======= + Take the red pill. + >>>>>>> feature + + If that were the case, then the above conflict resolution would not +have been correct, which demonstrates why seeing the original version +alongside the conflicting versions can be useful. + + You can perform the conflict resolution completely by hand, but Emacs +also provides some packages that help in the process: Smerge, Ediff +(*note (ediff)Top::), and Emerge (*note (emacs)Emerge::). Magit does +not provide its own tools for conflict resolution, but it does make +using Smerge and Ediff more convenient. (Ediff supersedes Emerge, so +you probably don’t want to use the latter anyway.) + + In the Magit status buffer, files with unresolved conflicts are +listed in the "Unstaged changes" and/or "Staged changes" sections. They +are prefixed with the word "unmerged", which in this context essentially +is a synonym for "unresolved". + + Pressing ‘RET’ while point is on such a file section shows a buffer +visiting that file, turns on ‘smerge-mode’ in that buffer, and places +point inside the first area with conflicts. You should then resolve +that conflict using regular edit commands and/or Smerge commands. + + Unfortunately Smerge does not have a manual, but you can get a list +of commands and binding ‘C-c ^ C-h’ and press ‘RET’ while point is on a +command name to read its documentation. + + Normally you would edit one version and then tell Smerge to keep only +that version. Use ‘C-c ^ m’ (‘smerge-keep-mine’) to keep the ‘HEAD’ +version or ‘C-c ^ o’ (‘smerge-keep-other’) to keep the version that +follows "|||||||". Then use ‘C-c ^ n’ to move to the next conflicting +area in the same file. Once you are done resolving conflicts, return to +the Magit status buffer. The file should now be shown as "modified", no +longer as "unmerged", because Smerge automatically stages the file when +you save the buffer after resolving the last conflict. + + Alternatively you could use Ediff, which uses separate buffers for +the different versions of the file. To resolve conflicts in a file +using Ediff press ‘e’ while point is on such a file in the status +buffer. + + Ediff can be used for other purposes as well. For more information +on how to enter Ediff from Magit, see *note Ediffing::. Explaining how +to use Ediff is beyond the scope of this manual, instead see *note +(ediff)Top::. + + If you are unsure whether you should Smerge or Ediff, then use the +former. It is much easier to understand and use, and except for truly +complex conflicts, the latter is usually overkill. + + +File: magit.info, Node: Rebasing, Next: Cherry Picking, Prev: Resolving Conflicts, Up: Manipulating + +6.9 Rebasing +============ + +Also see *note (gitman)git-rebase::. For information on how to resolve +conflicts that occur during rebases see the preceding section. + +‘r’ (‘magit-rebase’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no rebase is in progress, then the transient features the +following suffix commands. + + Using one of these commands _starts_ a rebase sequence. Git might +then stop somewhere along the way, either because you told it to do so, +or because applying a commit failed due to a conflict. When that +happens, then the status buffer shows information about the rebase +sequence which is in progress in a section similar to a log section. +See *note Information About In-Progress Rebase::. + + For information about the upstream and the push-remote, see *note The +Two Remotes::. + +‘r p’ (‘magit-rebase-onto-pushremote’) + + This command rebases the current branch onto its push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +‘r u’ (‘magit-rebase-onto-upstream’) + + This command rebases the current branch onto its upstream branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +‘r e’ (‘magit-rebase-branch’) + + This command rebases the current branch onto a branch read in the + minibuffer. All commits that are reachable from head but not from + the selected branch TARGET are being rebased. + +‘r s’ (‘magit-rebase-subset’) + + This command starts a non-interactive rebase sequence to transfer + commits from START to ‘HEAD’ onto NEWBASE. START has to be + selected from a list of recent commits. + + By default Magit uses the ‘--autostash’ argument, which causes +uncommitted changes to be stored in a stash before the rebase begins. +These changes are restored after the rebase completes and if possible +the stash is removed. If the stash does not apply cleanly, then the +stash is not removed. In case something goes wrong when resolving the +conflicts, this allows you to start over. + + Even though one of the actions is dedicated to interactive rebases, +the transient also features the infix argument ‘--interactive’. This +can be used to turn one of the other, non-interactive rebase variants +into an interactive rebase. + + For example if you want to clean up a feature branch and at the same +time rebase it onto ‘master’, then you could use ‘r-iu’. But we +recommend that you instead do that in two steps. First use ‘ri’ to +cleanup the feature branch, and then in a second step ‘ru’ to rebase it +onto ‘master’. That way if things turn out to be more complicated than +you thought and/or you make a mistake and have to start over, then you +only have to redo half the work. + + Explicitly enabling ‘--interactive’ won’t have an effect on the +following commands as they always use that argument anyway, even if it +is not enabled in the transient. + +‘r i’ (‘magit-rebase-interactive’) + + This command starts an interactive rebase sequence. + +‘r f’ (‘magit-rebase-autosquash’) + + This command combines squash and fixup commits with their intended + targets. + +‘r m’ (‘magit-rebase-edit-commit’) + + This command starts an interactive rebase sequence that lets the + user edit a single older commit. + +‘r w’ (‘magit-rebase-reword-commit’) + + This command starts an interactive rebase sequence that lets the + user reword a single older commit. + +‘r k’ (‘magit-rebase-remove-commit’) + + This command removes a single older commit using rebase. + + When a rebase is in progress, then the transient instead features the +following suffix commands. + +‘r r’ (‘magit-rebase-continue’) + + This command restart the current rebasing operation. + + In some cases this pops up a commit message buffer for you do edit. + With a prefix argument the old message is reused as-is. + +‘r s’ (‘magit-rebase-skip’) + + This command skips the current commit and restarts the current + rebase operation. + +‘r e’ (‘magit-rebase-edit’) + + This command lets the user edit the todo list of the current rebase + operation. + +‘r a’ (‘magit-rebase-abort’) + + This command aborts the current rebase operation, restoring the + original branch. + +* Menu: + +* Editing Rebase Sequences:: +* Information About In-Progress Rebase:: + + +File: magit.info, Node: Editing Rebase Sequences, Next: Information About In-Progress Rebase, Up: Rebasing + +6.9.1 Editing Rebase Sequences +------------------------------ + +‘C-c C-c’ (‘with-editor-finish’) + + Finish the current editing session by returning with exit code 0. + Git then uses the rebase instructions it finds in the file. + +‘C-c C-k’ (‘with-editor-cancel’) + + Cancel the current editing session by returning with exit code 1. + Git then forgoes starting the rebase sequence. + +‘RET’ (‘git-rebase-show-commit’) + + Show the commit on the current line in another buffer and select + that buffer. + +‘SPC’ (‘git-rebase-show-or-scroll-up’) + + Show the commit on the current line in another buffer without + selecting that buffer. If the revision buffer is already visible + in another window of the current frame, then instead scroll that + window up. + +‘DEL’ (‘git-rebase-show-or-scroll-down’) + + Show the commit on the current line in another buffer without + selecting that buffer. If the revision buffer is already visible + in another window of the current frame, then instead scroll that + window down. + +‘p’ (‘git-rebase-backward-line’) + + Move to previous line. + +‘n’ (‘forward-line’) + + Move to next line. + +‘M-p’ (‘git-rebase-move-line-up’) + + Move the current commit (or command) up. + +‘M-n’ (‘git-rebase-move-line-down’) + + Move the current commit (or command) down. + +‘r’ (‘git-rebase-reword’) + + Edit message of commit on current line. + +‘e’ (‘git-rebase-edit’) + + Stop at the commit on the current line. + +‘s’ (‘git-rebase-squash’) + + Meld commit on current line into previous commit, and edit message. + +‘f’ (‘git-rebase-fixup’) + + Meld commit on current line into previous commit, discarding the + current commit’s message. + +‘k’ (‘git-rebase-kill-line’) + + Kill the current action line. + +‘c’ (‘git-rebase-pick’) + + Use commit on current line. + +‘x’ (‘git-rebase-exec’) + + Insert a shell command to be run after the proceeding commit. + + If there already is such a command on the current line, then edit + that instead. With a prefix argument insert a new command even + when there already is one on the current line. With empty input + remove the command on the current line, if any. + +‘b’ (‘git-rebase-break’) + + Insert a break action before the current line, instructing Git to + return control to the user. + +‘y’ (‘git-rebase-insert’) + + Read an arbitrary commit and insert it below current line. + +‘C-x u’ (‘git-rebase-undo’) + + Undo some previous changes. Like ‘undo’ but works in read-only + buffers. + + -- User Option: git-rebase-auto-advance + + Whether to move to next line after changing a line. + + -- User Option: git-rebase-show-instructions + + Whether to show usage instructions inside the rebase buffer. + + -- User Option: git-rebase-confirm-cancel + + Whether confirmation is required to cancel. + + When a rebase is performed with the ‘--rebase-merges’ option, the +sequence will include a few other types of actions and the following +commands become relevant. + +‘l’ (‘git-rebase-label’) + + This commands inserts a label action or edits the one at point. + +‘t’ (‘git-rebase-reset’) + + This command inserts a reset action or edits the one at point. The + prompt will offer the labels that are currently present in the + buffer. + +‘MM’ (‘git-rebase-merge’) + + The command inserts a merge action or edits the one at point. The + prompt will offer the labels that are currently present in the + buffer. Specifying a message to reuse via ‘-c’ or ‘-C’ is not + supported; an editor will always be invoked for the merge. + +‘Mt’ (‘git-rebase-merge-toggle-editmsg’) + + This command toggles between the ‘-C’ and ‘-c’ options of the merge + action at point. These options both specify a commit whose message + should be reused. The lower-case variant instructs Git to invoke + the editor when creating the merge, allowing the user to edit the + message. + + +File: magit.info, Node: Information About In-Progress Rebase, Prev: Editing Rebase Sequences, Up: Rebasing + +6.9.2 Information About In-Progress Rebase +------------------------------------------ + +While a rebase sequence is in progress, the status buffer features a +section that lists the commits that have already been applied as well as +the commits that still have to be applied. + + The commits are split in two halves. When rebase stops at a commit, +either because the user has to deal with a conflict or because s/he +explicitly requested that rebase stops at that commit, then point is +placed on the commit that separates the two groups, i.e. on ‘HEAD’. +The commits above it have not been applied yet, while the ‘HEAD’ and the +commits below it have already been applied. In between these two groups +of applied and yet-to-be applied commits, there sometimes is a commit +which has been dropped. + + Each commit is prefixed with a word and these words are additionally +shown in different colors to indicate the status of the commits. + + The following colors are used: + + • Yellow commits have not been applied yet. + + • Gray commits have already been applied. + + • The blue commit is the ‘HEAD’ commit. + + • The green commit is the commit the rebase sequence stopped at. If + this is the same commit as ‘HEAD’ (e.g. because you haven’t done + anything yet after rebase stopped at the commit, then this commit + is shown in blue, not green). There can only be a green *and* a + blue commit at the same time, if you create one or more new commits + after rebase stops at a commit. + + • Red commits have been dropped. They are shown for reference only, + e.g. to make it easier to diff. + + Of course these colors are subject to the color-theme in use. + + The following words are used: + + • Commits prefixed with ‘pick’, ‘reword’, ‘edit’, ‘squash’, and + ‘fixup’ have not been applied yet. These words have the same + meaning here as they do in the buffer used to edit the rebase + sequence. See *note Editing Rebase Sequences::. When the + ‘--rebase-merges’ option was specified, ‘reset’, ‘label’, and + ‘merge’ lines may also be present. + + • Commits prefixed with ‘done’ and ‘onto’ have already been applied. + It is possible for such a commit to be the ‘HEAD’, in which case it + is blue. Otherwise it is grey. + + • The commit prefixed with ‘onto’ is the commit on top of which + all the other commits are being re-applied. This commit + itself did not have to be re-applied, it is the commit rebase + did rewind to before starting to re-apply other commits. + + • Commits prefixed with ‘done’ have already been re-applied. + This includes commits that have been re-applied but also new + commits that you have created during the rebase. + + • All other commits, those not prefixed with any of the above words, + are in some way related to the commit at which rebase stopped. + + To determine whether a commit is related to the stopped-at commit + their hashes, trees and patch-ids (1) are being compared. The + commit message is not used for this purpose. + + Generally speaking commits that are related to the stopped-at + commit can have any of the used colors, though not all color/word + combinations are possible. + + Words used for stopped-at commits are: + + • When a commit is prefixed with ‘void’, then that indicates + that Magit knows for sure that all the changes in that commit + have been applied using several new commits. This commit is + no longer reachable from ‘HEAD’, and it also isn’t one of the + commits that will be applied when resuming the session. + + • When a commit is prefixed with ‘join’, then that indicates + that the rebase sequence stopped at that commit due to a + conflict - you now have to join (merge) the changes with what + has already been applied. In a sense this is the commit + rebase stopped at, but while its effect is already in the + index and in the worktree (with conflict markers), the commit + itself has not actually been applied yet (it isn’t the + ‘HEAD’). So it is shown in yellow, like the other commits + that still have to be applied. + + • When a commit is prefixed with ‘stop’ or a _blue_ or _green_ + ‘same’, then that indicates that rebase stopped at this + commit, that it is still applied or has been applied again, + and that at least its patch-id is unchanged. + + • When a commit is prefixed with ‘stop’, then that + indicates that rebase stopped at that commit because you + requested that earlier, and its patch-id is unchanged. + It might even still be the exact same commit. + + • When a commit is prefixed with a _blue_ or _green_ + ‘same’, then that indicates that while its tree or hash + changed, its patch-id did not. If it is blue, then it is + the ‘HEAD’ commit (as always for blue). When it is + green, then it no longer is ‘HEAD’ because other commit + have been created since (but before continuing the + rebase). + + • When a commit is prefixed with ‘goal’, a _yellow_ ‘same,’ or + ‘work’, then that indicates that rebase applied that commit + but that you then reset ‘HEAD’ to an earlier commit (likely to + split it up into multiple commits), and that there are some + uncommitted changes remaining which likely (but not + necessarily) originate from that commit. + + • When a commit is prefixed with ‘goal’, then that + indicates that it is still possible to create a new + commit with the exact same tree (the "goal") without + manually editing any files, by committing the index, or + by staging all changes and then committing that. This is + the case when the original tree still exists in the index + or worktree in untainted form. + + • When a commit is prefixed with a yellow ‘same’, then that + indicates that it is no longer possible to create a + commit with the exact same tree, but that it is still + possible to create a commit with the same patch-id. This + would be the case if you created a new commit with other + changes, but the changes from the original commit still + exist in the index or working tree in untainted form. + + • When a commit is prefixed with ‘work’, then that + indicates that you reset ‘HEAD’ to an earlier commit, and + that there are some staged and/or unstaged changes + (likely, but not necessarily) originating from that + commit. However it is no longer possible to create a new + commit with the same tree or at least the same patch-id + because you have already made other changes. + + • When a commit is prefixed with ‘poof’ or ‘gone’, then that + indicates that rebase applied that commit but that you then + reset ‘HEAD’ to an earlier commit (likely to split it up into + multiple commits), and that there are no uncommitted changes. + + • When a commit is prefixed with ‘poof’, then that + indicates that it is no longer reachable from ‘HEAD’, but + that it has been replaced with one or more commits, which + together have the exact same effect. + + • When a commit is prefixed with ‘gone’, then that + indicates that it is no longer reachable from ‘HEAD’ and + that we also cannot determine whether its changes are + still in effect in one or more new commits. They might + be, but if so, then there must also be other changes + which makes it impossible to know for sure. + + Do not worry if you do not fully understand the above. That’s okay, +you will acquire a good enough understanding through practice. + + For other sequence operations such as cherry-picking, a similar +section is displayed, but they lack some of the features described +above, due to limitations in the git commands used to implement them. +Most importantly these sequences only support "picking" a commit but not +other actions such as "rewording", and they do not keep track of the +commits which have already been applied. + + ---------- Footnotes ---------- + + (1) The patch-id is a hash of the _changes_ introduced by a commit. +It differs from the hash of the commit itself, which is a hash of the +result of applying that change (i.e. the resulting trees and blobs) as +well as author and committer information, the commit message, and the +hashes of the parents of the commit. The patch-id hash on the other +hand is created only from the added and removed lines, even line numbers +and whitespace changes are ignored when calculating this hash. The +patch-ids of two commits can be used to answer the question "Do these +commits make the same change?". + + +File: magit.info, Node: Cherry Picking, Next: Resetting, Prev: Rebasing, Up: Manipulating + +6.10 Cherry Picking +=================== + +Also see *note (gitman)git-cherry-pick::. + +‘A’ (‘magit-cherry-pick’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no cherry-pick or revert is in progress, then the transient +features the following suffix commands. + +‘A A’ (‘magit-cherry-copy’) + + This command copies COMMITS from another branch onto the current + branch. If the region selects multiple commits, then those are + copied, without prompting. Otherwise the user is prompted for a + commit or range, defaulting to the commit at point. + +‘A a’ (‘magit-cherry-apply’) + + This command applies the changes in COMMITS from another branch + onto the current branch. If the region selects multiple commits, + then those are used, without prompting. Otherwise the user is + prompted for a commit or range, defaulting to the commit at point. + + This command also has a top-level binding, which can be invoked + without using the transient by typing ‘a’ at the top-level. + + The following commands not only apply some commits to some branch, +but also remove them from some other branch. The removal is performed +using either ‘git-update-ref’ or if necessary ‘git-rebase’. Both +applying commits as well as removing them using ‘git-rebase’ can lead to +conflicts. If that happens, then these commands abort and you not only +have to resolve the conflicts but also finish the process the same way +you would have to if these commands didn’t exist at all. + +‘A h’ (‘magit-cherry-harvest’) + + This command moves the selected COMMITS that must be located on + another BRANCH onto the current branch instead, removing them from + the former. When this command succeeds, then the same branch is + current as before. + + Applying the commits on the current branch or removing them from + the other branch can lead to conflicts. When that happens, then + this command stops and you have to resolve the conflicts and then + finish the process manually. + +‘A d’ (‘magit-cherry-donate’) + + This command moves the selected COMMITS from the current branch + onto another existing BRANCH, removing them from the former. When + this command succeeds, then the same branch is current as before. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + +‘A n’ (‘magit-cherry-spinout’) + + This command moves the selected COMMITS from the current branch + onto a new branch BRANCH, removing them from the former. When this + command succeeds, then the same branch is current as before. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + +‘A s’ (‘magit-cherry-spinoff’) + + This command moves the selected COMMITS from the current branch + onto a new branch BRANCH, removing them from the former. When this + command succeeds, then the new branch is checked out. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + + When a cherry-pick or revert is in progress, then the transient +instead features the following suffix commands. + +‘A A’ (‘magit-sequence-continue’) + + Resume the current cherry-pick or revert sequence. + +‘A s’ (‘magit-sequence-skip’) + + Skip the stopped at commit during a cherry-pick or revert sequence. + +‘A a’ (‘magit-sequence-abort’) + + Abort the current cherry-pick or revert sequence. This discards + all changes made since the sequence started. + +* Menu: + +* Reverting:: + + +File: magit.info, Node: Reverting, Up: Cherry Picking + +6.10.1 Reverting +---------------- + +‘V’ (‘magit-revert’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no cherry-pick or revert is in progress, then the transient +features the following suffix commands. + +‘V V’ (‘magit-revert-and-commit’) + + Revert a commit by creating a new commit. Prompt for a commit, + defaulting to the commit at point. If the region selects multiple + commits, then revert all of them, without prompting. + +‘V v’ (‘magit-revert-no-commit’) + + Revert a commit by applying it in reverse to the working tree. + Prompt for a commit, defaulting to the commit at point. If the + region selects multiple commits, then revert all of them, without + prompting. + + When a cherry-pick or revert is in progress, then the transient +instead features the following suffix commands. + +‘V A’ (‘magit-sequence-continue’) + + Resume the current cherry-pick or revert sequence. + +‘V s’ (‘magit-sequence-skip’) + + Skip the stopped at commit during a cherry-pick or revert sequence. + +‘V a’ (‘magit-sequence-abort’) + + Abort the current cherry-pick or revert sequence. This discards + all changes made since the sequence started. + + +File: magit.info, Node: Resetting, Next: Stashing, Prev: Cherry Picking, Up: Manipulating + +6.11 Resetting +============== + +Also see *note (gitman)git-reset::. + +‘x’ (‘magit-reset-quickly’) + + Reset the ‘HEAD’ and index to some commit read from the user and + defaulting to the commit at point, and possibly also reset the + working tree. With a prefix argument reset the working tree + otherwise don’t. + +‘X m’ (‘magit-reset-mixed’) + + Reset the ‘HEAD’ and index to some commit read from the user and + defaulting to the commit at point. The working tree is kept as-is. + +‘X s’ (‘magit-reset-soft’) + + Reset the ‘HEAD’ to some commit read from the user and defaulting + to the commit at point. The index and the working tree are kept + as-is. + +‘X h’ (‘magit-reset-hard’) + + Reset the ‘HEAD’, index, and working tree to some commit read from + the user and defaulting to the commit at point. + +‘X i’ (‘magit-reset-index’) + + Reset the index to some commit read from the user and defaulting to + the commit at point. Keep the ‘HEAD’ and working tree as-is, so if + the commit refers to the ‘HEAD’, then this effectively unstages all + changes. + +‘X w’ (‘magit-reset-worktree’) + + Reset the working tree to some commit read from the user and + defaulting to the commit at point. Keep the ‘HEAD’ and index + as-is. + +‘X f’ (‘magit-file-checkout’) + + Update file in the working tree and index to the contents from a + revision. Both the revision and file are read from the user. + + +File: magit.info, Node: Stashing, Prev: Resetting, Up: Manipulating + +6.12 Stashing +============= + +Also see *note (gitman)git-stash::. + +‘z’ (‘magit-stash’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘z z’ (‘magit-stash-both’) + + Create a stash of the index and working tree. Untracked files are + included according to infix arguments. One prefix argument is + equivalent to ‘--include-untracked’ while two prefix arguments are + equivalent to ‘--all’. + +‘z i’ (‘magit-stash-index’) + + Create a stash of the index only. Unstaged and untracked changes + are not stashed. + +‘z w’ (‘magit-stash-worktree’) + + Create a stash of unstaged changes in the working tree. Untracked + files are included according to infix arguments. One prefix + argument is equivalent to ‘--include-untracked’ while two prefix + arguments are equivalent to ‘--all’. + +‘z x’ (‘magit-stash-keep-index’) + + Create a stash of the index and working tree, keeping index intact. + Untracked files are included according to infix arguments. One + prefix argument is equivalent to ‘--include-untracked’ while two + prefix arguments are equivalent to ‘--all’. + +‘z Z’ (‘magit-snapshot-both’) + + Create a snapshot of the index and working tree. Untracked files + are included according to infix arguments. One prefix argument is + equivalent to ‘--include-untracked’ while two prefix arguments are + equivalent to ‘--all’. + +‘z I’ (‘magit-snapshot-index’) + + Create a snapshot of the index only. Unstaged and untracked + changes are not stashed. + +‘z W’ (‘magit-snapshot-worktree’) + + Create a snapshot of unstaged changes in the working tree. + Untracked files are included according to infix arguments. One + prefix argument is equivalent to ‘--include-untracked’ while two + prefix arguments are equivalent to ‘--all’-. + +‘z a’ (‘magit-stash-apply’) + + Apply a stash to the working tree. Try to preserve the stash + index. If that fails because there are staged changes, apply + without preserving the stash index. + +‘z p’ (‘magit-stash-pop’) + + Apply a stash to the working tree and remove it from stash list. + Try to preserve the stash index. If that fails because there are + staged changes, apply without preserving the stash index and forgo + removing the stash. + +‘z k’ (‘magit-stash-drop’) + + Remove a stash from the stash list. When the region is active, + offer to drop all contained stashes. + +‘z v’ (‘magit-stash-show’) + + Show all diffs of a stash in a buffer. + +‘z b’ (‘magit-stash-branch’) + + Create and checkout a new BRANCH from STASH. The branch starts at + the commit that was current when the stash was created. + +‘z B’ (‘magit-stash-branch-here’) + + Create and checkout a new BRANCH using ‘magit-branch’ with the + current branch or ‘HEAD’ as the starting-point. Then apply STASH, + dropping it if it applies cleanly. + +‘z f’ (‘magit-stash-format-patch’) + + Create a patch from STASH. + +‘k’ (‘magit-stash-clear’) + + Remove all stashes saved in REF’s reflog by deleting REF. + +‘z l’ (‘magit-stash-list’) + + List all stashes in a buffer. + + -- User Option: magit-stashes-margin + + This option specifies whether the margin is initially shown in + stashes buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + + • AUTHOR controls whether the name of the author is also shown + by default. + + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: magit.info, Node: Transferring, Next: Miscellaneous, Prev: Manipulating, Up: Top + +7 Transferring +************** + +* Menu: + +* Remotes:: +* Fetching:: +* Pulling:: +* Pushing:: +* Plain Patches:: +* Maildir Patches:: + + +File: magit.info, Node: Remotes, Next: Fetching, Up: Transferring + +7.1 Remotes +=========== + +* Menu: + +* Remote Commands:: +* Remote Git Variables:: + + +File: magit.info, Node: Remote Commands, Next: Remote Git Variables, Up: Remotes + +7.1.1 Remote Commands +--------------------- + +The transient prefix command ‘magit-remote’ is used to add remotes and +to make changes to existing remotes. This command only deals with +remotes themselves, not with branches or the transfer of commits. Those +features are available from separate transient commands. + + Also see *note (gitman)git-remote::. + +‘M’ (‘magit-remote’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + By default it also binds and displays the values of some + remote-related Git variables and allows changing their values. + + -- User Option: magit-remote-direct-configure + + This option controls whether remote-related Git variables are + accessible directly from the transient ‘magit-remote’. + + If ‘t’ (the default) and a local branch is checked out, then + ‘magit-remote’ features the variables for the upstream remote of + that branch, or if ‘HEAD’ is detached, for ‘origin’, provided that + exists. + + If ‘nil’, then ‘magit-remote-configure’ has to be used to do so. + +‘M C’ (‘magit-remote-configure’) + + This transient prefix command binds commands that set the value of + remote-related variables and displays them in a temporary buffer + until the transient is exited. + + With a prefix argument, this command always prompts for a remote. + + Without a prefix argument this depends on whether it was invoked as + a suffix of ‘magit-remote’ and on the + ‘magit-remote-direct-configure’ option. If ‘magit-remote’ already + displays the variables for the upstream, then it does not make + sense to invoke another transient that displays them for the same + remote. In that case this command prompts for a remote. + + The variables are described in *note Remote Git Variables::. + +‘M a’ (‘magit-remote-add’) + + This command add a remote and fetches it. The remote name and url + are read in the minibuffer. + +‘M r’ (‘magit-remote-rename’) + + This command renames a remote. Both the old and the new names are + read in the minibuffer. + +‘M u’ (‘magit-remote-set-url’) + + This command changes the url of a remote. Both the remote and the + new url are read in the minibuffer. + +‘M k’ (‘magit-remote-remove’) + + This command deletes a remote, read in the minibuffer. + +‘M p’ (‘magit-remote-prune’) + + This command removes stale remote-tracking branches for a remote + read in the minibuffer. + +‘M P’ (‘magit-remote-prune-refspecs’) + + This command removes stale refspecs for a remote read in the + minibuffer. + + A refspec is stale if there no longer exists at least one branch on + the remote that would be fetched due to that refspec. A stale + refspec is problematic because its existence causes Git to refuse + to fetch according to the remaining non-stale refspecs. + + If only stale refspecs remain, then this command offers to either + delete the remote or to replace the stale refspecs with the default + refspec ("+refs/heads/*:refs/remotes/REMOTE/*"). + + This command also removes the remote-tracking branches that were + created due to the now stale refspecs. Other stale branches are + not removed. + + -- User Option: magit-remote-add-set-remote.pushDefault + + This option controls whether the user is asked whether they want to + set ‘remote.pushDefault’ after adding a remote. + + If ‘ask’, then users is always ask. If ‘ask-if-unset’, then the + user is only if the variable isn’t set already. If ‘nil’, then the + user isn’t asked and the variable isn’t set. If the value is a + string, then the variable is set without the user being asked, + provided that the name of the added remote is equal to that string + and the variable isn’t already set. + + +File: magit.info, Node: Remote Git Variables, Prev: Remote Commands, Up: Remotes + +7.1.2 Remote Git Variables +-------------------------- + +These variables can be set from the transient prefix command +‘magit-remote-configure’. By default they can also be set from +‘magit-remote’. See *note Remote Commands::. + + -- Variable: remote.NAME.url + + This variable specifies the url of the remote named NAME. It can + have multiple values. + + -- Variable: remote.NAME.fetch + + The refspec used when fetching from the remote named NAME. It can + have multiple values. + + -- Variable: remote.NAME.pushurl + + This variable specifies the url used for fetching from the remote + named NAME. If it is not specified, then ‘remote.NAME.url’ is used + instead. It can have multiple values. + + -- Variable: remote.NAME.push + + The refspec used when pushing to the remote named NAME. It can + have multiple values. + + -- Variable: remote.NAME.tagOpts + + This variable specifies what tags are fetched by default. If the + value is ‘--no-tags’ then no tags are fetched. If the value is + ‘--tags’, then all tags are fetched. If this variable has no + value, then only tags are fetched that are reachable from fetched + branches. + + +File: magit.info, Node: Fetching, Next: Pulling, Prev: Remotes, Up: Transferring + +7.2 Fetching +============ + +Also see *note (gitman)git-fetch::. For information about the upstream +and the push-remote, see *note The Two Remotes::. + +‘f’ (‘magit-fetch’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘f p’ (‘magit-fetch-from-pushremote’) + + This command fetches from the current push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +‘f u’ (‘magit-fetch-from-upstream’) + + This command fetch from the upstream of the current branch. + + If the upstream is configured for the current branch and names an + existing remote, then use that. Otherwise try to use another + remote: If only a single remote is configured, then use that. + Otherwise if a remote named "origin" exists, then use that. + + If no remote can be determined, then this command is not available + from the ‘magit-fetch’ transient prefix and invoking it directly + results in an error. + +‘f e’ (‘magit-fetch-other’) + + This command fetch from a repository read from the minibuffer. + +‘f o’ (‘magit-fetch-branch’) + + This command fetches a branch from a remote, both of which are read + from the minibuffer. + +‘f r’ (‘magit-fetch-refspec’) + + This command fetches from a remote using an explicit refspec, both + of which are read from the minibuffer. + +‘f a’ (‘magit-fetch-all’) + + This command fetches from all remotes. + +‘f m’ (‘magit-submodule-fetch’) + + This command fetches all submodules. With a prefix argument it + fetches all remotes of all submodules. + + -- User Option: magit-pull-or-fetch + + By default fetch and pull commands are available from separate + transient prefix command. Setting this to ‘t’ adds some (but not + all) of the above suffix commands to the ‘magit-pull’ transient. + + If you do that, then you might also want to change the key binding + for these prefix commands, e.g.: + + (setq magit-pull-or-fetch t) + (define-key magit-mode-map "f" 'magit-pull) ; was magit-fetch + (define-key magit-mode-map "F" nil) ; was magit-pull + + +File: magit.info, Node: Pulling, Next: Pushing, Prev: Fetching, Up: Transferring + +7.3 Pulling +=========== + +Also see *note (gitman)git-pull::. For information about the upstream +and the push-remote, see *note The Two Remotes::. + +‘F’ (‘magit-pull’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +‘F p’ (‘magit-pull-from-pushremote’) + + This command pulls from the push-remote of the current branch. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +‘F u’ (‘magit-pull-from-upstream’) + + This command pulls from the upstream of the current branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +‘F e’ (‘magit-pull-branch’) + + This command pulls from a branch read in the minibuffer. + + +File: magit.info, Node: Pushing, Next: Plain Patches, Prev: Pulling, Up: Transferring + +7.4 Pushing +=========== + +Also see *note (gitman)git-push::. For information about the upstream +and the push-remote, see *note The Two Remotes::. + +‘P’ (‘magit-push’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘P p’ (‘magit-push-current-to-pushremote’) + + This command pushes the current branch to its push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +‘P u’ (‘magit-push-current-to-upstream’) + + This command pushes the current branch to its upstream branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +‘P e’ (‘magit-push-current’) + + This command pushes the current branch to a branch read in the + minibuffer. + +‘P o’ (‘magit-push-other’) + + This command pushes an arbitrary branch or commit somewhere. Both + the source and the target are read in the minibuffer. + +‘P r’ (‘magit-push-refspecs’) + + This command pushes one or multiple refspecs to a remote, both of + which are read in the minibuffer. + + To use multiple refspecs, separate them with commas. Completion is + only available for the part before the colon, or when no colon is + used. + +‘P m’ (‘magit-push-matching’) + + This command pushes all matching branches to another repository. + + If only one remote exists, then push to that. Otherwise prompt for + a remote, offering the remote configured for the current branch as + default. + +‘P t’ (‘magit-push-tags’) + + This command pushes all tags to another repository. + + If only one remote exists, then push to that. Otherwise prompt for + a remote, offering the remote configured for the current branch as + default. + +‘P T’ (‘magit-push-tag’) + + This command pushes a tag to another repository. + + Two more push commands exist, which by default are not available from +the push transient. See their doc-strings for instructions on how to +add them to the transient. + + -- Command: magit-push-implicitly args + + This command pushes somewhere without using an explicit refspec. + + This command simply runs ‘git push -v [ARGS]’. ARGS are the infix + arguments. No explicit refspec arguments are used. Instead the + behavior depends on at least these Git variables: ‘push.default’, + ‘remote.pushDefault’, ‘branch..pushRemote’, + ‘branch..remote’, ‘branch..merge’, and + ‘remote..push’. + + -- Command: magit-push-to-remote remote args + + This command pushes to the remote REMOTE without using an explicit + refspec. The remote is read in the minibuffer. + + This command simply runs ‘git push -v [ARGS] REMOTE’. ARGS are the + infix arguments. No refspec arguments are used. Instead the + behavior depends on at least these Git variables: ‘push.default’, + ‘remote.pushDefault’, ‘branch..pushRemote’, + ‘branch..remote’, ‘branch..merge’, and + ‘remote..push’. + + +File: magit.info, Node: Plain Patches, Next: Maildir Patches, Prev: Pushing, Up: Transferring + +7.5 Plain Patches +================= + +‘W’ (‘magit-patch’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘W c’ (‘magit-patch-create’) + + This command creates patches for a set commits. If the region + marks several commits, then it creates patches for all of them. + Otherwise it functions as a transient prefix command, which + features several infix arguments and binds itself as a suffix + command. When this command is invoked as a suffix of itself, then + it creates a patch using the specified infix arguments. + +‘w a’ (‘magit-patch-apply’) + + This command applies a patch. This is a transient prefix command, + which features several infix arguments and binds itself as a suffix + command. When this command is invoked as a suffix of itself, then + it applies a patch using the specified infix arguments. + +‘W s’ (‘magit-patch-save’) + + This command creates a patch from the current diff. + + Inside ‘magit-diff-mode’ or ‘magit-revision-mode’ buffers, ‘C-x + C-w’ is also bound to this command. + + It is also possible to save a plain patch file by using ‘C-x C-w’ +inside a ‘magit-diff-mode’ or ‘magit-revision-mode’ buffer. + + +File: magit.info, Node: Maildir Patches, Prev: Plain Patches, Up: Transferring + +7.6 Maildir Patches +=================== + +Also see *note (gitman)git-am::. and *note (gitman)git-apply::. + +‘w’ (‘magit-am’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘w w’ (‘magit-am-apply-patches’) + + This command applies one or more patches. If the region marks + files, then those are applied as patches. Otherwise this command + reads a file-name in the minibuffer, defaulting to the file at + point. + +‘w m’ (‘magit-am-apply-maildir’) + + This command applies patches from a maildir. + +‘w a’ (‘magit-patch-apply’) + + This command applies a plain patch. For a longer description see + *note Plain Patches::. This command is only available from the + ‘magit-am’ transient for historic reasons. + + When an "am" operation is in progress, then the transient instead +features the following suffix commands. + +‘w w’ (‘magit-am-continue’) + + This command resumes the current patch applying sequence. + +‘w s’ (‘magit-am-skip’) + + This command skips the stopped at patch during a patch applying + sequence. + +‘w a’ (‘magit-am-abort’) + + This command aborts the current patch applying sequence. This + discards all changes made since the sequence started. + + +File: magit.info, Node: Miscellaneous, Next: Customizing, Prev: Transferring, Up: Top + +8 Miscellaneous +*************** + +* Menu: + +* Tagging:: +* Notes:: +* Submodules:: +* Subtree:: +* Worktree:: +* Common Commands:: +* Wip Modes:: +* Minor Mode for Buffers Visiting Files:: +* Minor Mode for Buffers Visiting Blobs:: + + +File: magit.info, Node: Tagging, Next: Notes, Up: Miscellaneous + +8.1 Tagging +=========== + +Also see *note (gitman)git-tag::. + +‘t’ (‘magit-tag’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘t t’ (‘magit-tag-create’) + + This command creates a new tag with the given NAME at REV. With a + prefix argument it creates an annotate tag. + +‘t r’ (‘magit-tag-release’) + + This commands creates an annotated release tag. It assumes that + release tags match ‘magit-release-tag-regexp’. + + First it prompts for the name of the new tag using the highest + existing tag as initial input and leaving it to the user to + increment the desired part of the version string. + + Then it prompts for the message of the new tag. The proposed tag + message is based on the message of the highest tag, provided that + that contains the corresponding version string and substituting the + new version string for that. Otherwise it proposes something like + "Foo-Bar 1.2.3", given, for example, a TAG "v1.2.3" and a + repository located at something like "/path/to/foo-bar". + + Then it calls "git tag –annotate –sign -m MSG TAG" to create the + tag, regardless of whether these arguments are enabled in the + transient. Finally it shows the refs buffer to let the user + quickly review the result. + +‘t k’ (‘magit-tag-delete’) + + This command deletes one or more tags. If the region marks + multiple tags (and nothing else), then it offers to delete those. + Otherwise, it prompts for a single tag to be deleted, defaulting to + the tag at point. + +‘t p’ (‘magit-tag-prune’) + + This command offers to delete tags missing locally from REMOTE, and + vice versa. + + +File: magit.info, Node: Notes, Next: Submodules, Prev: Tagging, Up: Miscellaneous + +8.2 Notes +========= + +Also see *note (gitman)git-notes::. + +‘T’ (‘magit-notes’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +‘T T’ (‘magit-notes-edit’) + + Edit the note attached to a commit, defaulting to the commit at + point. + + By default use the value of Git variable ‘core.notesRef’ or + "refs/notes/commits" if that is undefined. + +‘T r’ (‘magit-notes-remove’) + + Remove the note attached to a commit, defaulting to the commit at + point. + + By default use the value of Git variable ‘core.notesRef’ or + "refs/notes/commits" if that is undefined. + +‘T p’ (‘magit-notes-prune’) + + Remove notes about unreachable commits. + + It is possible to merge one note ref into another. That may result +in conflicts which have to resolved in the temporary worktree +".git/NOTES_MERGE_WORKTREE". + +‘T m’ (‘magit-notes-merge’) + + Merge the notes of a ref read from the user into the current notes + ref. The current notes ref is the value of Git variable + ‘core.notesRef’ or "refs/notes/commits" if that is undefined. + + When a notes merge is in progress then the transient features the +following suffix commands, instead of those listed above. + +‘T c’ (‘magit-notes-merge-commit’) + + Commit the current notes ref merge, after manually resolving + conflicts. + +‘T a’ (‘magit-notes-merge-abort’) + + Abort the current notes ref merge. + + The following variables control what notes reference ‘magit-notes-*’, +‘git notes’ and ‘git show’ act on and display. Both the local and +global values are displayed and can be modified. + + -- Variable: core.notesRef + + This variable specifies the notes ref that is displayed by default + and which commands act on by default. + + -- Variable: notes.displayRef + + This variable specifies additional notes ref to be displayed in + addition to the ref specified by ‘core.notesRef’. It can have + multiple values and may end with ‘*’ to display all refs in the + ‘refs/notes/’ namespace (or ‘**’ if some names contain slashes). + + +File: magit.info, Node: Submodules, Next: Subtree, Prev: Notes, Up: Miscellaneous + +8.3 Submodules +============== + +Also see *note (gitman)git-submodule::. + +* Menu: + +* Listing Submodules:: +* Submodule Transient:: + + +File: magit.info, Node: Listing Submodules, Next: Submodule Transient, Up: Submodules + +8.3.1 Listing Submodules +------------------------ + +The command ‘magit-list-submodules’ displays a list of the current +repository’s submodules in a separate buffer. It’s also possible to +display information about submodules directly in the status buffer of +the super-repository by adding ‘magit-insert-submodules’ to the hook +‘magit-status-sections-hook’ as described in *note Status Module +Sections::. + + -- Command: magit-list-submodules + + This command displays a list of the current repository’s submodules + in a separate buffer. + + It can be invoked by pressing ‘RET’ on the section titled + "Modules". + + -- User Option: magit-submodule-list-columns + + This option controls what columns are displayed by the command + ‘magit-list-submodules’ and how they are displayed. + + Each element has the form ‘(HEADER WIDTH FORMAT PROPS)’. + + HEADER is the string displayed in the header. WIDTH is the width + of the column. FORMAT is a function that is called with one + argument, the repository identification (usually its basename), and + with ‘default-directory’ bound to the toplevel of its working tree. + It has to return a string to be inserted or nil. PROPS is an alist + that supports the keys ‘:right-align’ and ‘:pad-right’. + + -- Function: magit-insert-submodules + + Insert sections for all submodules. For each section insert the + path, the branch, and the output of ‘git describe --tags’, or, + failing that, the abbreviated HEAD commit hash. + + Press ‘RET’ on such a submodule section to show its own status + buffer. Press ‘RET’ on the "Modules" section to display a list of + submodules in a separate buffer. This shows additional information + not displayed in the super-repository’s status buffer. + + +File: magit.info, Node: Submodule Transient, Prev: Listing Submodules, Up: Submodules + +8.3.2 Submodule Transient +------------------------- + +‘o’ (‘magit-submodule’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + Some of the below commands default to act on the modules that are +selected using the region. For brevity their description talk about +"the selected modules", but if no modules are selected, then they act on +the current module instead, or if point isn’t on a module, then the read +a single module to act on. With a prefix argument these commands ignore +the selection and the current module and instead act on all suitable +modules. + +‘o a’ (‘magit-submodule-add’) + + This commands adds the repository at URL as a module. Optional + PATH is the path to the module relative to the root of the + super-project. If it is nil then the path is determined based on + URL. + +‘o r’ (‘magit-submodule-register’) + + This command registers the selected modules by copying their urls + from ".gitmodules" to "$GIT_DIR/config". These values can then be + edited before running ‘magit-submodule-populate’. If you don’t + need to edit any urls, then use the latter directly. + +‘o p’ (‘magit-submodule-populate’) + + This command creates the working directory or directories of the + selected modules, checking out the recorded commits. + +‘o u’ (‘magit-submodule-update’) + + This command updates the selected modules checking out the recorded + commits. + +‘o s’ (‘magit-submodule-synchronize’) + + This command synchronizes the urls of the selected modules, copying + the values from ".gitmodules" to the ".git/config" of the + super-project as well those of the modules. + +‘o d’ (‘magit-submodule-unpopulate’) + + This command removes the working directory of the selected modules. + +‘o l’ (‘magit-list-submodules’) + + This command displays a list of the current repository’s modules. + +‘o f’ (‘magit-fetch-modules’) + + This command fetches all modules. + + Option ‘magit-fetch-modules-jobs’ controls how many submodules are + being fetched in parallel. Also fetch the super-repository, + because ‘git fetch’ does not support not doing that. With a prefix + argument fetch all remotes. + + +File: magit.info, Node: Subtree, Next: Worktree, Prev: Submodules, Up: Miscellaneous + +8.4 Subtree +=========== + +Also see *note (gitman)git-subtree::. + +‘O’ (‘magit-subtree’) + + This transient prefix command binds the two sub-transients; one for + importing a subtree and one for exporting a subtree. + +‘O i’ (‘magit-subtree-import’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + The suffixes of this command import subtrees. + + If the ‘--prefix’ argument is set, then the suffix commands use + that prefix without prompting the user. If it is unset, then they + read the prefix in the minibuffer. + +‘O i a’ (‘magit-subtree-add’) + + This command adds COMMIT from REPOSITORY as a new subtree at + PREFIX. + +‘O i c’ (‘magit-subtree-add-commit’) + + This command add COMMIT as a new subtree at PREFIX. + +‘O i m’ (‘magit-subtree-merge’) + + This command merges COMMIT into the PREFIX subtree. + +‘O i f’ (‘magit-subtree-pull’) + + This command pulls COMMIT from REPOSITORY into the PREFIX subtree. + +‘O e’ (‘magit-subtree-export’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + The suffixes of this command export subtrees. + + If the ‘--prefix’ argument is set, then the suffix commands use + that prefix without prompting the user. If it is unset, then they + read the prefix in the minibuffer. + +‘O e p’ (‘magit-subtree-push’) + + This command extract the history of the subtree PREFIX and pushes + it to REF on REPOSITORY. + +‘O e s’ (‘magit-subtree-split’) + + This command extracts the history of the subtree PREFIX. + + +File: magit.info, Node: Worktree, Next: Common Commands, Prev: Subtree, Up: Miscellaneous + +8.5 Worktree +============ + +Also see *note (gitman)git-worktree::. + +‘%’ (‘magit-worktree’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +‘% b’ (‘magit-worktree-checkout’) + + Checkout BRANCH in a new worktree at PATH. + +‘% c’ (‘magit-worktree-branch’) + + Create a new BRANCH and check it out in a new worktree at PATH. + +‘% m’ (‘magit-worktree-move’) + + Move an existing worktree to a new PATH. + +‘% k’ (‘magit-worktree-delete’) + + Delete a worktree, defaulting to the worktree at point. The + primary worktree cannot be deleted. + +‘% g’ (‘magit-worktree-status’) + + Show the status for the worktree at point. + + If there is no worktree at point, then read one in the minibuffer. + If the worktree at point is the one whose status is already being + displayed in the current buffer, then show it in Dired instead. + + +File: magit.info, Node: Common Commands, Next: Wip Modes, Prev: Worktree, Up: Miscellaneous + +8.6 Common Commands +=================== + +These are some of the commands that can be used in all buffers whose +major-modes derive from ‘magit-mode’. There are other common commands +beside the ones below, but these didn’t fit well anywhere else. + +‘M-w’ (‘magit-copy-section-value’) + + This command saves the value of the current section to the + ‘kill-ring’, and, provided that the current section is a commit, + branch, or tag section, it also pushes the (referenced) revision to + the ‘magit-revision-stack’. + + When the current section is a branch or a tag, and a prefix + argument is used, then it saves the revision at its tip to the + ‘kill-ring’ instead of the reference name. + + When the region is active, this command saves that to the + ‘kill-ring’, like ‘kill-ring-save’ would, instead of behaving as + described above. If a prefix argument is used and the region is + within a hunk, it strips the outer diff marker column before saving + the text. + +‘C-w’ (‘magit-copy-buffer-revision’) + + This command saves the revision being displayed in the current + buffer to the ‘kill-ring’ and also pushes it to the + ‘magit-revision-stack’. It is mainly intended for use in + ‘magit-revision-mode’ buffers, the only buffers where it is always + unambiguous exactly which revision should be saved. + + Most other Magit buffers usually show more than one revision, in + some way or another, so this command has to select one of them, and + that choice might not always be the one you think would have been + the best pick. + + Outside of Magit ‘M-w’ and ‘C-w’ are usually bound to +‘kill-ring-save’ and ‘kill-region’, and these commands would also be +useful in Magit buffers. Therefore when the region is active, then both +of these commands behave like ‘kill-ring-save’ instead of as described +above. + diff --git a/elpa/magit-20200318.1224/magit.info-2 b/elpa/magit-20200318.1224/magit.info-2 new file mode 100644 index 00000000..36899fed --- /dev/null +++ b/elpa/magit-20200318.1224/magit.info-2 @@ -0,0 +1,3525 @@ +This is magit.info, produced by makeinfo version 6.5 from magit.texi. + + Copyright (C) 2015-2020 Jonas Bernoulli + + You can redistribute this document 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. + + This document 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. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Magit: (magit). Using Git from Emacs with Magit. +END-INFO-DIR-ENTRY + + +File: magit.info, Node: Wip Modes, Next: Minor Mode for Buffers Visiting Files, Prev: Common Commands, Up: Miscellaneous + +8.7 Wip Modes +============= + +Git keeps *committed* changes around long enough for users to recover +changes they have accidentally deleted. It does so by not garbage +collecting any committed but no longer referenced objects for a certain +period of time, by default 30 days. + + But Git does *not* keep track of *uncommitted* changes in the working +tree and not even the index (the staging area). Because Magit makes it +so convenient to modify uncommitted changes, it also makes it easy to +shoot yourself in the foot in the process. + + For that reason Magit provides a global mode that saves *tracked* +files to work-in-progress references after or before certain actions. +(At present untracked files are never saved and for technical reasons +nothing is saved before the first commit has been created). + + Two separate work-in-progress references are used to track the state +of the index and of the working tree: ‘refs/wip/index/’ and +‘refs/wip/wtree/’, where ‘’ is the full ref of the +current branch, e.g. ‘refs/heads/master’. When the ‘HEAD’ is detached +then ‘HEAD’ is used in place of ‘’. + + Checking out another branch (or detaching ‘HEAD’) causes the use of +different wip refs for subsequent changes. + + -- User Option: magit-wip-mode + + When this mode is enabled, then uncommitted changes are committed + to dedicated work-in-progress refs whenever appropriate (i.e. when + dataloss would be a possibility otherwise). + + Setting this variable directly does not take effect; either use the + Custom interface to do so or call the respective mode function. + + For historic reasons this mode is implemented on top of four other + ‘magit-wip-*’ modes, which can also be used individually, if you + want finer control over when the wip refs are updated; but that is + discouraged. See *note Legacy Wip Modes::. + + To view the log for a branch and its wip refs use the commands +‘magit-wip-log’ and ‘magit-wip-log-current’. You should use ‘--graph’ +when using these commands. + + -- Command: magit-wip-log + + This command shows the log for a branch and its wip refs. With a + negative prefix argument only the worktree wip ref is shown. + + The absolute numeric value of the prefix argument controls how many + "branches" of each wip ref are shown. This is only relevant if the + value of ‘magit-wip-merge-branch’ is ‘nil’. + + -- Command: magit-wip-log-current + + This command shows the log for the current branch and its wip refs. + With a negative prefix argument only the worktree wip ref is shown. + + The absolute numeric value of the prefix argument controls how many + "branches" of each wip ref are shown. This is only relevant if the + value of ‘magit-wip-merge-branch’ is ‘nil’. + +‘X w’ (‘magit-reset-worktree’) + + This command resets the working tree to some commit read from the + user and defaulting to the commit at point, while keeping the + ‘HEAD’ and index as-is. + + This can be used to restore files to the state committed to a wip + ref. Note that this will discard any unstaged changes that might + have existed before invoking this command (but of course only after + committing that to the working tree wip ref). + + Note that even if you enable ‘magit-wip-mode’ this won’t give you +perfect protection. The most likely scenario for losing changes despite +the use of ‘magit-wip-mode’ is making a change outside Emacs and then +destroying it also outside Emacs. In some such a scenario, Magit, being +an Emacs package, didn’t get the opportunity to keep you from shooting +yourself in the foot. + + When you are unsure whether Magit did commit a change to the wip +refs, then you can explicitly request that all changes to all tracked +files are being committed. + +‘M-x magit-wip-commit’ (‘magit-wip-commit’) + + This command commits all changes to all tracked files to the index + and working tree work-in-progress refs. Like the modes described + above, it does not commit untracked files, but it does check all + tracked files for changes. Use this command when you suspect that + the modes might have overlooked a change made outside Emacs/Magit. + + -- User Option: magit-wip-namespace + + The namespace used for work-in-progress refs. It has to end with a + slash. The wip refs are named ‘index/’ and + ‘wtree/’. When snapshots are created while + the ‘HEAD’ is detached then ‘HEAD’ is used in place of + ‘’. + + -- User Option: magit-wip-mode-lighter + + Mode-line lighter for ‘magit-wip--mode’. + +* Menu: + +* Wip Graph:: +* Legacy Wip Modes:: + + +File: magit.info, Node: Wip Graph, Next: Legacy Wip Modes, Up: Wip Modes + +8.7.1 Wip Graph +--------------- + + -- User Option: magit-wip-merge-branch + + This option controls whether the current branch is merged into the + wip refs after a new commit was created on the branch. + + If non-nil and the current branch has new commits, then it is + merged into the wip ref before creating a new wip commit. This + makes it easier to inspect wip history and the wip commits are + never garbage collected. + + If nil and the current branch has new commits, then the wip ref is + reset to the tip of the branch before creating a new wip commit. + With this setting wip commits are eventually garbage collected. + + When ‘magit-wip-merge-branch’ is ‘t’, then the history looks like +this: + + *--*--*--*--*--* refs/wip/index/refs/heads/master + / / / + A-----B-----C refs/heads/master + + When ‘magit-wip-merge-branch’ is ‘nil’, then creating a commit on the +real branch and then making a change causes the wip refs to be recreated +to fork from the new commit. But the old commits on the wip refs are +not lost. They are still available from the reflog. To make it easier +to see when the fork point of a wip ref was changed, an additional +commit with the message "restart autosaving" is created on it (‘xxO’ +commits below are such boundary commits). + + Starting with + + BI0---BI1 refs/wip/index/refs/heads/master + / + A---B refs/heads/master + \ + BW0---BW1 refs/wip/wtree/refs/heads/master + + and committing the staged changes and editing and saving a file would +result in + + BI0---BI1 refs/wip/index/refs/heads/master + / + A---B---C refs/heads/master + \ \ + \ CW0---CW1 refs/wip/wtree/refs/heads/master + \ + BW0---BW1 refs/wip/wtree/refs/heads/master@{2} + + The fork-point of the index wip ref is not changed until some change +is being staged. Likewise just checking out a branch or creating a +commit does not change the fork-point of the working tree wip ref. The +fork-points are not adjusted until there actually is a change that +should be committed to the respective wip ref. + + +File: magit.info, Node: Legacy Wip Modes, Prev: Wip Graph, Up: Wip Modes + +8.7.2 Legacy Wip Modes +---------------------- + +It is recommended that you use the mode ‘magit-wip-mode’ (which see) and +ignore the existence of the following modes, which are preserved for +historic reasons. + + Setting the following variables directly does not take effect; either +use the Custom interface to do so or call the respective mode functions. + + -- User Option: magit-wip-after-save-mode + + When this mode is enabled, then saving a buffer that visits a file + tracked in a Git repository causes its current state to be + committed to the working tree wip ref for the current branch. + + -- User Option: magit-wip-after-apply-mode + + When this mode is enabled, then applying (i.e. staging, unstaging, + discarding, reversing, and regularly applying) a change to a file + tracked in a Git repository causes its current state to be + committed to the index and/or working tree wip refs for the current + branch. + + If you only ever edit files using Emacs and only ever interact with +Git using Magit, then the above two modes should be enough to protect +each and every change from accidental loss. In practice nobody does +that. Two additional modes exists that do commit to the wip refs before +making changes that could cause the loss of earlier changes. + + -- User Option: magit-wip-before-change-mode + + When this mode is enabled, then certain commands commit the + existing changes to the files they are about to make changes to. + + -- User Option: magit-wip-initial-backup-mode + + When this mode is enabled, then the current version of a file is + committed to the worktree wip ref before the buffer visiting that + file is saved for the first time since the buffer was created. + + This backs up the same version of the file that ‘backup-buffer’ + would save. While ‘backup-buffer’ uses a backup file, this mode + uses the same worktree wip ref as used by the other Magit Wip + modes. Like ‘backup-buffer’, it only does this once; unless you + kill the buffer and visit the file again only one backup will be + created per Emacs session. + + This mode ignores the variables that affect ‘backup-buffer’ and can + be used along-side that function, which is recommended because it + only backs up files that are tracked in a Git repository. + + -- User Option: magit-wip-after-save-local-mode-lighter + + Mode-line lighter for ‘magit-wip-after-save-local-mode’. + + -- User Option: magit-wip-after-apply-mode-lighter + + Mode-line lighter for ‘magit-wip-after-apply-mode’. + + -- User Option: magit-wip-before-change-mode-lighter + + Mode-line lighter for ‘magit-wip-before-change-mode’. + + -- User Option: magit-wip-initial-backup-mode-lighter + + Mode-line lighter for ‘magit-wip-initial-backup-mode’. + + +File: magit.info, Node: Minor Mode for Buffers Visiting Files, Next: Minor Mode for Buffers Visiting Blobs, Prev: Wip Modes, Up: Miscellaneous + +8.8 Minor Mode for Buffers Visiting Files +========================================= + +The minor-mode ‘magit-file-mode’ enables certain Magit features in +file-visiting buffers belonging to a Git repository. The globalized +variant ‘global-magit-file-mode’ enables the local mode in all such +buffers. It is enabled by default. Currently the local mode only +establishes a few key bindings, but this might be extended in the +future. + + -- User Option: global-magit-file-mode + + Whether to establish certain Magit key bindings in all + file-visiting buffers belonging to any Git repository. This is + enabled by default. This globalized mode turns on the local + minor-mode ‘magit-file-mode’ in all suitable buffers. + + -- Variable: magit-file-mode-map + + This keymap is used by the local minor-mode ‘magit-file-mode’ and + establishes the key bindings described below. + + Note that the default binding for ‘magit-file-dispatch’ is very + cumbersome to use and that we recommend that you add a better + binding. + + Instead of ‘C-c M-g’ I would have preferred to use ‘C-c g’ because + (1) it is similar to ‘C-x g’ (the recommended global binding for + ‘~magit-status’), (2) we cannot use ‘C-c C-g’ because we have been + recommending that that be bound to ‘magit-dispatch’ for a long + time, (3) we cannot use ‘C-x C-g’ because that is a convenient way + of aborting the incomplete key sequence ‘C-x’, and most importantly + (4) it would make it much easier to type the next key (a suffix + binding) because most of those are letters. + + For example ‘C-c g b’ is much easier to type than ‘C-c M-g b’. For + suffix bindings that use uppercase letters, the default is just + horrible—having to use e.g. ‘C-c M-g B’ (‘Control+c Meta+g + Shift+b’) would drive anyone up the walls (or to Vim). + + However ‘C-c LETTER’ bindings are reserved for users (see *note + (elisp)Key Binding Conventions::). Packages are forbidden from + using those. Doing so anyway is considered heresy. Therefore if + you want a better binding, you have to add it yourself: + + (define-key magit-file-mode-map + (kbd "C-c g") 'magit-file-dispatch) + + The key bindings shown below assume that you have not improved the +binding for ‘magit-file-dispatch’. + +‘C-c M-g’ (‘magit-file-dispatch’) + + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +‘C-c M-g s’ (‘magit-stage-file’) + + Stage all changes to the file being visited in the current buffer. + +‘C-c M-g u’ (‘magit-unstage-file’) + + Unstage all changes to the file being visited in the current + buffer. + +‘C-c M-g c’ (‘magit-commit’) + + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. See *note Initiating a + Commit::. + +‘C-c M-g D’ (‘magit-diff’) + + This transient prefix command binds several diff suffix commands + and infix arguments and displays them in a temporary buffer until a + suffix is invoked. See *note Diffing::. + + This is the same command that ‘d’ is bound to in Magit buffers. If + this command is invoked from a file-visiting buffer, then the + initial value of the option (‘--’) that limits the diff to certain + file(s) is set to the visited file. + +‘C-c M-g d’ (‘magit-diff-buffer-file’) + + This command shows the diff for the file of blob that the current + buffer visits. + + -- User Option: magit-diff-buffer-file-locked + + This option controls whether ‘magit-diff-buffer-file’ uses a + dedicated buffer. See *note Modes and Buffers::. + +‘C-c M-g L’ (‘magit-log’) + + This transient prefix command binds several log suffix commands and + infix arguments and displays them in a temporary buffer until a + suffix is invoked. See *note Logging::. + + This is the same command that ‘l’ is bound to in Magit buffers. If + this command is invoked from a file-visiting buffer, then the + initial value of the option (‘--’) that limits the log to certain + file(s) is set to the visited file. + +‘C-c M-g l’ (‘magit-log-buffer-file’) + + This command shows the log for the file of blob that the current + buffer visits. Renames are followed when a prefix argument is used + or when ‘--follow’ is an active log argument. When the region is + active, the log is restricted to the selected line range. + +‘C-c M-g t’ (‘magit-log-trace-definition’) + + This command shows the log for the definition at point. + + -- User Option: magit-log-buffer-file-locked + + This option controls whether ‘magit-log-buffer-file’ uses a + dedicated buffer. See *note Modes and Buffers::. + +‘C-c M-g B’ (‘magit-blame’) + + This transient prefix command binds all blaming suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + For more information about this and the following commands also see + *note Blaming::. + + In addition to the ‘magit-blame’ sub-transient, the dispatch +transient also binds several blaming suffix commands directly. See +*note Blaming:: for information about those commands and bindings. + +‘C-c M-g e’ (‘magit-edit-line-commit’) + + This command makes the commit editable that added the current line. + + With a prefix argument it makes the commit editable that removes + the line, if any. The commit is determined using ‘git blame’ and + made editable using ‘git rebase --interactive’ if it is reachable + from ‘HEAD’, or by checking out the commit (or a branch that points + at it) otherwise. + +‘C-c M-g p’ (‘magit-blob-previous’) + + Visit the previous blob which modified the current file. + + There are a few additional commands that operate on a single file but +are not enabled in the file transient command by default: + + -- Command: magit-file-rename + + This command renames a file read from the user. + + -- Command: magit-file-delete + + This command deletes a file read from the user. + + -- Command: magit-file-untrack + + This command untracks a file read from the user. + + -- Command: magit-file-checkout + + This command updates a file in the working tree and index to the + contents from a revision. Both the revision and file are read from + the user. + + To enable them invoke the transient (‘C-c M-g’), enter "edit mode" +(‘C-x l’), set the "transient level" (‘C-x l’ again), enter ‘5’, and +leave edit mode (‘C-g’). Also see *note (transient)Enabling and +Disabling Suffixes::. + + +File: magit.info, Node: Minor Mode for Buffers Visiting Blobs, Prev: Minor Mode for Buffers Visiting Files, Up: Miscellaneous + +8.9 Minor Mode for Buffers Visiting Blobs +========================================= + +The ‘magit-blob-mode’ enables certain Magit features in blob-visiting +buffers. Such buffers can be created using ‘magit-find-file’ and some +of the commands mentioned below, which also take care of turning on this +minor mode. Currently this mode only establishes a few key bindings, +but this might be extended. + +‘p’ (‘magit-blob-previous’) + + Visit the previous blob which modified the current file. + +‘n’ (‘magit-blob-next’) + + Visit the next blob which modified the current file. + +‘q’ (‘magit-kill-this-buffer’) + + Kill the current buffer. + + +File: magit.info, Node: Customizing, Next: Plumbing, Prev: Miscellaneous, Up: Top + +9 Customizing +************* + +Both Git and Emacs are highly customizable. Magit is both a Git +porcelain as well as an Emacs package, so it makes sense to customize it +using both Git variables as well as Emacs options. However this +flexibility doesn’t come without problems, including but not limited to +the following. + + • Some Git variables automatically have an effect in Magit without + requiring any explicit support. Sometimes that is desirable - in + other cases, it breaks Magit. + + When a certain Git setting breaks Magit but you want to keep using + that setting on the command line, then that can be accomplished by + overriding the value for Magit only by appending something like + ‘("-c" "some.variable=compatible-value")’ to + ‘magit-git-global-arguments’. + + • Certain settings like ‘fetch.prune=true’ are respected by Magit + commands (because they simply call the respective Git command) but + their value is not reflected in the respective transient buffers. + In this case the ‘--prune’ argument in ‘magit-fetch’ might be + active or inactive, but that doesn’t keep the Git variable from + being honored by the suffix commands anyway. So pruning might + happen despite the ‘--prune’ arguments being displayed in a way + that seems to indicate that no pruning will happen. + + I intend to address these and similar issues in a future release. + +* Menu: + +* Per-Repository Configuration:: +* Essential Settings:: + + +File: magit.info, Node: Per-Repository Configuration, Next: Essential Settings, Up: Customizing + +9.1 Per-Repository Configuration +================================ + +Magit can be configured on a per-repository level using both Git +variables as well as Emacs options. + + To set a Git variable for one repository only, simply set it in +‘/path/to/repo/.git/config’ instead of ‘$HOME/.gitconfig’ or +‘/etc/gitconfig’. See *note (gitman)git-config::. + + Similarly, Emacs options can be set for one repository only by +editing ‘/path/to/repo/.dir-locals.el’. See *note (emacs)Directory +Variables::. For example to disable automatic refreshes of +file-visiting buffers in just one huge repository use this: + + • ‘/path/to/huge/repo/.dir-locals.el’ + + ((nil . ((magit-refresh-buffers . nil)))) + + It might only be costly to insert certain information into Magit +buffers for repositories that are exceptionally large, in which case you +can disable the respective section inserters just for that repository: + + • ‘/path/to/tag/invested/repo/.dir-locals.el’ + + ((magit-status-mode + . ((eval . (magit-disable-section-inserter 'magit-insert-tags-header))))) + + -- Function: magit-disable-section-inserter fn + + This function disables the section inserter FN in the current + repository. It is only intended for use in ‘.dir-locals.el’ and + ‘.dir-locals-2.el’. + + If you want to apply the same settings to several, but not all, +repositories then keeping the repository-local config files in sync +would quickly become annoying. To avoid that you can create config +files for certain classes of repositories (e.g. "huge repositories") +and then include those files in the per-repository config files. For +example: + + • ‘/path/to/huge/repo/.git/config’ + + [include] + path = /path/to/huge-gitconfig + + • ‘/path/to/huge-gitconfig’ + + [status] + showUntrackedFiles = no + + • ‘$HOME/.emacs.d/init.el’ + + (dir-locals-set-class-variables 'huge-git-repository + '((nil . ((magit-refresh-buffers . nil))))) + + (dir-locals-set-directory-class + "/path/to/huge/repo/" 'huge-git-repository) + + +File: magit.info, Node: Essential Settings, Prev: Per-Repository Configuration, Up: Customizing + +9.2 Essential Settings +====================== + +The next two sections list and discuss several variables that many users +might want to customize, for safety and/or performance reasons. + +* Menu: + +* Safety:: +* Performance:: + + +File: magit.info, Node: Safety, Next: Performance, Up: Essential Settings + +9.2.1 Safety +------------ + +This section discusses various variables that you might want to change +(or *not* change) for safety reasons. + + Git keeps *committed* changes around long enough for users to recover +changes they have accidentally been deleted. It does not do the same +for *uncommitted* changes in the working tree and not even the index +(the staging area). Because Magit makes it so easy to modify +uncommitted changes, it also makes it easy to shoot yourself in the foot +in the process. For that reason Magit provides three global modes that +save *tracked* files to work-in-progress references after or before +certain actions. See *note Wip Modes::. + + These modes are not enabled by default because of performance +concerns. Instead a lot of potentially destructive commands require +confirmation every time they are used. In many cases this can be +disabled by adding a symbol to ‘magit-no-confirm’ (see *note Completion +and Confirmation::). If you enable the various wip modes then you +should add ‘safe-with-wip’ to this list. + + Similarly it isn’t necessary to require confirmation before moving a +file to the system trash - if you trashed a file by mistake then you can +recover it from there. Option ‘magit-delete-by-moving-to-trash’ +controls whether the system trash is used, which is the case by default. +Nevertheless, ‘trash’ isn’t a member of ‘magit-no-confirm’ - you might +want to change that. + + By default buffers visiting files are automatically reverted when the +visited file changes on disk. This isn’t as risky as it might seem, but +to make an informed decision you should see *note Risk of Reverting +Automatically::. + + +File: magit.info, Node: Performance, Prev: Safety, Up: Essential Settings + +9.2.2 Performance +----------------- + +After Magit has run ‘git’ for side-effects, it also refreshes the +current Magit buffer and the respective status buffer. This is +necessary because otherwise outdated information might be displayed +without the user noticing. Magit buffers are updated by recreating +their content from scratch, which makes updating simpler and less +error-prone, but also more costly. Keeping it simple and just +re-creating everything from scratch is an old design decision and +departing from that will require major refactoring. + + I plan to do that in time for the next major release. I also intend +to create logs and diffs asynchronously, which should also help a lot +but also requires major refactoring. + + Meanwhile you can tell Magit to only automatically refresh the +current Magit buffer, but not the status buffer. If you do that, then +the status buffer is only refreshed automatically if it is the current +buffer. + + (setq magit-refresh-status-buffer nil) + + You should also check whether any third-party packages have added +anything to ‘magit-refresh-buffer-hook’, ‘magit-status-refresh-hook’, +‘magit-pre-refresh-hook’, and ‘magit-post-refresh-hook’. If so, then +check whether those additions impact performance significantly. + + Magit can be told to refresh buffers verbosely using ‘M-x +magit-toggle-verbose-refresh’. Enabling this helps figuring out which +sections are bottlenecks. The additional output can be found in the +‘*Messages*’ buffer. + + Magit also reverts buffers for visited files located inside the +current repository when the visited file changes on disk. That is +implemented on top of ‘auto-revert-mode’ from the built-in library +‘autorevert’. To figure out whether that impacts performance, check +whether performance is significantly worse, when many buffers exist +and/or when some buffers visit files using TRAMP. If so, then this +should help. + + (setq auto-revert-buffer-list-filter + 'magit-auto-revert-repository-buffer-p) + + For alternative approaches see *note Automatic Reverting of +File-Visiting Buffers::. + + If you have enabled any features that are disabled by default, then +you should check whether they impact performance significantly. It’s +likely that they were not enabled by default because it is known that +they reduce performance at least in large repositories. + + If performance is only slow inside certain unusually large +repositories, then you might want to disable certain features on a +per-repository or per-repository-class basis only. See *note +Per-Repository Configuration::. For example it takes a long time to +determine the next and current tag in repository with exceptional +numbers of tags. It would therefore be a good idea to disable +‘magit-insert-tags-headers’, as explained at the mentioned node. + +* Menu: + +* Microsoft Windows Performance:: +* MacOS Performance:: + +Log Performance +............... + +When showing logs, Magit limits the number of commits initially shown in +the hope that this avoids unnecessary work. When using ‘--graph’ is +used, then this unfortunately does not have the desired effect for large +histories. Junio, Git’s maintainer, said on the git mailing list +(): "‘--graph’ wants to +compute the whole history and the max-count only affects the output +phase after ‘--graph’ does its computation". + + In other words, it’s not that Git is slow at outputting the +differences, or that Magit is slow at parsing the output - the problem +is that Git first goes outside and has a smoke. + + We actually work around this issue by limiting the number of commits +not only by using ‘-’ but by also using a range. But unfortunately +that’s not always possible. + + When more than a few thousand commits are shown, then the use of +‘--graph’ can slow things down. + + Using ‘--color --graph’ is even slower. Magit uses code that is part +of Emacs to turn control characters into faces. That code is pretty +slow and this is quite noticeable when showing a log with many branches +and merges. For that reason ‘--color’ is not enabled by default +anymore. Consider leaving it at that. + +Diff Performance +................ + +If diffs are slow, then consider turning off some optional diff features +by setting all or some of the following variables to ‘nil’: +‘magit-diff-highlight-indentation’, ‘magit-diff-highlight-trailing’, +‘magit-diff-paint-whitespace’, ‘magit-diff-highlight-hunk-body’, and +‘magit-diff-refine-hunk’. + + When showing a commit instead of some arbitrary diff, then some +additional information is displayed. Calculating this information can +be quite expensive given certain circumstances. If looking at a commit +using ‘magit-revision-mode’ takes considerably more time than looking at +the same commit in ‘magit-diff-mode’, then consider setting +‘magit-revision-insert-related-refs’ to ‘nil’. + + When you are often confronted with diffs that contain deleted files, +then you might want to enable the ‘--irreversible-delete’ argument. If +you do that then diffs still show that a file was deleted but without +also showing the complete deleted content of the file. This argument is +not available by default, see *note (transient)Enabling and Disabling +Suffixes::. Once you have done that you should enable it and save that +setting, see *note (transient)Saving Values::. You should do this in +both the diff (‘d’) and the diff refresh (‘D’) transient popups. + +Refs Buffer Performance +....................... + +When refreshing the "references buffer" is slow, then that’s usually +because several hundred refs are being displayed. The best way to +address that is to display fewer refs, obviously. + + If you are not, or only mildly, interested in seeing the list of +tags, then start by not displaying them: + + (remove-hook 'magit-refs-sections-hook 'magit-insert-tags) + + Then you should also make sure that the listed remote branches +actually all exist. You can do so by pruning branches which no longer +exist using ‘f-pa’. + +Committing Performance +...................... + +When you initiate a commit, then Magit by default automatically shows a +diff of the changes you are about to commit. For large commits this can +take a long time, which is especially distracting when you are +committing large amounts of generated data which you don’t actually +intend to inspect before committing. This behavior can be turned off +using: + + (remove-hook 'server-switch-hook 'magit-commit-diff) + + Then you can type ‘C-c C-d’ to show the diff when you actually want +to see it, but only then. Alternatively you can leave the hook alone +and just type ‘C-g’ in those cases when it takes too long to generate +the diff. If you do that, then you will end up with a broken diff +buffer, but doing it this way has the advantage that you usually get to +see the diff, which is useful because it increases the odds that you +spot potential issues. + +The Built-In VC Package +....................... + +Emacs comes with a version control interface called "VC", see *note +(emacs)Version Control::. It is enabled be default, and if you don’t +use it in addition to Magit, then you should disable it to keep it from +performing unnecessary work: + + (setq vc-handled-backends nil) + + You can also disable its use for Git but keep using it when using +another version control system: + + (setq vc-handled-backends (delq 'Git vc-handled-backends)) + + +File: magit.info, Node: Microsoft Windows Performance, Next: MacOS Performance, Up: Performance + +Microsoft Windows Performance +............................. + +In order to update the status buffer, ‘git’ has to be run a few dozen +times. That is problematic on Microsoft Windows, because that operating +system is exceptionally slow at starting processes. Sadly this is an +issue that can only be fixed by Microsoft itself, and they don’t appear +to be particularly interested in doing so. + + Beside the subprocess issue, there are also other Windows-specific +performance issues. Some of these have workarounds. The maintainers of +"Git for Windows" try to improve performance on Windows. Always use the +latest release in order to benefit from the latest performance tweaks. +Magit too tries to work around some Windows-specific issues. + + According to some sources, setting the following Git variables can +also help. + + git config --global core.preloadindex true # default since v2.1 + git config --global core.fscache true # default since v2.8 + git config --global gc.auto 256 + + You should also check whether an anti-virus program is affecting +performance. + + +File: magit.info, Node: MacOS Performance, Prev: Microsoft Windows Performance, Up: Performance + +MacOS Performance +................. + +Before Emacs 26.1 child processes were created using ‘fork’ on macOS. +That needlessly copied GUI resources, which is expensive. The result +was that forking took about 30 times as long on Darwin than on Linux, +and because Magit starts many ‘git’ processes that made quite a +difference. + + So make sure that you are using at least Emacs 26.1, in which case +the faster ‘vfork’ will be used. (The creation of child processes still +takes about twice as long on Darwin compared to Linux.) See (1) for +more information. + + On Catalina, and potentially other macOS releases, there may be a +performance problem where any action takes 20 times longer on Darwin +than on Linux. This can be fixed by setting ‘magit-git-executable’ to +the absolute path of the ‘git’ executable, instead of relying on +resolving the ‘$PATH’. + + ---------- Footnotes ---------- + + (1) + + + +File: magit.info, Node: Plumbing, Next: FAQ, Prev: Customizing, Up: Top + +10 Plumbing +*********** + +The following sections describe how to use several of Magit’s core +abstractions to extend Magit itself or implement a separate extension. + + A few of the low-level features used by Magit have been factored out +into separate libraries/packages, so that they can be used by other +packages, without having to depend on Magit. See *note +(with-editor)Top:: for information about ‘with-editor’. ‘transient’ +doesn’t have a manual yet. + + If you are trying to find an unused key that you can bind to a +command provided by your own Magit extension, then checkout +. + +* Menu: + +* Calling Git:: +* Section Plumbing:: +* Refreshing Buffers:: +* Conventions:: + + +File: magit.info, Node: Calling Git, Next: Section Plumbing, Up: Plumbing + +10.1 Calling Git +================ + +Magit provides many specialized functions for calling Git. All of these +functions are defined in either ‘magit-git.el’ or ‘magit-process.el’ and +have one of the prefixes ‘magit-run-’, ‘magit-call-’, ‘magit-start-’, or +‘magit-git-’ (which is also used for other things). + + All of these functions accept an indefinite number of arguments, +which are strings that specify command line arguments for Git (or in +some cases an arbitrary executable). These arguments are flattened +before being passed on to the executable; so instead of strings they can +also be lists of strings and arguments that are ‘nil’ are silently +dropped. Some of these functions also require a single mandatory +argument before these command line arguments. + + Roughly speaking, these functions run Git either to get some value or +for side-effects. The functions that return a value are useful to +collect the information necessary to populate a Magit buffer, while the +others are used to implement Magit commands. + + The functions in the value-only group always run synchronously, and +they never trigger a refresh. The function in the side-effect group can +be further divided into subgroups depending on whether they run Git +synchronously or asynchronously, and depending on whether they trigger a +refresh when the executable has finished. + +* Menu: + +* Getting a Value from Git:: +* Calling Git for Effect:: + + +File: magit.info, Node: Getting a Value from Git, Next: Calling Git for Effect, Up: Calling Git + +10.1.1 Getting a Value from Git +------------------------------- + +These functions run Git in order to get a value, an exit status, or +output. Of course you could also use them to run Git commands that have +side-effects, but that should be avoided. + + -- Function: magit-git-exit-code &rest args + + Executes git with ARGS and returns its exit code. + + -- Function: magit-git-success &rest args + + Executes git with ARGS and returns ‘t’ if the exit code is ‘0’, + ‘nil’ otherwise. + + -- Function: magit-git-failure &rest args + + Executes git with ARGS and returns ‘t’ if the exit code is ‘1’, + ‘nil’ otherwise. + + -- Function: magit-git-true &rest args + + Executes git with ARGS and returns ‘t’ if the first line printed by + git is the string "true", ‘nil’ otherwise. + + -- Function: magit-git-false &rest args + + Executes git with ARGS and returns ‘t’ if the first line printed by + git is the string "false", ‘nil’ otherwise. + + -- Function: magit-git-insert &rest args + + Executes git with ARGS and inserts its output at point. + + -- Function: magit-git-string &rest args + + Executes git with ARGS and returns the first line of its output. + If there is no output or if it begins with a newline character, + then this returns ‘nil’. + + -- Function: magit-git-lines &rest args + + Executes git with ARGS and returns its output as a list of lines. + Empty lines anywhere in the output are omitted. + + -- Function: magit-git-items &rest args + + Executes git with ARGS and returns its null-separated output as a + list. Empty items anywhere in the output are omitted. + + If the value of option ‘magit-git-debug’ is non-nil and git exits + with a non-zero exit status, then warn about that in the echo area + and add a section containing git’s standard error in the current + repository’s process buffer. + + If an error occurs when using one of the above functions, then that +is usually due to a bug, i.e. using an argument which is not actually +supported. Such errors are usually not reported, but when they occur we +need to be able to debug them. + + -- User Option: magit-git-debug + + Whether to report errors that occur when using ‘magit-git-insert’, + ‘magit-git-string’, ‘magit-git-lines’, or ‘magit-git-items’. This + does not actually raise an error. Instead a message is shown in + the echo area, and git’s standard error is insert into a new + section in the current repository’s process buffer. + + -- Function: magit-git-str &rest args + + This is a variant of ‘magit-git-string’ that ignores the option + ‘magit-git-debug’. It is mainly intended to be used while handling + errors in functions that do respect that option. Using such a + function while handing an error could cause yet another error and + therefore lead to an infinite recursion. You probably won’t ever + need to use this function. + + +File: magit.info, Node: Calling Git for Effect, Prev: Getting a Value from Git, Up: Calling Git + +10.1.2 Calling Git for Effect +----------------------------- + +These functions are used to run git to produce some effect. Most Magit +commands that actually run git do so by using such a function. + + Because we do not need to consume git’s output when using these +functions, their output is instead logged into a per-repository buffer, +which can be shown using ‘$’ from a Magit buffer or ‘M-x magit-process’ +elsewhere. + + These functions can have an effect in two distinct ways. Firstly, +running git may change something, i.e. create or push a new commit. +Secondly, that change may require that Magit buffers are refreshed to +reflect the changed state of the repository. But refreshing isn’t +always desirable, so only some of these functions do perform such a +refresh after git has returned. + + Sometimes it is useful to run git asynchronously. For example, when +the user has just initiated a push, then there is no reason to make her +wait until that has completed. In other cases it makes sense to wait +for git to complete before letting the user do something else. For +example after staging a change it is useful to wait until after the +refresh because that also automatically moves to the next change. + + -- Function: magit-call-git &rest args + + Calls git synchronously with ARGS. + + -- Function: magit-call-process program &rest args + + Calls PROGRAM synchronously with ARGS. + + -- Function: magit-run-git &rest args + + Calls git synchronously with ARGS and then refreshes. + + -- Function: magit-run-git-with-input input &rest args + + Calls git synchronously with ARGS and sends it INPUT on standard + input. + + INPUT should be a buffer or the name of an existing buffer. The + content of that buffer is used as the process’ standard input. + After the process returns a refresh is performed. + + As a special case, INPUT may also be nil. In that case the content + of the current buffer is used as standard input and *no* refresh is + performed. + + This function actually runs git asynchronously. But then it waits + for the process to return, so the function itself is synchronous. + + -- Function: magit-run-git-with-logfile file &rest args + + Calls git synchronously with ARGS. The process’ output is saved in + FILE. This is rarely useful and so this function might be removed + in the future. + + This function actually runs git asynchronously. But then it waits + for the process to return, so the function itself is synchronous. + + -- Function: magit-git &rest args + + Calls git synchronously with ARGS for side-effects only. This + function does not refresh the buffer. + + -- Function: magit-git-wash washer &rest args + + Execute Git with ARGS, inserting washed output at point. Actually + first insert the raw output at point. If there is no output call + ‘magit-cancel-section’. Otherwise temporarily narrow the buffer to + the inserted text, move to its beginning, and then call function + WASHER with ARGS as its sole argument. + + And now for the asynchronous variants. + + -- Function: magit-run-git-async &rest args + + Start Git, prepare for refresh, and return the process object. + ARGS is flattened and then used as arguments to Git. + + Display the command line arguments in the echo area. + + After Git returns some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + Unmodified buffers visiting files that are tracked in the current + repository are reverted if ‘magit-revert-buffers’ is non-nil. + + -- Function: magit-run-git-with-editor &rest args + + Export GIT_EDITOR and start Git. Also prepare for refresh and + return the process object. ARGS is flattened and then used as + arguments to Git. + + Display the command line arguments in the echo area. + + After Git returns some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + + -- Function: magit-start-git &rest args + + Start Git, prepare for refresh, and return the process object. + + If INPUT is non-nil, it has to be a buffer or the name of an + existing buffer. The buffer content becomes the processes standard + input. + + Option ‘magit-git-executable’ specifies the Git executable and + option ‘magit-git-global-arguments’ specifies constant arguments. + The remaining arguments ARGS specify arguments to Git. They are + flattened before use. + + After Git returns, some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + Unmodified buffers visiting files that are tracked in the current + repository are reverted if ‘magit-revert-buffers’ is non-nil. + + -- Function: magit-start-process &rest args + + Start PROGRAM, prepare for refresh, and return the process object. + + If optional argument INPUT is non-nil, it has to be a buffer or the + name of an existing buffer. The buffer content becomes the + processes standard input. + + The process is started using ‘start-file-process’ and then setup to + use the sentinel ‘magit-process-sentinel’ and the filter + ‘magit-process-filter’. Information required by these functions is + stored in the process object. When this function returns the + process has not started to run yet so it is possible to override + the sentinel and filter. + + After the process returns, ‘magit-process-sentinel’ refreshes the + buffer that was current when ‘magit-start-process’ was called (if + it is a Magit buffer and still alive), as well as the respective + Magit status buffer. Unmodified buffers visiting files that are + tracked in the current repository are reverted if + ‘magit-revert-buffers’ is non-nil. + + -- Variable: magit-this-process + + The child process which is about to start. This can be used to + change the filter and sentinel. + + -- Variable: magit-process-raise-error + + When this is non-nil, then ‘magit-process-sentinel’ raises an error + if git exits with a non-zero exit status. For debugging purposes. + + +File: magit.info, Node: Section Plumbing, Next: Refreshing Buffers, Prev: Calling Git, Up: Plumbing + +10.2 Section Plumbing +===================== + +* Menu: + +* Creating Sections:: +* Section Selection:: +* Matching Sections:: + + +File: magit.info, Node: Creating Sections, Next: Section Selection, Up: Section Plumbing + +10.2.1 Creating Sections +------------------------ + + -- Macro: magit-insert-section &rest args + + Insert a section at point. + + TYPE is the section type, a symbol. Many commands that act on the + current section behave differently depending on that type. Also if + a variable ‘magit-TYPE-section-map’ exists, then use that as the + text-property ‘keymap’ of all text belonging to the section (but + this may be overwritten in subsections). TYPE can also have the + form ‘(eval FORM)’ in which case FORM is evaluated at runtime. + + Optional VALUE is the value of the section, usually a string that + is required when acting on the section. + + When optional HIDE is non-nil collapse the section body by default, + i.e. when first creating the section, but not when refreshing the + buffer. Otherwise, expand it by default. This can be overwritten + using ‘magit-section-set-visibility-hook’. When a section is + recreated during a refresh, then the visibility of predecessor is + inherited and HIDE is ignored (but the hook is still honored). + + BODY is any number of forms that actually insert the section’s + heading and body. Optional NAME, if specified, has to be a symbol, + which is then bound to the struct of the section being inserted. + + Before BODY is evaluated the ‘start’ of the section object is set + to the value of ‘point’ and after BODY was evaluated its ‘end’ is + set to the new value of ‘point’; BODY is responsible for moving + ‘point’ forward. + + If it turns out inside BODY that the section is empty, then + ‘magit-cancel-section’ can be used to abort and remove all traces + of the partially inserted section. This can happen when creating a + section by washing Git’s output and Git didn’t actually output + anything this time around. + + -- Function: magit-insert-heading &rest args + + Insert the heading for the section currently being inserted. + + This function should only be used inside ‘magit-insert-section’. + + When called without any arguments, then just set the ‘content’ slot + of the object representing the section being inserted to a marker + at ‘point’. The section should only contain a single line when + this function is used like this. + + When called with arguments ARGS, which have to be strings, then + insert those strings at point. The section should not contain any + text before this happens and afterwards it should again only + contain a single line. If the ‘face’ property is set anywhere + inside any of these strings, then insert all of them unchanged. + Otherwise use the ‘magit-section-heading’ face for all inserted + text. + + The ‘content’ property of the section struct is the end of the + heading (which lasts from ‘start’ to ‘content’) and the beginning + of the body (which lasts from ‘content’ to ‘end’). If the value of + ‘content’ is nil, then the section has no heading and its body + cannot be collapsed. If a section does have a heading then its + height must be exactly one line, including a trailing newline + character. This isn’t enforced; you are responsible for getting it + right. The only exception is that this function does insert a + newline character if necessary. + + -- Function: magit-cancel-section + + Cancel the section currently being inserted. This exits the + innermost call to ‘magit-insert-section’ and removes all traces of + what has already happened inside that call. + + -- Function: magit-define-section-jumper sym title &optional value + + Define an interactive function to go to section SYM. TITLE is the + displayed title of the section. + + +File: magit.info, Node: Section Selection, Next: Matching Sections, Prev: Creating Sections, Up: Section Plumbing + +10.2.2 Section Selection +------------------------ + + -- Function: magit-current-section + + Return the section at point. + + -- Function: magit-region-sections &optional condition multiple + + Return a list of the selected sections. + + When the region is active and constitutes a valid section + selection, then return a list of all selected sections. This is + the case when the region begins in the heading of a section and + ends in the heading of the same section or in that of a sibling + section. If optional MULTIPLE is non-nil, then the region cannot + begin and end in the same section. + + When the selection is not valid, then return nil. In this case, + most commands that can act on the selected sections will instead + act on the section at point. + + When the region looks like it would in any other buffer then the + selection is invalid. When the selection is valid then the region + uses the ‘magit-section-highlight’ face. This does not apply to + diffs where things get a bit more complicated, but even here if the + region looks like it usually does, then that’s not a valid + selection as far as this function is concerned. + + If optional CONDITION is non-nil, then the selection not only has + to be valid; all selected sections additionally have to match + CONDITION, or nil is returned. See ‘magit-section-match’ for the + forms CONDITION can take. + + -- Function: magit-region-values &optional condition multiple + + Return a list of the values of the selected sections. + + Return the values that themselves would be returned by + ‘magit-region-sections’ (which see). + + +File: magit.info, Node: Matching Sections, Prev: Section Selection, Up: Section Plumbing + +10.2.3 Matching Sections +------------------------ + +‘M-x magit-describe-section-briefly’ (‘magit-describe-section-briefly’) + + Show information about the section at point. This command is + intended for debugging purposes. + + -- Function: magit-section-ident section + + Return an unique identifier for SECTION. The return value has the + form ‘((TYPE . VALUE)...)’. + + -- Function: magit-get-section ident &optional root + + Return the section identified by IDENT. IDENT has to be a list as + returned by ‘magit-section-ident’. + + -- Function: magit-section-match condition &optional section + + Return ‘t’ if SECTION matches CONDITION. SECTION defaults to the + section at point. If SECTION is not specified and there also is no + section at point, then return ‘nil’. + + CONDITION can take the following forms: + • ‘(CONDITION...)’ + + matches if any of the CONDITIONs matches. + + • ‘[CLASS...]’ + + matches if the section’s class is the same as the first CLASS + or a subclass of that; the section’s parent class matches the + second CLASS; and so on. + + • ‘[* CLASS...]’ + + matches sections that match ‘[CLASS...]’ and also recursively + all their child sections. + + • ‘CLASS’ + + matches if the section’s class is the same as CLASS or a + subclass of that; regardless of the classes of the parent + sections. + + Each CLASS should be a class symbol, identifying a class that + derives from ‘magit-section’. For backward compatibility CLASS can + also be a "type symbol". A section matches such a symbol if the + value of its ‘type’ slot is ‘eq’. If a type symbol has an entry in + ‘magit--section-type-alist’, then a section also matches that type + if its class is a subclass of the class that corresponds to the + type as per that alist. + + Note that it is not necessary to specify the complete section + lineage as printed by ‘magit-describe-section-briefly’, unless of + course you want to be that precise. + + -- Function: magit-section-value-if condition &optional section + + If the section at point matches CONDITION, then return its value. + + If optional SECTION is non-nil then test whether that matches + instead. If there is no section at point and SECTION is nil, then + return nil. If the section does not match, then return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + + -- Function: magit-section-case &rest clauses + + Choose among clauses on the type of the section at point. + + Each clause looks like (CONDITION BODY...). The type of the + section is compared against each CONDITION; the BODY forms of the + first match are evaluated sequentially and the value of the last + form is returned. Inside BODY the symbol ‘it’ is bound to the + section at point. If no clause succeeds or if there is no section + at point return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + Additionally a CONDITION of t is allowed in the final clause and + matches if no other CONDITION match, even if there is no section at + point. + + -- Variable: magit-root-section + + The root section in the current buffer. All other sections are + descendants of this section. The value of this variable is set by + ‘magit-insert-section’ and you should never modify it. + + For diff related sections a few additional tools exist. + + -- Function: magit-diff-type &optional section + + Return the diff type of SECTION. + + The returned type is one of the symbols ‘staged’, ‘unstaged’, + ‘committed’, or ‘undefined’. This type serves a similar purpose as + the general type common to all sections (which is stored in the + ‘type’ slot of the corresponding ‘magit-section’ struct) but takes + additional information into account. When the SECTION isn’t + related to diffs and the buffer containing it also isn’t a + diff-only buffer, then return nil. + + Currently the type can also be one of ‘tracked’ and ‘untracked’, + but these values are not handled explicitly in every place they + should be. A possible fix could be to just return nil here. + + The section has to be a ‘diff’ or ‘hunk’ section, or a section + whose children are of type ‘diff’. If optional SECTION is nil, + return the diff type for the current section. In buffers whose + major mode is ‘magit-diff-mode’ SECTION is ignored and the type is + determined using other means. In ‘magit-revision-mode’ buffers the + type is always ‘committed’. + + -- Function: magit-diff-scope &optional section strict + + Return the diff scope of SECTION or the selected section(s). + + A diff’s "scope" describes what part of a diff is selected, it is a + symbol, one of ‘region’, ‘hunk’, ‘hunks’, ‘file’, ‘files’, or + ‘list’. Do not confuse this with the diff "type", as returned by + ‘magit-diff-type’. + + If optional SECTION is non-nil, then return the scope of that, + ignoring the sections selected by the region. Otherwise return the + scope of the current section, or if the region is active and + selects a valid group of diff related sections, the type of these + sections, i.e. ‘hunks’ or ‘files’. If SECTION (or if the current + section that is nil) is a ‘hunk’ section and the region starts and + ends inside the body of a that section, then the type is ‘region’. + + If optional STRICT is non-nil then return nil if the diff type of + the section at point is ‘untracked’ or the section at point is not + actually a ‘diff’ but a ‘diffstat’ section. + + +File: magit.info, Node: Refreshing Buffers, Next: Conventions, Prev: Section Plumbing, Up: Plumbing + +10.3 Refreshing Buffers +======================= + +All commands that create a new Magit buffer or change what is being +displayed in an existing buffer do so by calling ‘magit-mode-setup’. +Among other things, that function sets the buffer local values of +‘default-directory’ (to the top-level of the repository), +‘magit-refresh-function’, and ‘magit-refresh-args’. + + Buffers are refreshed by calling the function that is the local value +of ‘magit-refresh-function’ (a function named ‘magit-*-refresh-buffer’, +where ‘*’ may be something like ‘diff’) with the value of +‘magit-refresh-args’ as arguments. + + -- Macro: magit-mode-setup buffer switch-func mode refresh-func + &optional refresh-args + + This function displays and selects BUFFER, turns on MODE, and + refreshes a first time. + + This function displays and optionally selects BUFFER by calling + ‘magit-mode-display-buffer’ with BUFFER, MODE and SWITCH-FUNC as + arguments. Then it sets the local value of + ‘magit-refresh-function’ to REFRESH-FUNC and that of + ‘magit-refresh-args’ to REFRESH-ARGS. Finally it creates the + buffer content by calling REFRESH-FUNC with REFRESH-ARGS as + arguments. + + All arguments are evaluated before switching to BUFFER. + + -- Function: magit-mode-display-buffer buffer mode &optional + switch-function + + This function display BUFFER in some window and select it. BUFFER + may be a buffer or a string, the name of a buffer. The buffer is + returned. + + Unless BUFFER is already displayed in the selected frame, store the + previous window configuration as a buffer local value, so that it + can later be restored by ‘magit-mode-bury-buffer’. + + The buffer is displayed and selected using SWITCH-FUNCTION. If + that is ‘nil’ then ‘pop-to-buffer’ is used if the current buffer’s + major mode derives from ‘magit-mode’. Otherwise ‘switch-to-buffer’ + is used. + + -- Variable: magit-refresh-function + + The value of this buffer-local variable is the function used to + refresh the current buffer. It is called with ‘magit-refresh-args’ + as arguments. + + -- Variable: magit-refresh-args + + The list of arguments used by ‘magit-refresh-function’ to refresh + the current buffer. ‘magit-refresh-function’ is called with these + arguments. + + The value is usually set using ‘magit-mode-setup’, but in some + cases it’s also useful to provide commands that can change the + value. For example, the ‘magit-diff-refresh’ transient can be used + to change any of the arguments used to display the diff, without + having to specify again which differences should be shown, but + ‘magit-diff-more-context’, ‘magit-diff-less-context’ and + ‘magit-diff-default-context’ change just the ‘-U’ argument. In + both case this is done by changing the value of this variable and + then calling this ‘magit-refresh-function’. + + +File: magit.info, Node: Conventions, Prev: Refreshing Buffers, Up: Plumbing + +10.4 Conventions +================ + +Also see *note Completion and Confirmation::. + +* Menu: + +* Theming Faces:: + + +File: magit.info, Node: Theming Faces, Up: Conventions + +10.4.1 Theming Faces +-------------------- + +The default theme uses blue for local branches, green for remote +branches, and goldenrod (brownish yellow) for tags. When creating a new +theme, you should probably follow that example. If your theme already +uses other colors, then stick to that. + + In older releases these reference faces used to have a background +color and a box around them. The basic default faces no longer do so, +to make Magit buffers much less noisy, and you should follow that +example at least with regards to boxes. (Boxes were used in the past to +work around a conflict between the highlighting overlay and text +property backgrounds. That’s no longer necessary because highlighting +no longer causes other background colors to disappear.) Alternatively +you can keep the background color and/or box, but then have to take +special care to adjust ‘magit-branch-current’ accordingly. By default +it looks mostly like ‘magit-branch-local’, but with a box (by default +the former is the only face that uses a box, exactly so that it sticks +out). If the former also uses a box, then you have to make sure that it +differs in some other way from the latter. + + The most difficult faces to theme are those related to diffs, +headings, highlighting, and the region. There are faces that fall into +all four groups - expect to spend some time getting this right. + + The ‘region’ face in the default theme, in both the light and dark +variants, as well as in many other themes, distributed with Emacs or by +third-parties, is very ugly. It is common to use a background color +that really sticks out, which is ugly but if that were the only problem +then it would be acceptable. Unfortunately many themes also set the +foreground color, which ensures that all text within the region is +readable. Without doing that there might be cases where some foreground +color is too close to the region background color to still be readable. +But it also means that text within the region loses all syntax +highlighting. + + I consider the work that went into getting the ‘region’ face right to +be a good indicator for the general quality of a theme. My +recommendation for the ‘region’ face is this: use a background color +slightly different from the background color of the ‘default’ face, and +do not set the foreground color at all. So for a light theme you might +use a light (possibly tinted) gray as the background color of ‘default’ +and a somewhat darker gray for the background of ‘region’. That should +usually be enough to not collide with the foreground color of any other +face. But if some other faces also set a light gray as background +color, then you should also make sure it doesn’t collide with those (in +some cases it might be acceptable though). + + Magit only uses the ‘region’ face when the region is "invalid" by its +own definition. In a Magit buffer the region is used to either select +multiple sibling sections, so that commands which support it act on all +of these sections instead of just the current section, or to select +lines within a single hunk section. In all other cases, the section is +considered invalid and Magit won’t act on it. But such invalid sections +happen, either because the user has not moved point enough yet to make +it valid or because she wants to use a non-magit command to act on the +region, e.g. ‘kill-region’. + + So using the regular ‘region’ face for invalid sections is a feature. +It tells the user that Magit won’t be able to act on it. It’s +acceptable if that face looks a bit odd and even (but less so) if it +collides with the background colors of section headings and other things +that have a background color. + + Magit highlights the current section. If a section has subsections, +then all of them are highlighted. This is done using faces that have +"highlight" in their names. For most sections, +‘magit-section-highlight’ is used for both the body and the heading. +Like the ‘region’ face, it should only set the background color to +something similar to that of ‘default’. The highlight background color +must be different from both the ‘region’ background color and the +‘default’ background color. + + For diff related sections Magit uses various faces to highlight +different parts of the selected section(s). Note that hunk headings, +unlike all other section headings, by default have a background color, +because it is useful to have very visible separators between hunks. +That face ‘magit-diff-hunk-heading’, should be different from both +‘magit-diff-hunk-heading-highlight’ and ‘magit-section-highlight’, as +well as from ‘magit-diff-context’ and ‘magit-diff-context-highlight’. +By default we do that by changing the foreground color. Changing the +background color would lead to complications, and there are already +enough we cannot get around. (Also note that it is generally a good +idea for section headings to always be bold, but only for sections that +have subsections). + + When there is a valid region selecting diff-related sibling sections, +i.e. multiple files or hunks, then the bodies of all these sections use +the respective highlight faces, but additionally the headings instead +use one of the faces ‘magit-diff-file-heading-selection’ or +‘magit-diff-hunk-heading-selection’. These faces have to be different +from the regular highlight variants to provide explicit visual +indication that the region is active. + + When theming diff related faces, start by setting the option +‘magit-diff-refine-hunk’ to ‘all’. You might personally prefer to only +refine the current hunk or not use hunk refinement at all, but some of +the users of your theme want all hunks to be refined, so you have to +cater to that. + + (Also turn on ‘magit-diff-highlight-indentation’, +‘magit-diff-highlight-trailing’, and ‘magit-diff-paint-whitespace’; and +insert some whitespace errors into the code you use for testing.) + + For e.g. "added lines" you have to adjust three faces: +‘magit-diff-added’, ‘magit-diff-added-highlight’, and +‘smerge-refined-added’. Make sure that the latter works well with both +of the former, as well as ‘smerge-other’ and ‘diff-added’. Then do the +same for the removed lines, context lines, lines added by us, and lines +added by them. Also make sure the respective added, removed, and +context faces use approximately the same saturation for both the +highlighted and unhighlighted variants. Also make sure the file and +diff headings work nicely with context lines (e.g. make them look +different). Line faces should set both the foreground and the +background color. For example, for added lines use two different +greens. + + It’s best if the foreground color of both the highlighted and the +unhighlighted variants are the same, so you will need to have to find a +color that works well on the highlight and unhighlighted background, the +refine background, and the highlight context background. When there is +an hunk internal region, then the added- and removed-lines background +color is used only within that region. Outside the region the +highlighted context background color is used. This makes it easier to +see what is being staged. With an hunk internal region the hunk heading +is shown using ‘magit-diff-hunk-heading-selection’, and so are the thin +lines that are added around the lines that fall within the region. The +background color of that has to be distinct enough from the various +other involved background colors. + + Nobody said this would be easy. If your theme restricts itself to a +certain set of colors, then you should make an exception here. +Otherwise it would be impossible to make the diffs look good in each and +every variation. Actually you might want to just stick to the default +definitions for these faces. You have been warned. Also please note +that if you do not get this right, this will in some cases look to users +like bugs in Magit - so please do it right or not at all. + + +File: magit.info, Node: FAQ, Next: Debugging Tools, Prev: Plumbing, Up: Top + +Appendix A FAQ +************** + +The next two nodes lists frequently asked questions. For a list of +frequently *and recently* asked questions, i.e. questions that haven’t +made it into the manual yet, see +. + + Please also use the *note Debugging Tools::. + +* Menu: + +* FAQ - How to ...?:: +* FAQ - Issues and Errors:: + + +File: magit.info, Node: FAQ - How to ...?, Next: FAQ - Issues and Errors, Up: FAQ + +A.1 FAQ - How to ...? +===================== + +* Menu: + +* How to show git's output?:: +* How to install the gitman info manual?:: +* How to show diffs for gpg-encrypted files?:: +* How does branching and pushing work?:: +* Can Magit be used as ediff-version-control-package?:: + + +File: magit.info, Node: How to show git's output?, Next: How to install the gitman info manual?, Up: FAQ - How to ...? + +A.1.1 How to show git’s output? +------------------------------- + +To show the output of recently run git commands, press ‘$’ (or, if that +isn’t available, ‘M-x magit-process-buffer’). This will show a buffer +containing a section per git invocation; as always press ‘TAB’ to expand +or collapse them. + + By default, git’s output is only inserted into the process buffer if +it is run for side-effects. When the output is consumed in some way, +also inserting it into the process buffer would be too expensive. For +debugging purposes, it’s possible to do so anyway by setting +‘magit-git-debug’ to ‘t’. + + +File: magit.info, Node: How to install the gitman info manual?, Next: How to show diffs for gpg-encrypted files?, Prev: How to show git's output?, Up: FAQ - How to ...? + +A.1.2 How to install the gitman info manual? +-------------------------------------------- + +Git’s manpages can be exported as an info manual called ‘gitman’. +Magit’s own info manual links to nodes in that manual instead of the +actual manpages because Info doesn’t support linking to manpages. + + Unfortunately some distributions do not install the ‘gitman’ manual +by default and you will have to install a separate documentation package +to get it. + + Magit patches Info adding the ability to visit links to the ‘gitman’ +Info manual by instead viewing the respective manpage. If you prefer +that approach, then set the value of ‘magit-view-git-manual-method’ to +one of the supported packages ‘man’ or ‘woman’, e.g.: + + (setq magit-view-git-manual-method 'man) + + +File: magit.info, Node: How to show diffs for gpg-encrypted files?, Next: How does branching and pushing work?, Prev: How to install the gitman info manual?, Up: FAQ - How to ...? + +A.1.3 How to show diffs for gpg-encrypted files? +------------------------------------------------ + +Git supports showing diffs for encrypted files, but has to be told to do +so. Since Magit just uses Git to get the diffs, configuring Git also +affects the diffs displayed inside Magit. + + git config --global diff.gpg.textconv "gpg --no-tty --decrypt" + echo "*.gpg filter=gpg diff=gpg" > .gitattributes + + +File: magit.info, Node: How does branching and pushing work?, Next: Can Magit be used as ediff-version-control-package?, Prev: How to show diffs for gpg-encrypted files?, Up: FAQ - How to ...? + +A.1.4 How does branching and pushing work? +------------------------------------------ + +Please see *note Branching:: and + + + +File: magit.info, Node: Can Magit be used as ediff-version-control-package?, Prev: How does branching and pushing work?, Up: FAQ - How to ...? + +A.1.5 Can Magit be used as ‘ediff-version-control-package’? +----------------------------------------------------------- + +No, it cannot. For that to work the functions ‘ediff-magit-internal’ +and ‘ediff-magit-merge-internal’ would have to be implemented, and they +are not. These two functions are only used by the three commands +‘ediff-revision’, ‘ediff-merge-revisions-with-ancestor’, and +‘ediff-merge-revisions’. + + These commands only delegate the task of populating buffers with +certain revisions to the "internal" functions. The equally important +task of determining which revisions are to be compared/merged is not +delegated. Instead this is done without any support whatsoever from the +version control package/system - meaning that the user has to enter the +revisions explicitly. Instead of implementing ‘ediff-magit-internal’ we +provide ‘magit-ediff-compare’, which handles both tasks like it is 2005. + + The other commands ‘ediff-merge-revisions’ and +‘ediff-merge-revisions-with-ancestor’ are normally not what you want +when using a modern version control system like Git. Instead of letting +the user resolve only those conflicts which Git could not resolve on its +own, they throw away all work done by Git and then expect the user to +manually merge all conflicts, including those that had already been +resolved. That made sense back in the days when version control systems +couldn’t merge (or so I have been told), but not anymore. Once in a +blue moon you might actually want to see all conflicts, in which case +you *can* use these commands, which then use ‘ediff-vc-merge-internal’. +So we don’t actually have to implement ‘ediff-magit-merge-internal’. +Instead we provide the more useful command ‘magit-ediff-resolve’ which +only shows yet-to-be resolved conflicts. + + +File: magit.info, Node: FAQ - Issues and Errors, Prev: FAQ - How to ...?, Up: FAQ + +A.2 FAQ - Issues and Errors +=========================== + +* Menu: + +* Magit is slow:: +* I changed several thousand files at once and now Magit is unusable:: +* I am having problems committing:: +* I am using MS Windows and cannot push with Magit:: +* I am using OS X and SOMETHING works in shell, but not in Magit: I am using OS X and SOMETHING works in shell but not in Magit. +* Expanding a file to show the diff causes it to disappear:: +* Point is wrong in the COMMIT_EDITMSG buffer:: +* The mode-line information isn't always up-to-date:: +* A branch and tag sharing the same name breaks SOMETHING:: +* My Git hooks work on the command-line but not inside Magit:: +* git-commit-mode isn't used when committing from the command-line:: +* Point ends up inside invisible text when jumping to a file-visiting buffer:: + + +File: magit.info, Node: Magit is slow, Next: I changed several thousand files at once and now Magit is unusable, Up: FAQ - Issues and Errors + +A.2.1 Magit is slow +------------------- + +See *note Performance::. + + +File: magit.info, Node: I changed several thousand files at once and now Magit is unusable, Next: I am having problems committing, Prev: Magit is slow, Up: FAQ - Issues and Errors + +A.2.2 I changed several thousand files at once and now Magit is unusable +------------------------------------------------------------------------ + +Magit is *currently* not expected to work under such conditions. It +sure would be nice if it did, and v2.5 will hopefully be a big step into +that direction. But it might take until v3.1 to accomplish fully +satisfactory performance, because that requires some heavy refactoring. + + But for now we recommend you use the command line to complete this +one commit. Also see *note Performance::. + + +File: magit.info, Node: I am having problems committing, Next: I am using MS Windows and cannot push with Magit, Prev: I changed several thousand files at once and now Magit is unusable, Up: FAQ - Issues and Errors + +A.2.3 I am having problems committing +------------------------------------- + +That likely means that Magit is having problems finding an appropriate +emacsclient executable. See *note (with-editor)Configuring +With-Editor:: and *note (with-editor)Debugging::. + + +File: magit.info, Node: I am using MS Windows and cannot push with Magit, Next: I am using OS X and SOMETHING works in shell but not in Magit, Prev: I am having problems committing, Up: FAQ - Issues and Errors + +A.2.4 I am using MS Windows and cannot push with Magit +------------------------------------------------------ + +It’s almost certain that Magit is only incidental to this issue. It is +much more likely that this is a configuration issue, even if you can +push on the command line. + + Detailed setup instructions can be found at +. + + +File: magit.info, Node: I am using OS X and SOMETHING works in shell but not in Magit, Next: Expanding a file to show the diff causes it to disappear, Prev: I am using MS Windows and cannot push with Magit, Up: FAQ - Issues and Errors + +A.2.5 I am using OS X and SOMETHING works in shell, but not in Magit +-------------------------------------------------------------------- + +This usually occurs because Emacs doesn’t have the same environment +variables as your shell. Try installing and configuring +. By default it +synchronizes ‘$PATH’, which helps Magit find the same ‘git’ as the one +you are using on the shell. + + If SOMETHING is "passphrase caching with gpg-agent for commit and/or +tag signing", then you’ll also need to synchronize ‘$GPG_AGENT_INFO’. + + +File: magit.info, Node: Expanding a file to show the diff causes it to disappear, Next: Point is wrong in the COMMIT_EDITMSG buffer, Prev: I am using OS X and SOMETHING works in shell but not in Magit, Up: FAQ - Issues and Errors + +A.2.6 Expanding a file to show the diff causes it to disappear +-------------------------------------------------------------- + +This is probably caused by a change of a ‘diff.*’ Git variable. You +probably set that variable for a reason, and should therefore only undo +that setting in Magit by customizing ‘magit-git-global-arguments’. + + +File: magit.info, Node: Point is wrong in the COMMIT_EDITMSG buffer, Next: The mode-line information isn't always up-to-date, Prev: Expanding a file to show the diff causes it to disappear, Up: FAQ - Issues and Errors + +A.2.7 Point is wrong in the ‘COMMIT_EDITMSG’ buffer +--------------------------------------------------- + +Neither Magit nor ‘git-commit‘ fiddle with point in the buffer used to +write commit messages, so something else must be doing it. + + You have probably globally enabled a mode which does restore point in +file-visiting buffers. It might be a bit surprising, but when you write +a commit message, then you are actually editing a file. + + So you have to figure out which package is doing. ‘saveplace’, +‘pointback’, and ‘session’ are likely candidates. These snippets might +help: + + (setq session-name-disable-regexp "\\(?:\\`'\\.git/[A-Z_]+\\'\\)") + + (with-eval-after-load 'pointback + (lambda () + (when (or git-commit-mode git-rebase-mode) + (pointback-mode -1)))) + + +File: magit.info, Node: The mode-line information isn't always up-to-date, Next: A branch and tag sharing the same name breaks SOMETHING, Prev: Point is wrong in the COMMIT_EDITMSG buffer, Up: FAQ - Issues and Errors + +A.2.8 The mode-line information isn’t always up-to-date +------------------------------------------------------- + +Magit is not responsible for the version control information that is +being displayed in the mode-line and looks something like ‘Git-master’. +The built-in "Version Control" package, also known as "VC", updates that +information, and can be told to do so more often: + + (setq auto-revert-check-vc-info t) + + But doing so isn’t good for performance. For more (overly +optimistic) information see *note (emacs)VC Mode Line::. + + If you don’t really care about seeing that information in the +mode-line, but just don’t want to see _incorrect_ information, then +consider disabling VC when using Git: + + (setq vc-handled-backends (delq 'Git vc-handled-backends)) + + Or to disable it completely: + + (setq vc-handled-backends nil) + + +File: magit.info, Node: A branch and tag sharing the same name breaks SOMETHING, Next: My Git hooks work on the command-line but not inside Magit, Prev: The mode-line information isn't always up-to-date, Up: FAQ - Issues and Errors + +A.2.9 A branch and tag sharing the same name breaks SOMETHING +------------------------------------------------------------- + +Or more generally, ambiguous refnames break SOMETHING. + + Magit assumes that refs are named non-ambiguously across the +"refs/heads/", "refs/tags/", and "refs/remotes/" namespaces (i.e., all +the names remain unique when those prefixes are stripped). We consider +ambiguous refnames unsupported and recommend that you use a +non-ambiguous naming scheme. However, if you do work with a repository +that has ambiguous refnames, please report any issues you encounter so +that we can investigate whether there is a simple fix. + + +File: magit.info, Node: My Git hooks work on the command-line but not inside Magit, Next: git-commit-mode isn't used when committing from the command-line, Prev: A branch and tag sharing the same name breaks SOMETHING, Up: FAQ - Issues and Errors + +A.2.10 My Git hooks work on the command-line but not inside Magit +----------------------------------------------------------------- + +When Magit calls ‘git’ it adds a few global arguments including +‘--literal-pathspecs’ and the ‘git’ process started by Magit then passes +that setting on to other ‘git’ process it starts itself. It does so by +setting the environment variable ‘GIT_LITERAL_PATHSPECS’, not by calling +subprocesses with the ‘--literal-pathspecs’ argument. You can therefore +override this setting in hook scripts using ‘unset +GIT_LITERAL_PATHSPECS’. + + +File: magit.info, Node: git-commit-mode isn't used when committing from the command-line, Next: Point ends up inside invisible text when jumping to a file-visiting buffer, Prev: My Git hooks work on the command-line but not inside Magit, Up: FAQ - Issues and Errors + +A.2.11 ‘git-commit-mode’ isn’t used when committing from the command-line +------------------------------------------------------------------------- + +The reason for this is that ‘git-commit.el’ has not been loaded yet +and/or that the server has not been started yet. These things have +always already been taken care of when you commit from Magit because in +order to do so, Magit has to be loaded and doing that involves loading +‘git-commit’ and starting the server. + + If you want to commit from the command-line, then you have to take +care of these things yourself. Your ‘init.el’ file should contain: + + (require 'git-commit) + (server-mode) + + Instead of ‘(require ’git-commit)‘ you may also use: + + (load "/path/to/magit-autoloads.el") + + You might want to do that because loading ‘git-commit’ causes large +parts of Magit to be loaded. + + There are also some variations of ‘(server-mode)’ that you might want +to try. Personally I use: + + (use-package server + :config (or (server-running-p) (server-mode))) + + Now you can use: + + $ emacs& + $ EDITOR=emacsclient git commit + + However you cannot use: + + $ killall emacs + $ EDITOR="emacsclient --alternate-editor emacs" git commit + + This will actually end up using ‘emacs’, not ‘emacsclient’. If you +do this, then can still edit the commit message but ‘git-commit-mode’ +won’t be used and you have to exit ‘emacs’ to finish the process. + + Tautology ahead. If you want to be able to use ‘emacsclient’ to +connect to a running ‘emacs’ instance, even though no ‘emacs’ instance +is running, then you cannot use ‘emacsclient’ directly. + + Instead you have to create a script that does something like this: + + Try to use ‘emacsclient’ (without using ‘--alternate-editor’). If +that succeeds, do nothing else. Otherwise start ‘emacs &’ (and +‘init.el’ must call ‘server-start’) and try to use ‘emacsclient’ again. + + +File: magit.info, Node: Point ends up inside invisible text when jumping to a file-visiting buffer, Prev: git-commit-mode isn't used when committing from the command-line, Up: FAQ - Issues and Errors + +A.2.12 Point ends up inside invisible text when jumping to a file-visiting buffer +--------------------------------------------------------------------------------- + +This can happen when you type ‘RET’ on a hunk to visit the respective +file at the respective position. One solution to this problem is to use +‘global-reveal-mode’. It makes sure that text around point is always +visible. If that is too drastic for your taste, then you may instead +use ‘magit-diff-visit-file-hook’ to reveal the text, possibly using +‘reveal-post-command’ or for Org buffers ‘org-reveal’. + + +File: magit.info, Node: Debugging Tools, Next: Keystroke Index, Prev: FAQ, Up: Top + +B Debugging Tools +***************** + +Magit and its dependencies provide a few debugging tools, and we +appreciate it very much if you use those tools before reporting an +issue. Please include all relevant output when reporting an issue. + +‘M-x magit-version’ (‘magit-version’) + + This command shows the currently used versions of Magit, Git, and + Emacs in the echo area. Non-interactively this just returns the + Magit version. + +‘M-x magit-emacs-Q-command’ (‘magit-emacs-Q-command’) + + This command shows a debugging shell command in the echo area and + adds it to the kill ring. Paste that command into a shell and run + it. + + This shell command starts ‘emacs’ with only ‘magit’ and its + dependencies loaded. Neither your configuration nor other + installed packages are loaded. This makes it easier to determine + whether some issue lays with Magit or something else. + + If you run Magit from its Git repository, then you should be able + to use ‘make emacs-Q’ instead of the output of this command. + +‘M-x magit-toggle-verbose-refresh’ (‘magit-toggle-verbose-refresh’) + + This command toggles whether Magit refreshes buffers verbosely. + Enabling this helps figuring out which sections are bottlenecks. + The additional output can be found in the ‘*Messages*’ buffer. + +‘M-x magit-debug-git-executable’ (‘magit-debug-git-executable’) + + This command displays a buffer containing information about the + available and used ‘git’ executable(s), and can be useful when + investigating ‘exec-path’ issues. + + Also see *note Git Executable::. + +‘M-x with-editor-debug’ (‘with-editor-debug’) + + This command displays a buffer containing information about the + available and used ‘emacsclient’ executable(s), and can be useful + when investigating why Magit (or rather ‘with-editor’) cannot find + an appropriate ‘emacsclient’ executable. + + Also see *note (with-editor)Debugging::. + + Please also see the *note FAQ::. + + +File: magit.info, Node: Keystroke Index, Next: Command Index, Prev: Debugging Tools, Up: Top + +Appendix C Keystroke Index +************************** + +[index] +* Menu: + +* !: Running Git Manually. + (line 12) +* ! !: Running Git Manually. + (line 17) +* ! a: Running Git Manually. + (line 58) +* ! b: Running Git Manually. + (line 62) +* ! g: Running Git Manually. + (line 66) +* ! k: Running Git Manually. + (line 54) +* ! p: Running Git Manually. + (line 25) +* ! s: Running Git Manually. + (line 35) +* ! S: Running Git Manually. + (line 40) +* $: Viewing Git Output. (line 16) +* %: Worktree. (line 8) +* % b: Worktree. (line 13) +* % c: Worktree. (line 17) +* % g: Worktree. (line 30) +* % k: Worktree. (line 25) +* % m: Worktree. (line 21) +* +: Log Buffer. (line 61) +* + <1>: Refreshing Diffs. (line 69) +* -: Log Buffer. (line 65) +* - <1>: Refreshing Diffs. (line 65) +* 0: Refreshing Diffs. (line 73) +* 1: Section Visibility. (line 26) +* 2: Section Visibility. (line 27) +* 3: Section Visibility. (line 28) +* 4: Section Visibility. (line 29) +* =: Log Buffer. (line 55) +* ^: Section Movement. (line 31) +* a: Applying. (line 33) +* A: Cherry Picking. (line 8) +* A A: Cherry Picking. (line 17) +* A a: Cherry Picking. (line 24) +* A A <1>: Cherry Picking. (line 90) +* A a <1>: Cherry Picking. (line 98) +* A d: Cherry Picking. (line 54) +* A h: Cherry Picking. (line 42) +* A n: Cherry Picking. (line 65) +* A s: Cherry Picking. (line 76) +* A s <1>: Cherry Picking. (line 94) +* B: Bisecting. (line 8) +* b: Blaming. (line 105) +* b <1>: Branch Commands. (line 12) +* b <2>: Editing Rebase Sequences. + (line 85) +* B B: Bisecting. (line 16) +* B b: Bisecting. (line 31) +* b b: Branch Commands. (line 49) +* b C: Branch Commands. (line 29) +* b c: Branch Commands. (line 67) +* B g: Bisecting. (line 36) +* B k: Bisecting. (line 41) +* b k: Branch Commands. (line 147) +* b l: Branch Commands. (line 74) +* b n: Branch Commands. (line 57) +* B r: Bisecting. (line 47) +* b r: Branch Commands. (line 153) +* B s: Bisecting. (line 24) +* b s: Branch Commands. (line 97) +* b S: Branch Commands. (line 125) +* b x: Branch Commands. (line 131) +* c: Blaming. (line 138) +* C: Cloning Repository. (line 20) +* c <1>: Initiating a Commit. (line 8) +* c <2>: Editing Rebase Sequences. + (line 72) +* c a: Initiating a Commit. (line 19) +* c A: Initiating a Commit. (line 67) +* C b: Cloning Repository. (line 41) +* C C: Cloning Repository. (line 29) +* c c: Initiating a Commit. (line 14) +* C d: Cloning Repository. (line 54) +* C e: Cloning Repository. (line 61) +* c e: Initiating a Commit. (line 23) +* c f: Initiating a Commit. (line 43) +* c F: Initiating a Commit. (line 51) +* C m: Cloning Repository. (line 46) +* C s: Cloning Repository. (line 34) +* c s: Initiating a Commit. (line 55) +* c S: Initiating a Commit. (line 63) +* c w: Initiating a Commit. (line 33) +* C-: Visiting Files and Blobs from a Diff. + (line 51) +* C-: Section Visibility. (line 13) +* C-c C-a: Commit Pseudo Headers. + (line 17) +* C-c C-b: Log Buffer. (line 21) +* C-c C-b <1>: Refreshing Diffs. (line 91) +* C-c C-c: Transient Commands. (line 18) +* C-c C-c <1>: Select from Log. (line 20) +* C-c C-c <2>: Editing Commit Messages. + (line 17) +* C-c C-c <3>: Editing Rebase Sequences. + (line 6) +* C-c C-d: Refreshing Diffs. (line 81) +* C-c C-d <1>: Editing Commit Messages. + (line 58) +* C-c C-e: Commands Available in Diffs. + (line 25) +* C-c C-f: Log Buffer. (line 25) +* C-c C-f <1>: Refreshing Diffs. (line 95) +* C-c C-i: Commit Pseudo Headers. + (line 13) +* C-c C-k: Select from Log. (line 26) +* C-c C-k <1>: Editing Commit Messages. + (line 22) +* C-c C-k <2>: Editing Rebase Sequences. + (line 11) +* C-c C-n: Log Buffer. (line 29) +* C-c C-o: Commit Pseudo Headers. + (line 33) +* C-c C-p: Commit Pseudo Headers. + (line 37) +* C-c C-r: Commit Pseudo Headers. + (line 21) +* C-c C-s: Commit Pseudo Headers. + (line 25) +* C-c C-t: Commands Available in Diffs. + (line 14) +* C-c C-t <1>: Commit Pseudo Headers. + (line 29) +* C-c C-w: Using the Revision Stack. + (line 6) +* C-c M-g: Minor Mode for Buffers Visiting Files. + (line 54) +* C-c M-g B: Blaming. (line 21) +* C-c M-g b: Blaming. (line 32) +* C-c M-g B <1>: Minor Mode for Buffers Visiting Files. + (line 123) +* C-c M-g B b: Blaming. (line 33) +* C-c M-g B e: Blaming. (line 67) +* C-c M-g B f: Blaming. (line 58) +* C-c M-g B r: Blaming. (line 49) +* C-c M-g c: Minor Mode for Buffers Visiting Files. + (line 68) +* C-c M-g D: Minor Mode for Buffers Visiting Files. + (line 75) +* C-c M-g d: Minor Mode for Buffers Visiting Files. + (line 86) +* C-c M-g e: Blaming. (line 66) +* C-c M-g e <1>: Minor Mode for Buffers Visiting Files. + (line 136) +* C-c M-g f: Blaming. (line 57) +* C-c M-g L: Minor Mode for Buffers Visiting Files. + (line 96) +* C-c M-g l: Minor Mode for Buffers Visiting Files. + (line 107) +* C-c M-g p: Minor Mode for Buffers Visiting Files. + (line 146) +* C-c M-g r: Blaming. (line 48) +* C-c M-g s: Minor Mode for Buffers Visiting Files. + (line 59) +* C-c M-g t: Minor Mode for Buffers Visiting Files. + (line 114) +* C-c M-g u: Minor Mode for Buffers Visiting Files. + (line 63) +* C-c M-i: Commit Pseudo Headers. + (line 42) +* C-c M-s: Editing Commit Messages. + (line 34) +* C-w: Common Commands. (line 27) +* C-x g: Status Buffer. (line 22) +* C-x u: Editing Rebase Sequences. + (line 94) +* d: Diffing. (line 21) +* D: Refreshing Diffs. (line 11) +* d c: Diffing. (line 69) +* d d: Diffing. (line 27) +* D f: Refreshing Diffs. (line 46) +* D F: Refreshing Diffs. (line 51) +* D g: Refreshing Diffs. (line 17) +* d p: Diffing. (line 61) +* d r: Diffing. (line 31) +* D r: Refreshing Diffs. (line 41) +* d s: Diffing. (line 51) +* D s: Refreshing Diffs. (line 22) +* d t: Diffing. (line 74) +* D t: Refreshing Diffs. (line 37) +* d u: Diffing. (line 57) +* d w: Diffing. (line 45) +* D w: Refreshing Diffs. (line 29) +* DEL: Log Buffer. (line 45) +* DEL <1>: Commands Available in Diffs. + (line 60) +* DEL <2>: Blaming. (line 92) +* DEL <3>: Editing Rebase Sequences. + (line 28) +* e: Ediffing. (line 9) +* E: Ediffing. (line 21) +* e <1>: Editing Rebase Sequences. + (line 55) +* E c: Ediffing. (line 65) +* E i: Ediffing. (line 57) +* E m: Ediffing. (line 35) +* E r: Ediffing. (line 26) +* E s: Ediffing. (line 48) +* E u: Ediffing. (line 53) +* E w: Ediffing. (line 61) +* E z: Ediffing. (line 69) +* f: Editing Rebase Sequences. + (line 63) +* f <1>: Fetching. (line 9) +* F: Pulling. (line 9) +* f a: Fetching. (line 50) +* f C: Branch Commands. (line 30) +* F C: Branch Commands. (line 31) +* f e: Fetching. (line 36) +* F e: Pulling. (line 30) +* f m: Fetching. (line 54) +* f o: Fetching. (line 40) +* f p: Fetching. (line 15) +* F p: Pulling. (line 14) +* f r: Fetching. (line 45) +* f u: Fetching. (line 23) +* F u: Pulling. (line 22) +* g: Automatic Refreshing of Magit Buffers. + (line 24) +* G: Automatic Refreshing of Magit Buffers. + (line 33) +* j: Commands Available in Diffs. + (line 45) +* k: Viewing Git Output. (line 24) +* k <1>: Applying. (line 40) +* k <2>: Editing Rebase Sequences. + (line 68) +* k <3>: Stashing. (line 96) +* l: Logging. (line 29) +* L: Refreshing Logs. (line 11) +* L <1>: Log Buffer. (line 6) +* L <2>: Log Margin. (line 57) +* l <1>: Editing Rebase Sequences. + (line 115) +* l a: Logging. (line 60) +* l b: Logging. (line 56) +* L d: Log Margin. (line 74) +* L g: Refreshing Logs. (line 17) +* l h: Logging. (line 48) +* l H: Reflog. (line 19) +* l l: Logging. (line 35) +* l L: Logging. (line 52) +* L L: Log Margin. (line 66) +* L l: Log Margin. (line 70) +* l o: Logging. (line 41) +* l O: Reflog. (line 15) +* l r: Reflog. (line 11) +* L s: Refreshing Logs. (line 22) +* L t: Refreshing Logs. (line 37) +* L w: Refreshing Logs. (line 29) +* m: Merging. (line 9) +* M: Remote Commands. (line 13) +* m a: Merging. (line 45) +* m a <1>: Merging. (line 95) +* M a: Remote Commands. (line 50) +* M C: Remote Commands. (line 33) +* m e: Merging. (line 31) +* m i: Merging. (line 58) +* M k: Remote Commands. (line 65) +* m m: Merging. (line 18) +* m m <1>: Merging. (line 89) +* m n: Merging. (line 38) +* m p: Merging. (line 81) +* M p: Remote Commands. (line 69) +* M P: Remote Commands. (line 74) +* M r: Remote Commands. (line 55) +* m s: Merging. (line 72) +* M u: Remote Commands. (line 60) +* M-1: Section Visibility. (line 33) +* M-2: Section Visibility. (line 34) +* M-3: Section Visibility. (line 35) +* M-4: Section Visibility. (line 36) +* M-: Section Visibility. (line 17) +* M-n: Section Movement. (line 26) +* M-n <1>: Editing Commit Messages. + (line 44) +* M-n <2>: Editing Rebase Sequences. + (line 47) +* M-p: Section Movement. (line 20) +* M-p <1>: Editing Commit Messages. + (line 38) +* M-p <2>: Editing Rebase Sequences. + (line 43) +* M-w: Blaming. (line 130) +* M-w <1>: Common Commands. (line 10) +* M-x magit-debug-git-executable: Git Executable. (line 45) +* M-x magit-debug-git-executable <1>: Debugging Tools. (line 36) +* M-x magit-describe-section-briefly: Section Types and Values. + (line 13) +* M-x magit-describe-section-briefly <1>: Matching Sections. (line 6) +* M-x magit-emacs-Q-command: Debugging Tools. (line 16) +* M-x magit-init: Creating Repository. (line 6) +* M-x magit-reset-index: Staging and Unstaging. + (line 87) +* M-x magit-reverse-in-index: Staging and Unstaging. + (line 62) +* M-x magit-stage-file: Staging from File-Visiting Buffers. + (line 10) +* M-x magit-toggle-buffer-lock: Modes and Buffers. (line 17) +* M-x magit-toggle-verbose-refresh: Debugging Tools. (line 30) +* M-x magit-unstage-file: Staging from File-Visiting Buffers. + (line 18) +* M-x magit-version: Git Executable. (line 17) +* M-x magit-version <1>: Debugging Tools. (line 10) +* M-x magit-wip-commit: Wip Modes. (line 88) +* M-x with-editor-debug: Debugging Tools. (line 44) +* MM: Editing Rebase Sequences. + (line 125) +* Mt: Editing Rebase Sequences. + (line 132) +* n: Section Movement. (line 16) +* n <1>: Blaming. (line 109) +* N: Blaming. (line 113) +* n <2>: Editing Rebase Sequences. + (line 39) +* n <3>: Minor Mode for Buffers Visiting Blobs. + (line 16) +* o: Submodule Transient. (line 6) +* O: Subtree. (line 8) +* o a: Submodule Transient. (line 20) +* o d: Submodule Transient. (line 50) +* O e: Subtree. (line 42) +* O e p: Subtree. (line 54) +* O e s: Subtree. (line 59) +* o f: Submodule Transient. (line 58) +* O i: Subtree. (line 13) +* O i a: Subtree. (line 25) +* O i c: Subtree. (line 30) +* O i f: Subtree. (line 38) +* O i m: Subtree. (line 34) +* o l: Submodule Transient. (line 54) +* o p: Submodule Transient. (line 34) +* o r: Submodule Transient. (line 27) +* o s: Submodule Transient. (line 44) +* o u: Submodule Transient. (line 39) +* p: Section Movement. (line 10) +* p <1>: Blaming. (line 117) +* P: Blaming. (line 121) +* p <2>: Editing Rebase Sequences. + (line 35) +* P <1>: Pushing. (line 9) +* p <3>: Minor Mode for Buffers Visiting Blobs. + (line 12) +* P C: Branch Commands. (line 32) +* P e: Pushing. (line 31) +* P m: Pushing. (line 50) +* P o: Pushing. (line 36) +* P p: Pushing. (line 15) +* P r: Pushing. (line 41) +* P t: Pushing. (line 58) +* P T: Pushing. (line 66) +* P u: Pushing. (line 23) +* q: Quitting Windows. (line 6) +* q <1>: Log Buffer. (line 14) +* q <2>: Blaming. (line 125) +* q <3>: Minor Mode for Buffers Visiting Blobs. + (line 20) +* r: Rebasing. (line 9) +* r <1>: Editing Rebase Sequences. + (line 51) +* r a: Rebasing. (line 123) +* r e: Rebasing. (line 44) +* r e <1>: Rebasing. (line 118) +* r f: Rebasing. (line 84) +* r i: Rebasing. (line 80) +* r k: Rebasing. (line 99) +* r m: Rebasing. (line 89) +* r p: Rebasing. (line 28) +* r r: Rebasing. (line 106) +* r s: Rebasing. (line 50) +* r s <1>: Rebasing. (line 113) +* r u: Rebasing. (line 36) +* r w: Rebasing. (line 94) +* RET: References Buffer. (line 181) +* RET <1>: Visiting Files and Blobs from a Diff. + (line 8) +* RET <2>: Blaming. (line 78) +* RET <3>: Editing Rebase Sequences. + (line 16) +* s: Staging and Unstaging. + (line 28) +* S: Staging and Unstaging. + (line 36) +* s <1>: Editing Rebase Sequences. + (line 59) +* S-: Section Visibility. (line 22) +* SPC: Log Buffer. (line 35) +* SPC <1>: Commands Available in Diffs. + (line 56) +* SPC <2>: Blaming. (line 82) +* SPC <3>: Editing Rebase Sequences. + (line 21) +* t: Editing Rebase Sequences. + (line 119) +* t <1>: Tagging. (line 8) +* T: Notes. (line 8) +* T a: Notes. (line 52) +* T c: Notes. (line 47) +* t k: Tagging. (line 40) +* T m: Notes. (line 38) +* t p: Tagging. (line 47) +* T p: Notes. (line 30) +* t r: Tagging. (line 19) +* T r: Notes. (line 22) +* t t: Tagging. (line 14) +* T T: Notes. (line 14) +* TAB: Section Visibility. (line 9) +* u: Staging and Unstaging. + (line 43) +* U: Staging and Unstaging. + (line 52) +* v: Applying. (line 44) +* V: Reverting. (line 6) +* V A: Reverting. (line 31) +* V a: Reverting. (line 39) +* V s: Reverting. (line 35) +* V V: Reverting. (line 15) +* V v: Reverting. (line 21) +* W: Plain Patches. (line 6) +* w: Maildir Patches. (line 8) +* w a: Plain Patches. (line 21) +* w a <1>: Maildir Patches. (line 25) +* w a <2>: Maildir Patches. (line 43) +* W c: Plain Patches. (line 12) +* w m: Maildir Patches. (line 21) +* W s: Plain Patches. (line 28) +* w s: Maildir Patches. (line 38) +* w w: Maildir Patches. (line 14) +* w w <1>: Maildir Patches. (line 34) +* x: Editing Rebase Sequences. + (line 76) +* x <1>: Resetting. (line 8) +* X f: Resetting. (line 44) +* X h: Resetting. (line 26) +* X i: Resetting. (line 31) +* X m: Resetting. (line 15) +* X s: Resetting. (line 20) +* X w: Resetting. (line 38) +* X w <1>: Wip Modes. (line 66) +* Y: Cherries. (line 17) +* y: References Buffer. (line 6) +* y <1>: Editing Rebase Sequences. + (line 90) +* y c: References Buffer. (line 26) +* y o: References Buffer. (line 32) +* y y: References Buffer. (line 21) +* z: Stashing. (line 8) +* z a: Stashing. (line 59) +* z b: Stashing. (line 81) +* z B: Stashing. (line 86) +* z f: Stashing. (line 92) +* z i: Stashing. (line 21) +* z I: Stashing. (line 47) +* z k: Stashing. (line 72) +* z l: Stashing. (line 100) +* z p: Stashing. (line 65) +* z v: Stashing. (line 77) +* z w: Stashing. (line 26) +* z W: Stashing. (line 52) +* z x: Stashing. (line 33) +* z z: Stashing. (line 14) +* z Z: Stashing. (line 40) + + +File: magit.info, Node: Command Index, Next: Function Index, Prev: Keystroke Index, Up: Top + +Appendix D Command Index +************************ + +[index] +* Menu: + +* forward-line: Editing Rebase Sequences. + (line 39) +* git-commit-ack: Commit Pseudo Headers. + (line 17) +* git-commit-cc: Commit Pseudo Headers. + (line 33) +* git-commit-insert-pseudo-header: Commit Pseudo Headers. + (line 13) +* git-commit-next-message: Editing Commit Messages. + (line 44) +* git-commit-prev-message: Editing Commit Messages. + (line 38) +* git-commit-reported: Commit Pseudo Headers. + (line 37) +* git-commit-review: Commit Pseudo Headers. + (line 21) +* git-commit-save-message: Editing Commit Messages. + (line 34) +* git-commit-signoff: Commit Pseudo Headers. + (line 25) +* git-commit-suggested: Commit Pseudo Headers. + (line 42) +* git-commit-test: Commit Pseudo Headers. + (line 29) +* git-rebase-backward-line: Editing Rebase Sequences. + (line 35) +* git-rebase-break: Editing Rebase Sequences. + (line 85) +* git-rebase-edit: Editing Rebase Sequences. + (line 55) +* git-rebase-exec: Editing Rebase Sequences. + (line 76) +* git-rebase-fixup: Editing Rebase Sequences. + (line 63) +* git-rebase-insert: Editing Rebase Sequences. + (line 90) +* git-rebase-kill-line: Editing Rebase Sequences. + (line 68) +* git-rebase-label: Editing Rebase Sequences. + (line 115) +* git-rebase-merge: Editing Rebase Sequences. + (line 125) +* git-rebase-merge-toggle-editmsg: Editing Rebase Sequences. + (line 132) +* git-rebase-move-line-down: Editing Rebase Sequences. + (line 47) +* git-rebase-move-line-up: Editing Rebase Sequences. + (line 43) +* git-rebase-pick: Editing Rebase Sequences. + (line 72) +* git-rebase-reset: Editing Rebase Sequences. + (line 119) +* git-rebase-reword: Editing Rebase Sequences. + (line 51) +* git-rebase-show-commit: Editing Rebase Sequences. + (line 16) +* git-rebase-show-or-scroll-down: Editing Rebase Sequences. + (line 28) +* git-rebase-show-or-scroll-up: Editing Rebase Sequences. + (line 21) +* git-rebase-squash: Editing Rebase Sequences. + (line 59) +* git-rebase-undo: Editing Rebase Sequences. + (line 94) +* ido-enter-magit-status: Status Buffer. (line 72) +* magit-am: Maildir Patches. (line 8) +* magit-am-abort: Maildir Patches. (line 43) +* magit-am-apply-maildir: Maildir Patches. (line 21) +* magit-am-apply-patches: Maildir Patches. (line 14) +* magit-am-continue: Maildir Patches. (line 34) +* magit-am-skip: Maildir Patches. (line 38) +* magit-apply: Applying. (line 33) +* magit-bisect: Bisecting. (line 8) +* magit-bisect-bad: Bisecting. (line 31) +* magit-bisect-good: Bisecting. (line 36) +* magit-bisect-reset: Bisecting. (line 47) +* magit-bisect-run: Bisecting. (line 24) +* magit-bisect-skip: Bisecting. (line 41) +* magit-bisect-start: Bisecting. (line 16) +* magit-blame: Blaming. (line 21) +* magit-blame <1>: Blaming. (line 105) +* magit-blame <2>: Minor Mode for Buffers Visiting Files. + (line 123) +* magit-blame-addition: Blaming. (line 32) +* magit-blame-addition <1>: Blaming. (line 33) +* magit-blame-copy-hash: Blaming. (line 130) +* magit-blame-cycle-style: Blaming. (line 138) +* magit-blame-echo: Blaming. (line 66) +* magit-blame-echo <1>: Blaming. (line 67) +* magit-blame-next-chunk: Blaming. (line 109) +* magit-blame-next-chunk-same-commit: Blaming. (line 113) +* magit-blame-previous-chunk: Blaming. (line 117) +* magit-blame-previous-chunk-same-commit: Blaming. (line 121) +* magit-blame-quit: Blaming. (line 125) +* magit-blame-removal: Blaming. (line 48) +* magit-blame-removal <1>: Blaming. (line 49) +* magit-blame-reverse: Blaming. (line 57) +* magit-blame-reverse <1>: Blaming. (line 58) +* magit-blob-next: Minor Mode for Buffers Visiting Blobs. + (line 16) +* magit-blob-previous: Minor Mode for Buffers Visiting Files. + (line 146) +* magit-blob-previous <1>: Minor Mode for Buffers Visiting Blobs. + (line 12) +* magit-branch: Branch Commands. (line 12) +* magit-branch-and-checkout: Branch Commands. (line 67) +* magit-branch-checkout: Branch Commands. (line 74) +* magit-branch-configure: Branch Commands. (line 29) +* magit-branch-configure <1>: Branch Commands. (line 30) +* magit-branch-configure <2>: Branch Commands. (line 31) +* magit-branch-configure <3>: Branch Commands. (line 32) +* magit-branch-create: Branch Commands. (line 57) +* magit-branch-delete: Branch Commands. (line 147) +* magit-branch-or-checkout: Branch Commands. (line 257) +* magit-branch-orphan: Branch Commands. (line 252) +* magit-branch-rename: Branch Commands. (line 153) +* magit-branch-reset: Branch Commands. (line 131) +* magit-branch-shelve: Auxiliary Branch Commands. + (line 9) +* magit-branch-spinoff: Branch Commands. (line 97) +* magit-branch-spinout: Branch Commands. (line 125) +* magit-branch-unshelve: Auxiliary Branch Commands. + (line 20) +* magit-checkout: Branch Commands. (line 49) +* magit-cherry: Cherries. (line 17) +* magit-cherry-apply: Cherry Picking. (line 24) +* magit-cherry-copy: Cherry Picking. (line 17) +* magit-cherry-donate: Cherry Picking. (line 54) +* magit-cherry-harvest: Cherry Picking. (line 42) +* magit-cherry-pick: Cherry Picking. (line 8) +* magit-cherry-spinoff: Cherry Picking. (line 76) +* magit-cherry-spinout: Cherry Picking. (line 65) +* magit-clone: Cloning Repository. (line 20) +* magit-clone-bare: Cloning Repository. (line 41) +* magit-clone-mirror: Cloning Repository. (line 46) +* magit-clone-regular: Cloning Repository. (line 29) +* magit-clone-shallow: Cloning Repository. (line 34) +* magit-clone-shallow-exclude: Cloning Repository. (line 61) +* magit-clone-shallow-since: Cloning Repository. (line 54) +* magit-commit: Initiating a Commit. (line 8) +* magit-commit <1>: Minor Mode for Buffers Visiting Files. + (line 68) +* magit-commit-amend: Initiating a Commit. (line 19) +* magit-commit-augment: Initiating a Commit. (line 67) +* magit-commit-create: Initiating a Commit. (line 14) +* magit-commit-extend: Initiating a Commit. (line 23) +* magit-commit-fixup: Initiating a Commit. (line 43) +* magit-commit-instant-fixup: Initiating a Commit. (line 51) +* magit-commit-instant-squash: Initiating a Commit. (line 63) +* magit-commit-reword: Initiating a Commit. (line 33) +* magit-commit-squash: Initiating a Commit. (line 55) +* magit-copy-buffer-revision: Common Commands. (line 27) +* magit-copy-section-value: Common Commands. (line 10) +* magit-cycle-margin-style: Log Margin. (line 70) +* magit-debug-git-executable: Git Executable. (line 45) +* magit-debug-git-executable <1>: Debugging Tools. (line 36) +* magit-describe-section-briefly: Section Types and Values. + (line 13) +* magit-describe-section-briefly <1>: Matching Sections. (line 6) +* magit-diff: Diffing. (line 21) +* magit-diff <1>: Minor Mode for Buffers Visiting Files. + (line 75) +* magit-diff-buffer-file: Minor Mode for Buffers Visiting Files. + (line 86) +* magit-diff-default-context: Refreshing Diffs. (line 73) +* magit-diff-dwim: Diffing. (line 27) +* magit-diff-edit-hunk-commit: Commands Available in Diffs. + (line 25) +* magit-diff-flip-revs: Refreshing Diffs. (line 46) +* magit-diff-less-context: Refreshing Diffs. (line 65) +* magit-diff-more-context: Refreshing Diffs. (line 69) +* magit-diff-paths: Diffing. (line 61) +* magit-diff-range: Diffing. (line 31) +* magit-diff-refresh: Refreshing Diffs. (line 11) +* magit-diff-refresh <1>: Refreshing Diffs. (line 17) +* magit-diff-save-default-arguments: Refreshing Diffs. (line 29) +* magit-diff-set-default-arguments: Refreshing Diffs. (line 22) +* magit-diff-show-or-scroll-down: Log Buffer. (line 45) +* magit-diff-show-or-scroll-down <1>: Blaming. (line 92) +* magit-diff-show-or-scroll-up: Log Buffer. (line 35) +* magit-diff-show-or-scroll-up <1>: Blaming. (line 82) +* magit-diff-staged: Diffing. (line 51) +* magit-diff-switch-range-type: Refreshing Diffs. (line 41) +* magit-diff-toggle-file-filter: Refreshing Diffs. (line 51) +* magit-diff-toggle-refine-hunk: Refreshing Diffs. (line 37) +* magit-diff-trace-definition: Commands Available in Diffs. + (line 14) +* magit-diff-unstaged: Diffing. (line 57) +* magit-diff-visit-file: Visiting Files and Blobs from a Diff. + (line 8) +* magit-diff-visit-file-other-frame: Visiting Files and Blobs from a Diff. + (line 74) +* magit-diff-visit-file-other-window: Visiting Files and Blobs from a Diff. + (line 73) +* magit-diff-visit-file-worktree: Visiting Files and Blobs from a Diff. + (line 51) +* magit-diff-visit-worktree-file-other-frame: Visiting Files and Blobs from a Diff. + (line 76) +* magit-diff-visit-worktree-file-other-window: Visiting Files and Blobs from a Diff. + (line 75) +* magit-diff-while-committing: Refreshing Diffs. (line 81) +* magit-diff-while-committing <1>: Editing Commit Messages. + (line 58) +* magit-diff-working-tree: Diffing. (line 45) +* magit-discard: Applying. (line 40) +* magit-dispatch: Transient Commands. (line 18) +* magit-ediff: Ediffing. (line 21) +* magit-ediff-compare: Ediffing. (line 26) +* magit-ediff-dwim: Ediffing. (line 9) +* magit-ediff-resolve: Ediffing. (line 35) +* magit-ediff-show-commit: Ediffing. (line 65) +* magit-ediff-show-staged: Ediffing. (line 57) +* magit-ediff-show-stash: Ediffing. (line 69) +* magit-ediff-show-unstaged: Ediffing. (line 53) +* magit-ediff-show-working-tree: Ediffing. (line 61) +* magit-ediff-stage: Ediffing. (line 48) +* magit-edit-line-commit: Minor Mode for Buffers Visiting Files. + (line 136) +* magit-emacs-Q-command: Debugging Tools. (line 16) +* magit-fetch: Fetching. (line 9) +* magit-fetch-all: Fetching. (line 50) +* magit-fetch-branch: Fetching. (line 40) +* magit-fetch-from-pushremote: Fetching. (line 15) +* magit-fetch-from-upstream: Fetching. (line 23) +* magit-fetch-modules: Submodule Transient. (line 58) +* magit-fetch-other: Fetching. (line 36) +* magit-fetch-refspec: Fetching. (line 45) +* magit-file-checkout: Resetting. (line 44) +* magit-file-checkout <1>: Minor Mode for Buffers Visiting Files. + (line 165) +* magit-file-delete: Minor Mode for Buffers Visiting Files. + (line 157) +* magit-file-dispatch: Minor Mode for Buffers Visiting Files. + (line 54) +* magit-file-rename: Minor Mode for Buffers Visiting Files. + (line 153) +* magit-file-untrack: Minor Mode for Buffers Visiting Files. + (line 161) +* magit-find-file: General-Purpose Visit Commands. + (line 9) +* magit-find-file-other-frame: General-Purpose Visit Commands. + (line 21) +* magit-find-file-other-window: General-Purpose Visit Commands. + (line 15) +* magit-git-command: Running Git Manually. + (line 25) +* magit-git-command-topdir: Running Git Manually. + (line 17) +* magit-go-backward: Log Buffer. (line 21) +* magit-go-backward <1>: Refreshing Diffs. (line 91) +* magit-go-forward: Log Buffer. (line 25) +* magit-go-forward <1>: Refreshing Diffs. (line 95) +* magit-init: Creating Repository. (line 6) +* magit-jump-to-diffstat-or-diff: Commands Available in Diffs. + (line 45) +* magit-kill-this-buffer: Minor Mode for Buffers Visiting Blobs. + (line 20) +* magit-list-repositories: Repository List. (line 6) +* magit-list-submodules: Listing Submodules. (line 13) +* magit-list-submodules <1>: Submodule Transient. (line 54) +* magit-log: Logging. (line 29) +* magit-log <1>: Minor Mode for Buffers Visiting Files. + (line 96) +* magit-log-all: Logging. (line 60) +* magit-log-all-branches: Logging. (line 56) +* magit-log-branches: Logging. (line 52) +* magit-log-buffer-file: Minor Mode for Buffers Visiting Files. + (line 107) +* magit-log-bury-buffer: Log Buffer. (line 14) +* magit-log-current: Logging. (line 35) +* magit-log-double-commit-limit: Log Buffer. (line 61) +* magit-log-half-commit-limit: Log Buffer. (line 65) +* magit-log-head: Logging. (line 48) +* magit-log-move-to-parent: Log Buffer. (line 29) +* magit-log-other: Logging. (line 41) +* magit-log-refresh: Refreshing Logs. (line 11) +* magit-log-refresh <1>: Refreshing Logs. (line 17) +* magit-log-refresh <2>: Log Buffer. (line 6) +* magit-log-save-default-arguments: Refreshing Logs. (line 29) +* magit-log-select-pick: Select from Log. (line 20) +* magit-log-select-quit: Select from Log. (line 26) +* magit-log-set-default-arguments: Refreshing Logs. (line 22) +* magit-log-toggle-commit-limit: Log Buffer. (line 55) +* magit-log-trace-definition: Minor Mode for Buffers Visiting Files. + (line 114) +* magit-margin-settings: Log Margin. (line 57) +* magit-merge: Merging. (line 9) +* magit-merge <1>: Merging. (line 89) +* magit-merge-abort: Merging. (line 95) +* magit-merge-absorb: Merging. (line 45) +* magit-merge-editmsg: Merging. (line 31) +* magit-merge-into: Merging. (line 58) +* magit-merge-nocommit: Merging. (line 38) +* magit-merge-plain: Merging. (line 18) +* magit-merge-preview: Merging. (line 81) +* magit-merge-squash: Merging. (line 72) +* magit-mode-bury-buffer: Quitting Windows. (line 6) +* magit-notes: Notes. (line 8) +* magit-notes-edit: Notes. (line 14) +* magit-notes-merge: Notes. (line 38) +* magit-notes-merge-abort: Notes. (line 52) +* magit-notes-merge-commit: Notes. (line 47) +* magit-notes-prune: Notes. (line 30) +* magit-notes-remove: Notes. (line 22) +* magit-patch: Plain Patches. (line 6) +* magit-patch-apply: Plain Patches. (line 21) +* magit-patch-apply <1>: Maildir Patches. (line 25) +* magit-patch-create: Plain Patches. (line 12) +* magit-patch-save: Plain Patches. (line 28) +* magit-pop-revision-stack: Using the Revision Stack. + (line 6) +* magit-process: Viewing Git Output. (line 16) +* magit-process-kill: Viewing Git Output. (line 24) +* magit-pull: Pulling. (line 9) +* magit-pull-branch: Pulling. (line 30) +* magit-pull-from-pushremote: Pulling. (line 14) +* magit-pull-from-upstream: Pulling. (line 22) +* magit-push: Pushing. (line 9) +* magit-push-current: Pushing. (line 31) +* magit-push-current-to-pushremote: Pushing. (line 15) +* magit-push-current-to-upstream: Pushing. (line 23) +* magit-push-implicitly args: Pushing. (line 74) +* magit-push-matching: Pushing. (line 50) +* magit-push-other: Pushing. (line 36) +* magit-push-refspecs: Pushing. (line 41) +* magit-push-tag: Pushing. (line 66) +* magit-push-tags: Pushing. (line 58) +* magit-push-to-remote remote args: Pushing. (line 85) +* magit-rebase: Rebasing. (line 9) +* magit-rebase-abort: Rebasing. (line 123) +* magit-rebase-autosquash: Rebasing. (line 84) +* magit-rebase-branch: Rebasing. (line 44) +* magit-rebase-continue: Rebasing. (line 106) +* magit-rebase-edit: Rebasing. (line 118) +* magit-rebase-edit-commit: Rebasing. (line 89) +* magit-rebase-interactive: Rebasing. (line 80) +* magit-rebase-onto-pushremote: Rebasing. (line 28) +* magit-rebase-onto-upstream: Rebasing. (line 36) +* magit-rebase-remove-commit: Rebasing. (line 99) +* magit-rebase-reword-commit: Rebasing. (line 94) +* magit-rebase-skip: Rebasing. (line 113) +* magit-rebase-subset: Rebasing. (line 50) +* magit-reflog-current: Reflog. (line 11) +* magit-reflog-head: Reflog. (line 19) +* magit-reflog-other: Reflog. (line 15) +* magit-refresh: Automatic Refreshing of Magit Buffers. + (line 24) +* magit-refresh-all: Automatic Refreshing of Magit Buffers. + (line 33) +* magit-remote: Remote Commands. (line 13) +* magit-remote-add: Remote Commands. (line 50) +* magit-remote-configure: Remote Commands. (line 33) +* magit-remote-prune: Remote Commands. (line 69) +* magit-remote-prune-refspecs: Remote Commands. (line 74) +* magit-remote-remove: Remote Commands. (line 65) +* magit-remote-rename: Remote Commands. (line 55) +* magit-remote-set-url: Remote Commands. (line 60) +* magit-reset-hard: Resetting. (line 26) +* magit-reset-index: Staging and Unstaging. + (line 87) +* magit-reset-index <1>: Resetting. (line 31) +* magit-reset-mixed: Resetting. (line 15) +* magit-reset-quickly: Resetting. (line 8) +* magit-reset-soft: Resetting. (line 20) +* magit-reset-worktree: Resetting. (line 38) +* magit-reset-worktree <1>: Wip Modes. (line 66) +* magit-reverse: Applying. (line 44) +* magit-reverse-in-index: Staging and Unstaging. + (line 62) +* magit-revert: Reverting. (line 6) +* magit-revert-and-commit: Reverting. (line 15) +* magit-revert-no-commit: Reverting. (line 21) +* magit-run: Running Git Manually. + (line 12) +* magit-run-git-gui: Running Git Manually. + (line 66) +* magit-run-gitk: Running Git Manually. + (line 54) +* magit-run-gitk-all: Running Git Manually. + (line 58) +* magit-run-gitk-branches: Running Git Manually. + (line 62) +* magit-section-backward: Section Movement. (line 10) +* magit-section-backward-siblings: Section Movement. (line 20) +* magit-section-cycle: Section Visibility. (line 13) +* magit-section-cycle-diffs: Section Visibility. (line 17) +* magit-section-cycle-global: Section Visibility. (line 22) +* magit-section-forward: Section Movement. (line 16) +* magit-section-forward-siblings: Section Movement. (line 26) +* magit-section-hide: Section Visibility. (line 49) +* magit-section-hide-children: Section Visibility. (line 64) +* magit-section-show: Section Visibility. (line 45) +* magit-section-show-children: Section Visibility. (line 58) +* magit-section-show-headings: Section Visibility. (line 53) +* magit-section-show-level-1: Section Visibility. (line 26) +* magit-section-show-level-1-all: Section Visibility. (line 33) +* magit-section-show-level-2: Section Visibility. (line 27) +* magit-section-show-level-2-all: Section Visibility. (line 34) +* magit-section-show-level-3: Section Visibility. (line 28) +* magit-section-show-level-3-all: Section Visibility. (line 35) +* magit-section-show-level-4: Section Visibility. (line 29) +* magit-section-show-level-4-all: Section Visibility. (line 36) +* magit-section-toggle: Section Visibility. (line 9) +* magit-section-toggle-children: Section Visibility. (line 68) +* magit-section-up: Section Movement. (line 31) +* magit-sequence-abort: Cherry Picking. (line 98) +* magit-sequence-abort <1>: Reverting. (line 39) +* magit-sequence-continue: Cherry Picking. (line 90) +* magit-sequence-continue <1>: Reverting. (line 31) +* magit-sequence-skip: Cherry Picking. (line 94) +* magit-sequence-skip <1>: Reverting. (line 35) +* magit-shell-command: Running Git Manually. + (line 40) +* magit-shell-command-topdir: Running Git Manually. + (line 35) +* magit-show-commit: Diffing. (line 69) +* magit-show-commit <1>: Blaming. (line 78) +* magit-show-refs: References Buffer. (line 6) +* magit-show-refs-current: References Buffer. (line 26) +* magit-show-refs-head: References Buffer. (line 21) +* magit-show-refs-other: References Buffer. (line 32) +* magit-snapshot-both: Stashing. (line 40) +* magit-snapshot-index: Stashing. (line 47) +* magit-snapshot-worktree: Stashing. (line 52) +* magit-stage: Staging and Unstaging. + (line 28) +* magit-stage-file: Staging from File-Visiting Buffers. + (line 10) +* magit-stage-file <1>: Minor Mode for Buffers Visiting Files. + (line 59) +* magit-stage-modified: Staging and Unstaging. + (line 36) +* magit-stash: Stashing. (line 8) +* magit-stash-apply: Stashing. (line 59) +* magit-stash-both: Stashing. (line 14) +* magit-stash-branch: Stashing. (line 81) +* magit-stash-branch-here: Stashing. (line 86) +* magit-stash-clear: Stashing. (line 96) +* magit-stash-drop: Stashing. (line 72) +* magit-stash-format-patch: Stashing. (line 92) +* magit-stash-index: Stashing. (line 21) +* magit-stash-keep-index: Stashing. (line 33) +* magit-stash-list: Stashing. (line 100) +* magit-stash-pop: Stashing. (line 65) +* magit-stash-show: Diffing. (line 74) +* magit-stash-show <1>: Stashing. (line 77) +* magit-stash-worktree: Stashing. (line 26) +* magit-status: Status Buffer. (line 22) +* magit-submodule: Submodule Transient. (line 6) +* magit-submodule-add: Submodule Transient. (line 20) +* magit-submodule-fetch: Fetching. (line 54) +* magit-submodule-populate: Submodule Transient. (line 34) +* magit-submodule-register: Submodule Transient. (line 27) +* magit-submodule-synchronize: Submodule Transient. (line 44) +* magit-submodule-unpopulate: Submodule Transient. (line 50) +* magit-submodule-update: Submodule Transient. (line 39) +* magit-subtree: Subtree. (line 8) +* magit-subtree-add: Subtree. (line 25) +* magit-subtree-add-commit: Subtree. (line 30) +* magit-subtree-export: Subtree. (line 42) +* magit-subtree-import: Subtree. (line 13) +* magit-subtree-merge: Subtree. (line 34) +* magit-subtree-pull: Subtree. (line 38) +* magit-subtree-push: Subtree. (line 54) +* magit-subtree-split: Subtree. (line 59) +* magit-tag: Tagging. (line 8) +* magit-tag-create: Tagging. (line 14) +* magit-tag-delete: Tagging. (line 40) +* magit-tag-prune: Tagging. (line 47) +* magit-tag-release: Tagging. (line 19) +* magit-toggle-buffer-lock: Modes and Buffers. (line 17) +* magit-toggle-margin: Refreshing Logs. (line 37) +* magit-toggle-margin <1>: Log Margin. (line 66) +* magit-toggle-margin-details: Log Margin. (line 74) +* magit-toggle-verbose-refresh: Debugging Tools. (line 30) +* magit-unstage: Staging and Unstaging. + (line 43) +* magit-unstage-all: Staging and Unstaging. + (line 52) +* magit-unstage-file: Staging from File-Visiting Buffers. + (line 18) +* magit-unstage-file <1>: Minor Mode for Buffers Visiting Files. + (line 63) +* magit-version: Git Executable. (line 17) +* magit-version <1>: Debugging Tools. (line 10) +* magit-visit-ref: References Buffer. (line 181) +* magit-wip-commit: Wip Modes. (line 88) +* magit-wip-log: Wip Modes. (line 48) +* magit-wip-log-current: Wip Modes. (line 57) +* magit-worktree: Worktree. (line 8) +* magit-worktree-branch: Worktree. (line 17) +* magit-worktree-checkout: Worktree. (line 13) +* magit-worktree-delete: Worktree. (line 25) +* magit-worktree-move: Worktree. (line 21) +* magit-worktree-status: Worktree. (line 30) +* scroll-down: Commands Available in Diffs. + (line 60) +* scroll-up: Commands Available in Diffs. + (line 56) +* with-editor-cancel: Editing Commit Messages. + (line 22) +* with-editor-cancel <1>: Editing Rebase Sequences. + (line 11) +* with-editor-debug: Debugging Tools. (line 44) +* with-editor-finish: Editing Commit Messages. + (line 17) +* with-editor-finish <1>: Editing Rebase Sequences. + (line 6) + + +File: magit.info, Node: Function Index, Next: Variable Index, Prev: Command Index, Up: Top + +Appendix E Function Index +************************* + +[index] +* Menu: + +* bug-reference-mode: Commit Mode and Hooks. + (line 56) +* git-commit-check-style-conventions: Commit Message Conventions. + (line 40) +* git-commit-propertize-diff: Commit Mode and Hooks. + (line 47) +* git-commit-save-message: Commit Mode and Hooks. + (line 28) +* git-commit-setup-changelog-support: Commit Mode and Hooks. + (line 32) +* git-commit-turn-on-auto-fill: Commit Mode and Hooks. + (line 37) +* git-commit-turn-on-flyspell: Commit Mode and Hooks. + (line 42) +* ido-enter-magit-status: Status Buffer. (line 72) +* magit-add-section-hook: Section Hooks. (line 20) +* magit-after-save-refresh-status: Automatic Refreshing of Magit Buffers. + (line 58) +* magit-branch-or-checkout: Branch Commands. (line 257) +* magit-branch-orphan: Branch Commands. (line 252) +* magit-branch-shelve: Auxiliary Branch Commands. + (line 9) +* magit-branch-unshelve: Auxiliary Branch Commands. + (line 20) +* magit-builtin-completing-read: Support for Completion Frameworks. + (line 42) +* magit-call-git: Calling Git for Effect. + (line 28) +* magit-call-process: Calling Git for Effect. + (line 32) +* magit-cancel-section: Creating Sections. (line 71) +* magit-completing-read: Support for Completion Frameworks. + (line 60) +* magit-current-section: Section Selection. (line 6) +* magit-define-section-jumper: Creating Sections. (line 77) +* magit-diff-scope: Matching Sections. (line 118) +* magit-diff-type: Matching Sections. (line 95) +* magit-diff-visit-file-other-frame: Visiting Files and Blobs from a Diff. + (line 74) +* magit-diff-visit-file-other-window: Visiting Files and Blobs from a Diff. + (line 73) +* magit-diff-visit-worktree-file-other-frame: Visiting Files and Blobs from a Diff. + (line 76) +* magit-diff-visit-worktree-file-other-window: Visiting Files and Blobs from a Diff. + (line 75) +* magit-disable-section-inserter: Per-Repository Configuration. + (line 31) +* magit-display-buffer: Switching Buffers. (line 6) +* magit-display-buffer-fullcolumn-most-v1: Switching Buffers. (line 75) +* magit-display-buffer-fullframe-status-topleft-v1: Switching Buffers. + (line 65) +* magit-display-buffer-fullframe-status-v1: Switching Buffers. + (line 59) +* magit-display-buffer-same-window-except-diff-v1: Switching Buffers. + (line 53) +* magit-display-buffer-traditional: Switching Buffers. (line 45) +* magit-file-checkout: Minor Mode for Buffers Visiting Files. + (line 165) +* magit-file-delete: Minor Mode for Buffers Visiting Files. + (line 157) +* magit-file-rename: Minor Mode for Buffers Visiting Files. + (line 153) +* magit-file-untrack: Minor Mode for Buffers Visiting Files. + (line 161) +* magit-find-file: General-Purpose Visit Commands. + (line 9) +* magit-find-file-other-frame: General-Purpose Visit Commands. + (line 21) +* magit-find-file-other-window: General-Purpose Visit Commands. + (line 15) +* magit-generate-buffer-name-default-function: Naming Buffers. + (line 17) +* magit-get-section: Matching Sections. (line 16) +* magit-git: Calling Git for Effect. + (line 65) +* magit-git-exit-code: Getting a Value from Git. + (line 10) +* magit-git-failure: Getting a Value from Git. + (line 19) +* magit-git-false: Getting a Value from Git. + (line 29) +* magit-git-insert: Getting a Value from Git. + (line 34) +* magit-git-items: Getting a Value from Git. + (line 49) +* magit-git-lines: Getting a Value from Git. + (line 44) +* magit-git-str: Getting a Value from Git. + (line 72) +* magit-git-string: Getting a Value from Git. + (line 38) +* magit-git-success: Getting a Value from Git. + (line 14) +* magit-git-true: Getting a Value from Git. + (line 24) +* magit-git-wash: Calling Git for Effect. + (line 70) +* magit-hunk-set-window-start: Section Movement. (line 51) +* magit-ido-completing-read: Support for Completion Frameworks. + (line 48) +* magit-insert-am-sequence: Status Sections. (line 28) +* magit-insert-assumed-unchanged-files: Status Sections. (line 117) +* magit-insert-bisect-log: Status Sections. (line 46) +* magit-insert-bisect-output: Status Sections. (line 38) +* magit-insert-bisect-rest: Status Sections. (line 42) +* magit-insert-diff-filter-header: Status Header Sections. + (line 38) +* magit-insert-error-header: Status Header Sections. + (line 28) +* magit-insert-head-branch-header: Status Header Sections. + (line 42) +* magit-insert-heading: Creating Sections. (line 42) +* magit-insert-ignored-files: Status Sections. (line 100) +* magit-insert-local-branches: References Sections. (line 17) +* magit-insert-merge-log: Status Sections. (line 18) +* magit-insert-modules: Status Module Sections. + (line 12) +* magit-insert-modules-overview: Status Module Sections. + (line 33) +* magit-insert-modules-unpulled-from-pushremote: Status Module Sections. + (line 50) +* magit-insert-modules-unpulled-from-upstream: Status Module Sections. + (line 44) +* magit-insert-modules-unpushed-to-pushremote: Status Module Sections. + (line 62) +* magit-insert-modules-unpushed-to-upstream: Status Module Sections. + (line 56) +* magit-insert-push-branch-header: Status Header Sections. + (line 51) +* magit-insert-rebase-sequence: Status Sections. (line 23) +* magit-insert-recent-commits: Status Sections. (line 131) +* magit-insert-remote-branches: References Sections. (line 21) +* magit-insert-remote-header: Status Header Sections. + (line 67) +* magit-insert-repo-header: Status Header Sections. + (line 63) +* magit-insert-section: Creating Sections. (line 6) +* magit-insert-sequencer-sequence: Status Sections. (line 33) +* magit-insert-skip-worktree-files: Status Sections. (line 110) +* magit-insert-staged-changes: Status Sections. (line 63) +* magit-insert-stashes: Status Sections. (line 67) +* magit-insert-status-headers: Status Header Sections. + (line 12) +* magit-insert-submodules: Listing Submodules. (line 35) +* magit-insert-tags: References Sections. (line 25) +* magit-insert-tags-header: Status Header Sections. + (line 56) +* magit-insert-tracked-files: Status Sections. (line 96) +* magit-insert-unpulled-cherries: Status Sections. (line 142) +* magit-insert-unpulled-from-pushremote: Status Sections. (line 79) +* magit-insert-unpulled-from-upstream: Status Sections. (line 74) +* magit-insert-unpulled-or-recent-commits: Status Sections. (line 124) +* magit-insert-unpushed-cherries: Status Sections. (line 149) +* magit-insert-unpushed-to-pushremote: Status Sections. (line 89) +* magit-insert-unpushed-to-upstream: Status Sections. (line 84) +* magit-insert-unstaged-changes: Status Sections. (line 59) +* magit-insert-untracked-files: Status Sections. (line 50) +* magit-insert-upstream-branch-header: Status Header Sections. + (line 46) +* magit-insert-user-header: Status Header Sections. + (line 75) +* magit-list-repositories: Repository List. (line 6) +* magit-list-submodules: Listing Submodules. (line 13) +* magit-log-maybe-show-more-commits: Section Movement. (line 66) +* magit-log-maybe-update-blob-buffer: Section Movement. (line 82) +* magit-log-maybe-update-revision-buffer: Section Movement. (line 74) +* magit-maybe-set-dedicated: Switching Buffers. (line 100) +* magit-mode-display-buffer: Refreshing Buffers. (line 33) +* magit-mode-quit-window: Quitting Windows. (line 34) +* magit-mode-setup: Refreshing Buffers. (line 17) +* magit-push-implicitly: Pushing. (line 74) +* magit-push-to-remote: Pushing. (line 85) +* magit-region-sections: Section Selection. (line 10) +* magit-region-values: Section Selection. (line 37) +* magit-repolist-column-branch: Repository List. (line 44) +* magit-repolist-column-branches: Repository List. (line 53) +* magit-repolist-column-flag: Repository List. (line 61) +* magit-repolist-column-ident: Repository List. (line 30) +* magit-repolist-column-path: Repository List. (line 35) +* magit-repolist-column-stashes: Repository List. (line 57) +* magit-repolist-column-unpulled-from-pushremote: Repository List. + (line 81) +* magit-repolist-column-unpulled-from-upstream: Repository List. + (line 76) +* magit-repolist-column-unpushed-to-pushremote: Repository List. + (line 91) +* magit-repolist-column-unpushed-to-upstream: Repository List. + (line 86) +* magit-repolist-column-upstream: Repository List. (line 48) +* magit-repolist-column-version: Repository List. (line 39) +* magit-restore-window-configuration: Quitting Windows. (line 23) +* magit-run-git: Calling Git for Effect. + (line 36) +* magit-run-git-async: Calling Git for Effect. + (line 80) +* magit-run-git-with-editor: Calling Git for Effect. + (line 93) +* magit-run-git-with-input: Calling Git for Effect. + (line 40) +* magit-run-git-with-logfile: Calling Git for Effect. + (line 56) +* magit-save-window-configuration: Switching Buffers. (line 89) +* magit-section-case: Matching Sections. (line 71) +* magit-section-hide: Section Visibility. (line 49) +* magit-section-hide-children: Section Visibility. (line 64) +* magit-section-ident: Matching Sections. (line 11) +* magit-section-match: Matching Sections. (line 21) +* magit-section-set-window-start: Section Movement. (line 59) +* magit-section-show: Section Visibility. (line 45) +* magit-section-show-children: Section Visibility. (line 58) +* magit-section-show-headings: Section Visibility. (line 53) +* magit-section-toggle-children: Section Visibility. (line 68) +* magit-section-value-if: Matching Sections. (line 61) +* magit-start-git: Calling Git for Effect. + (line 105) +* magit-start-process: Calling Git for Effect. + (line 124) +* magit-stashes-maybe-update-stash-buffer: Section Movement. (line 106) +* magit-status-maybe-update-blob-buffer: Section Movement. (line 100) +* magit-status-maybe-update-revision-buffer: Section Movement. + (line 88) +* magit-status-maybe-update-stash-buffer: Section Movement. (line 94) +* magit-wip-log: Wip Modes. (line 48) +* magit-wip-log-current: Wip Modes. (line 57) +* with-editor-usage-message: Commit Mode and Hooks. + (line 60) + + +File: magit.info, Node: Variable Index, Prev: Function Index, Up: Top + +Appendix F Variable Index +************************* + +[index] +* Menu: + +* auto-revert-buffer-list-filter: Automatic Reverting of File-Visiting Buffers. + (line 81) +* auto-revert-interval: Automatic Reverting of File-Visiting Buffers. + (line 76) +* auto-revert-mode: Automatic Reverting of File-Visiting Buffers. + (line 62) +* auto-revert-stop-on-user-input: Automatic Reverting of File-Visiting Buffers. + (line 71) +* auto-revert-use-notify: Automatic Reverting of File-Visiting Buffers. + (line 49) +* auto-revert-verbose: Automatic Reverting of File-Visiting Buffers. + (line 103) +* branch.autoSetupMerge: Branch Git Variables. + (line 81) +* branch.autoSetupRebase: Branch Git Variables. + (line 98) +* branch.NAME.description: Branch Git Variables. + (line 48) +* branch.NAME.merge: Branch Git Variables. + (line 10) +* branch.NAME.pushRemote: Branch Git Variables. + (line 34) +* branch.NAME.rebase: Branch Git Variables. + (line 22) +* branch.NAME.remote: Branch Git Variables. + (line 16) +* core.notesRef: Notes. (line 60) +* git-commit-fill-column: Commit Message Conventions. + (line 19) +* git-commit-finish-query-functions: Commit Message Conventions. + (line 24) +* git-commit-known-pseudo-headers: Commit Pseudo Headers. + (line 9) +* git-commit-major-mode: Commit Mode and Hooks. + (line 12) +* git-commit-setup-hook: Commit Mode and Hooks. + (line 22) +* git-commit-setup-hook <1>: Commit Mode and Hooks. + (line 64) +* git-commit-style-convention-checks: Commit Message Conventions. + (line 46) +* git-commit-summary-max-length: Commit Message Conventions. + (line 13) +* git-rebase-auto-advance: Editing Rebase Sequences. + (line 99) +* git-rebase-confirm-cancel: Editing Rebase Sequences. + (line 107) +* git-rebase-show-instructions: Editing Rebase Sequences. + (line 103) +* global-auto-revert-mode: Automatic Reverting of File-Visiting Buffers. + (line 22) +* global-magit-file-mode: Minor Mode for Buffers Visiting Files. + (line 13) +* magit-auto-revert-immediately: Automatic Reverting of File-Visiting Buffers. + (line 32) +* magit-auto-revert-mode: Automatic Reverting of File-Visiting Buffers. + (line 17) +* magit-auto-revert-tracked-only: Automatic Reverting of File-Visiting Buffers. + (line 55) +* magit-bisect-show-graph: Bisecting. (line 55) +* magit-blame-disable-modes: Blaming. (line 168) +* magit-blame-echo-style: Blaming. (line 151) +* magit-blame-goto-chunk-hook: Blaming. (line 174) +* magit-blame-read-only: Blaming. (line 163) +* magit-blame-styles: Blaming. (line 146) +* magit-blame-time-format: Blaming. (line 158) +* magit-branch-adjust-remote-upstream-alist: Branch Commands. (line 210) +* magit-branch-direct-configure: Branch Commands. (line 20) +* magit-branch-prefer-remote-upstream: Branch Commands. (line 165) +* magit-branch-read-upstream-first: Branch Commands. (line 159) +* magit-buffer-name-format: Naming Buffers. (line 27) +* magit-bury-buffer-function: Quitting Windows. (line 14) +* magit-cherry-margin: Cherries. (line 22) +* magit-clone-always-transient: Cloning Repository. (line 12) +* magit-clone-default-directory: Cloning Repository. (line 90) +* magit-clone-name-alist: Cloning Repository. (line 103) +* magit-clone-set-remote-head: Cloning Repository. (line 68) +* magit-clone-set-remote.pushDefault: Cloning Repository. (line 78) +* magit-clone-url-format: Cloning Repository. (line 124) +* magit-commit-ask-to-stage: Initiating a Commit. (line 75) +* magit-commit-extend-override-date: Initiating a Commit. (line 80) +* magit-commit-reword-override-date: Initiating a Commit. (line 84) +* magit-commit-squash-confirm: Initiating a Commit. (line 88) +* magit-completing-read-function: Support for Completion Frameworks. + (line 27) +* magit-diff-adjust-tab-width: Diff Options. (line 21) +* magit-diff-buffer-file-locked: Minor Mode for Buffers Visiting Files. + (line 91) +* magit-diff-hide-trailing-cr-characters: Diff Options. (line 90) +* magit-diff-highlight-hunk-region-functions: Diff Options. (line 94) +* magit-diff-highlight-indentation: Diff Options. (line 75) +* magit-diff-highlight-trailing: Diff Options. (line 70) +* magit-diff-paint-whitespace: Diff Options. (line 43) +* magit-diff-paint-whitespace-lines: Diff Options. (line 60) +* magit-diff-refine-hunk: Diff Options. (line 6) +* magit-diff-refine-ignore-whitespace: Diff Options. (line 16) +* magit-diff-unmarked-lines-keep-foreground: Diff Options. (line 120) +* magit-diff-visit-previous-blob: Visiting Files and Blobs from a Diff. + (line 39) +* magit-direct-use-buffer-arguments: Transient Arguments and Buffer Variables. + (line 73) +* magit-display-buffer-function: Switching Buffers. (line 27) +* magit-display-buffer-noselect: Switching Buffers. (line 18) +* magit-dwim-selection: Completion and Confirmation. + (line 42) +* magit-ediff-dwim-show-on-hunks: Ediffing. (line 73) +* magit-ediff-quit-hook: Ediffing. (line 88) +* magit-ediff-show-stash-with-index: Ediffing. (line 81) +* magit-file-mode-map: Minor Mode for Buffers Visiting Files. + (line 20) +* magit-generate-buffer-name-function: Naming Buffers. (line 6) +* magit-git-debug: Viewing Git Output. (line 28) +* magit-git-debug <1>: Getting a Value from Git. + (line 64) +* magit-git-executable: Git Executable. (line 39) +* magit-git-global-arguments: Global Git Arguments. + (line 6) +* magit-keep-region-overlay: The Selection. (line 52) +* magit-list-refs-sortby: Additional Completion Options. + (line 6) +* magit-log-auto-more: Log Buffer. (line 69) +* magit-log-buffer-file-locked: Minor Mode for Buffers Visiting Files. + (line 118) +* magit-log-margin: Log Margin. (line 12) +* magit-log-margin-show-committer-date: Log Margin. (line 49) +* magit-log-section-commit-count: Status Sections. (line 136) +* magit-log-select-margin: Select from Log. (line 30) +* magit-log-show-refname-after-summary: Log Buffer. (line 75) +* magit-log-trace-definition-function: Commands Available in Diffs. + (line 18) +* magit-module-sections-hook: Status Module Sections. + (line 20) +* magit-module-sections-nested: Status Module Sections. + (line 24) +* magit-no-confirm: Action Confirmation. (line 18) +* magit-pop-revision-stack-format: Using the Revision Stack. + (line 35) +* magit-post-display-buffer-hook: Switching Buffers. (line 95) +* magit-pre-display-buffer-hook: Switching Buffers. (line 84) +* magit-prefer-remote-upstream: Branch Git Variables. + (line 126) +* magit-prefix-use-buffer-arguments: Transient Arguments and Buffer Variables. + (line 64) +* magit-process-raise-error: Calling Git for Effect. + (line 151) +* magit-pull-or-fetch: Fetching. (line 59) +* magit-reflog-margin: Reflog. (line 23) +* magit-refresh-args: Refreshing Buffers. (line 55) +* magit-refresh-buffer-hook: Automatic Refreshing of Magit Buffers. + (line 42) +* magit-refresh-function: Refreshing Buffers. (line 49) +* magit-refresh-status-buffer: Automatic Refreshing of Magit Buffers. + (line 48) +* magit-refs-filter-alist: References Buffer. (line 159) +* magit-refs-focus-column-width: References Buffer. (line 82) +* magit-refs-margin: References Buffer. (line 97) +* magit-refs-margin-for-tags: References Buffer. (line 125) +* magit-refs-pad-commit-counts: References Buffer. (line 49) +* magit-refs-primary-column-width: References Buffer. (line 69) +* magit-refs-sections-hook: References Sections. (line 13) +* magit-refs-show-commit-count: References Buffer. (line 37) +* magit-refs-show-remote-prefix: References Buffer. (line 62) +* magit-remote-add-set-remote.pushDefault: Remote Commands. (line 92) +* magit-remote-direct-configure: Remote Commands. (line 21) +* magit-repolist-columns: Repository List. (line 14) +* magit-repository-directories: Status Buffer. (line 58) +* magit-revision-filter-files-on-follow: Revision Buffer. (line 64) +* magit-revision-insert-related-refs: Revision Buffer. (line 6) +* magit-revision-show-gravatars: Revision Buffer. (line 19) +* magit-revision-use-hash-sections: Revision Buffer. (line 36) +* magit-root-section: Matching Sections. (line 87) +* magit-save-repository-buffers: Automatic Saving of File-Visiting Buffers. + (line 13) +* magit-section-cache-visibility: Section Visibility. (line 95) +* magit-section-initial-visibility-alist: Section Visibility. (line 78) +* magit-section-movement-hook: Section Movement. (line 46) +* magit-section-set-visibility-hook: Section Visibility. (line 106) +* magit-section-show-child-count: Section Options. (line 9) +* magit-section-visibility-indicator: Section Visibility. (line 124) +* magit-shell-command-verbose-prompt: Running Git Manually. + (line 47) +* magit-stashes-margin: Stashing. (line 104) +* magit-status-headers-hook: Status Header Sections. + (line 18) +* magit-status-margin: Status Options. (line 10) +* magit-status-refresh-hook: Status Options. (line 6) +* magit-status-sections-hook: Status Sections. (line 10) +* magit-submodule-list-columns: Listing Submodules. (line 21) +* magit-this-process: Calling Git for Effect. + (line 146) +* magit-uniquify-buffer-names: Naming Buffers. (line 74) +* magit-unstage-committed: Staging and Unstaging. + (line 56) +* magit-update-other-window-delay: Section Movement. (line 112) +* magit-visit-ref-behavior: References Buffer. (line 192) +* magit-wip-after-apply-mode: Legacy Wip Modes. (line 19) +* magit-wip-after-apply-mode-lighter: Legacy Wip Modes. (line 59) +* magit-wip-after-save-local-mode-lighter: Legacy Wip Modes. (line 55) +* magit-wip-after-save-mode: Legacy Wip Modes. (line 13) +* magit-wip-before-change-mode: Legacy Wip Modes. (line 33) +* magit-wip-before-change-mode-lighter: Legacy Wip Modes. (line 63) +* magit-wip-initial-backup-mode: Legacy Wip Modes. (line 38) +* magit-wip-initial-backup-mode-lighter: Legacy Wip Modes. (line 67) +* magit-wip-merge-branch: Wip Graph. (line 6) +* magit-wip-mode: Wip Modes. (line 30) +* magit-wip-mode-lighter: Wip Modes. (line 104) +* magit-wip-namespace: Wip Modes. (line 96) +* notes.displayRef: Notes. (line 65) +* pull.rebase: Branch Git Variables. + (line 57) +* remote.NAME.fetch: Remote Git Variables. + (line 15) +* remote.NAME.push: Remote Git Variables. + (line 26) +* remote.NAME.pushurl: Remote Git Variables. + (line 20) +* remote.NAME.tagOpts: Remote Git Variables. + (line 31) +* remote.NAME.url: Remote Git Variables. + (line 10) +* remote.pushDefault: Branch Git Variables. + (line 71) + diff --git a/elpa/olivetti-20200320.1154/olivetti-autoloads.el b/elpa/olivetti-20200320.1154/olivetti-autoloads.el new file mode 100644 index 00000000..afadcee7 --- /dev/null +++ b/elpa/olivetti-20200320.1154/olivetti-autoloads.el @@ -0,0 +1,15 @@ +;;; olivetti-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; olivetti-autoloads.el ends here diff --git a/elpa/olivetti-20200320.1154/olivetti-pkg.el b/elpa/olivetti-20200320.1154/olivetti-pkg.el new file mode 100644 index 00000000..d754a189 --- /dev/null +++ b/elpa/olivetti-20200320.1154/olivetti-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "olivetti" "20200320.1154" "Minor mode for a nice writing environment" '((emacs "24.5")) :commit "5dc27716c706166e1932f4a0e9f94384b6d17cb0" :keywords '("wp" "text") :authors '(("William Rankin" . "code@william.bydasein.com")) :maintainer '("William Rankin" . "code@william.bydasein.com") :url "https://gthub.com/rnkn/olivetti") diff --git a/elpa/olivetti-20200320.1154/olivetti.el b/elpa/olivetti-20200320.1154/olivetti.el new file mode 100644 index 00000000..e69de29b diff --git a/elpa/olivetti-20200320.1154/olivetti.elc b/elpa/olivetti-20200320.1154/olivetti.elc new file mode 100644 index 00000000..9f0970a6 Binary files /dev/null and b/elpa/olivetti-20200320.1154/olivetti.elc differ diff --git a/elpa/slime-20200319.1939/contrib/README.md b/elpa/slime-20200319.1939/contrib/README.md new file mode 100644 index 00000000..94fd02fe --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/README.md @@ -0,0 +1,14 @@ +This directory contains source code which may be useful to some Slime +users. `*.el` files are Emacs Lisp source and `*.lisp` files contain +Common Lisp source code. If not otherwise stated in the file itself, +the files are placed in the Public Domain. + +The components in this directory are more or less detached from the +rest of Slime. They are essentially "add-ons". But Slime can also be +used without them. The code is maintained by the respective authors. + +See the top level README.md for how to use packages in this directory. + +Finally, the contrib `slime-fancy` is specially noteworthy, as it +represents a meta-contrib that'll load a bunch of commonly used +contribs. Look into `slime-fancy.el` to find out which. diff --git a/elpa/slime-20200319.1939/contrib/bridge.el b/elpa/slime-20200319.1939/contrib/bridge.el new file mode 100644 index 00000000..5bf87797 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/bridge.el @@ -0,0 +1,472 @@ +;;; -*-Emacs-Lisp-*- +;;;%Header +;;; Bridge process filter, V1.0 +;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu +;;; +;;; Send mail to ilisp@cons.org if you have problems. +;;; +;;; Send mail to majordomo@cons.org if you want to be on the +;;; ilisp mailing list. + +;;; This file is part of GNU Emacs. + +;;; GNU Emacs is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY. No author or distributor +;;; accepts responsibility to anyone for the consequences of using it +;;; or for whether it serves any particular purpose or works at all, +;;; unless he says so in writing. Refer to the GNU Emacs General Public +;;; License for full details. + +;;; Everyone is granted permission to copy, modify and redistribute +;;; GNU Emacs, but only under the conditions described in the +;;; GNU Emacs General Public License. A copy of this license is +;;; supposed to have been given to you along with GNU Emacs so you +;;; can know your rights and responsibilities. It should be in a +;;; file named COPYING. Among other things, the copyright notice +;;; and this notice must be preserved on all copies. + +;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting +;;; the process filter for continuous handlers. + +;;; USAGE: M-x install-bridge will add a process output filter to the +;;; current buffer. Any output that the process does between +;;; bridge-start-regexp and bridge-end-regexp will be bundled up and +;;; passed to the first handler on bridge-handlers that matches the +;;; output using string-match. If bridge-prompt-regexp shows up +;;; before bridge-end-regexp, the bridge will be cancelled. If no +;;; handler matches the output, the first symbol in the output is +;;; assumed to be a buffer name and the rest of the output will be +;;; sent to that buffer's process. This can be used to communicate +;;; between processes or to set up two way interactions between Emacs +;;; and an inferior process. + +;;; You can write handlers that process the output in special ways. +;;; See bridge-send-handler for the default handler. The command +;;; hand-bridge is useful for testing. Keep in mind that all +;;; variables are buffer local. + +;;; YOUR .EMACS FILE: +;;; +;;; ;;; Set up load path to include bridge +;;; (setq load-path (cons "/bridge-directory/" load-path)) +;;; (autoload 'install-bridge "bridge" "Install a process bridge." t) +;;; (setq bridge-hook +;;; '(lambda () +;;; ;; Example options +;;; (setq bridge-source-insert nil) ;Don't insert in source buffer +;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer +;;; ;; Handle copy-it messages yourself +;;; (setq bridge-handlers +;;; '(("copy-it" . my-copy-handler))))) + +;;; EXAMPLE: +;;; # This pipes stdin to the named buffer in a Unix shell +;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")' +;;; +;;; ls | devgnu *scratch* + +(eval-when-compile + (require 'cl)) + +;;;%Parameters +(defvar bridge-hook nil + "Hook called when a bridge is installed by install-hook.") + +(defvar bridge-start-regexp "" + "*Regular expression to match the start of a process bridge in +process output. It should be followed by a buffer name, the data to +be sent and a bridge-end-regexp.") + +(defvar bridge-end-regexp "" + "*Regular expression to match the end of a process bridge in process +output.") + +(defvar bridge-prompt-regexp nil + "*Regular expression for detecting a prompt. If there is a +comint-prompt-regexp, it will be initialized to that. A prompt before +a bridge-end-regexp will stop the process bridge.") + +(defvar bridge-handlers nil + "Alist of (regexp . handler) for handling process output delimited +by bridge-start-regexp and bridge-end-regexp. The first entry on the +list whose regexp matches the output will be called on the process and +the delimited output.") + +(defvar bridge-source-insert t + "*T to insert bridge input in the source buffer minus delimiters.") + +(defvar bridge-destination-insert t + "*T for bridge-send-handler to insert bridge input into the +destination buffer minus delimiters.") + +(defvar bridge-chunk-size 512 + "*Long inputs send to comint processes are broken up into chunks of +this size. If your process is choking on big inputs, try lowering the +value.") + +;;;%Internal variables +(defvar bridge-old-filter nil + "Old filter for a bridged process buffer.") + +(defvar bridge-string nil + "The current output in the process bridge.") + +(defvar bridge-in-progress nil + "The current handler function, if any, that bridge passes strings on to, +or nil if none.") + +(defvar bridge-leftovers nil + "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.") + +(defvar bridge-send-to-buffer nil + "The buffer that the default bridge-handler (bridge-send-handler) is +currently sending to, or nil if it hasn't started yet. Your handler +function can use this variable also.") + +(defvar bridge-last-failure () + "Last thing that broke the bridge handler. First item is function call +(eval'able); last item is error condition which resulted. This is provided +to help handler-writers in their debugging.") + +(defvar bridge-insert-function nil + "If non-nil use this instead of `bridge-insert'") + +;;;%Utilities +(defun bridge-insert (output &optional _dummy) + "Insert process OUTPUT into the current buffer." + (if bridge-insert-function + (funcall bridge-insert-function output) + (if output + (let* ((buffer (current-buffer)) + (process (get-buffer-process buffer)) + (mark (process-mark process)) + (window (selected-window)) + (at-end nil)) + (if (eq (window-buffer window) buffer) + (setq at-end (= (point) mark)) + (setq window (get-buffer-window buffer))) + (save-excursion + (goto-char mark) + (insert output) + (set-marker mark (point))) + (if window + (progn + (if at-end (goto-char mark)) + (if (not (pos-visible-in-window-p (point) window)) + (let ((original (selected-window))) + (save-excursion + (select-window window) + (recenter '(center)) + (select-window original)))))))))) + +;;; +;(defun bridge-send-string (process string) +; "Send PROCESS the contents of STRING as input. +;This is equivalent to process-send-string, except that long input strings +;are broken up into chunks of size comint-input-chunk-size. Processes +;are given a chance to output between chunks. This can help prevent processes +;from hanging when you send them long inputs on some OS's." +; (let* ((len (length string)) +; (i (min len bridge-chunk-size))) +; (process-send-string process (substring string 0 i)) +; (while (< i len) +; (let ((next-i (+ i bridge-chunk-size))) +; (accept-process-output) +; (process-send-string process (substring string i (min len next-i))) +; (setq i next-i))))) + +;;; +(defun bridge-call-handler (handler proc string) + "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens, +and user is signaled. State is put in bridge-last-failure. Returns t if +handler executed without error." + (let ((inhibit-quit nil) + (failed nil)) + (condition-case err + (funcall handler proc string) + (error + (ding) + (setq failed t) + (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)" + handler err) + (setq bridge-last-failure + `((funcall ',handler ',proc ,string) + "Caused: " + ,err)))) + (not failed))) + +;;;%Handlers +(defun bridge-send-handler (process input) + "Send PROCESS INPUT to the buffer name found at the start of the +input. The input after the buffer name is sent to the buffer's +process if it has one. If bridge-destination-insert is T, the input +will be inserted into the buffer. If it does not have a process, it +will be inserted at the end of the buffer." + (if (null input) + (setq bridge-send-to-buffer nil) ; end of bridge + (let (buffer-and-start buffer-name dest to) + ;; if this is first time, get the buffer out of the first line + (cond ((not bridge-send-to-buffer) + (setq buffer-and-start (read-from-string input) + buffer-name (format "%s" (car (read-from-string input))) + dest (get-buffer buffer-name) + to (get-buffer-process dest) + input (substring input (cdr buffer-and-start))) + (setq bridge-send-to-buffer dest)) + (t + (setq buffer-name bridge-send-to-buffer + dest (get-buffer buffer-name) + to (get-buffer-process dest) + ))) + (if dest + (let ((buffer (current-buffer))) + (if bridge-destination-insert + (unwind-protect + (progn + (set-buffer dest) + (if to + (bridge-insert process input) + (goto-char (point-max)) + (insert input))) + (set-buffer buffer))) + (if to + ;; (bridge-send-string to input) + (process-send-string to input) + )) + (error "%s is not a buffer" buffer-name))))) + +;;;%Filter +(defun bridge-filter (process output) + "Given PROCESS and some OUTPUT, check for the presence of +bridge-start-regexp. Everything prior to this will be passed to the +normal filter function or inserted in the buffer if it is nil. The +output up to bridge-end-regexp will be sent to the first handler on +bridge-handlers that matches the string. If no handlers match, the +input will be sent to bridge-send-handler. If bridge-prompt-regexp is +encountered before the bridge-end-regexp, the bridge will be cancelled." + (let ((inhibit-quit t) + (match-data (match-data)) + (buffer (current-buffer)) + (process-buffer (process-buffer process)) + (case-fold-search t) + (start 0) (end 0) + function + b-start b-start-end b-end) + (set-buffer process-buffer) ;; access locals + + ;; Handle bridge messages that straddle a packet by prepending + ;; them to this packet. + + (when bridge-leftovers + (setq output (concat bridge-leftovers output)) + (setq bridge-leftovers nil)) + + (setq function bridge-in-progress) + + ;; How it works: + ;; + ;; start, end delimit the part of string we are interested in; + ;; initially both 0; after an iteration we move them to next string. + + ;; b-start, b-end delimit part of string to bridge (possibly whole string); + ;; this will be string between corresponding regexps. + + ;; There are two main cases when we come into loop: + + ;; bridge in progress + ;;0 setq b-start = start + ;;1 setq b-end (or end-pattern end) + ;;4 process string + ;;5 remove handler if end found + + ;; no bridge in progress + ;;0 setq b-start if see start-pattern + ;;1 setq b-end if bstart to (or end-pattern end) + ;;2 send (substring start b-start) to normal place + ;;3 find handler (in b-start, b-end) if not set + ;;4 process string + ;;5 remove handler if end found + + ;; equivalent sections have the same numbers here; + ;; we fold them together in this code. + + (block bridge-filter + (unwind-protect + (while (< end (length output)) + + ;;0 setq b-start if find + (setq b-start + (cond (bridge-in-progress + (setq b-start-end start) + start) + ((string-match bridge-start-regexp output start) + (setq b-start-end (match-end 0)) + (match-beginning 0)) + (t nil))) + ;;1 setq b-end + (setq b-end + (if b-start + (let ((end-seen (string-match bridge-end-regexp + output b-start-end))) + (if end-seen (setq end (match-end 0))) + + end-seen))) + + ;; Detect and save partial bridge messages + (when (and b-start b-start-end (not b-end)) + (setq bridge-leftovers (substring output b-start)) + ) + + (if (and b-start (not b-end)) + (setq end b-start) + (if (not b-end) + (setq end (length output)))) + + ;;1.5 - if see prompt before end, remove current + (if (and b-start b-end) + (let ((prompt (string-match bridge-prompt-regexp + output b-start-end))) + (if (and prompt (<= (match-end 0) b-end)) + (setq b-start nil ; b-start-end start + b-end start + end (match-end 0) + bridge-in-progress nil + )))) + + ;;2 send (substring start b-start) to old filter, if any + (when (not (equal start (or b-start end))) ; don't bother on empty string + (let ((pass-on (substring output start (or b-start end)))) + (if bridge-old-filter + (let ((old bridge-old-filter)) + (store-match-data match-data) + (funcall old process pass-on) + ;; if filter changed, re-install ourselves + (let ((new (process-filter process))) + (if (not (eq new 'bridge-filter)) + (progn (setq bridge-old-filter new) + (set-process-filter process 'bridge-filter))))) + (set-buffer process-buffer) + (bridge-insert pass-on)))) + + (if (and b-start-end (not b-end)) + (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early. + (progn + ;;3 find handler (in b-start, b-end) if none current + (if (and b-start (not bridge-in-progress)) + (let ((handlers bridge-handlers)) + (while (and handlers (not function)) + (let* ((handler (car handlers)) + (m (string-match (car handler) output b-start-end))) + (if (and m (< m b-end)) + (setq function (cdr handler)) + (setq handlers (cdr handlers))))) + ;; Set default handler if none + (if (null function) + (setq function 'bridge-send-handler)) + (setq bridge-in-progress function))) + ;;4 process strin + (if function + (let ((ok t)) + (if (/= b-start-end b-end) + (let ((send (substring output b-start-end b-end))) + ;; also, insert the stuff in buffer between + ;; iff bridge-source-insert. + (if bridge-source-insert (bridge-insert send)) + ;; call handler on string + (setq ok (bridge-call-handler function process send)))) + ;;5 remove handler if end found + ;; if function removed then tell it that's all + (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string + (progn + (bridge-call-handler function process nil) + ;; have to remove function too for next time around + (setq function nil + bridge-in-progress nil) + )) + )) + + ;; continue looping, in case there's more string + (setq start end)) + )) + ;; protected forms: restore buffer, match-data + (set-buffer buffer) + (store-match-data match-data) + )))) + + +;;;%Interface +(defun install-bridge () + "Set up a process bridge in the current buffer." + (interactive) + (if (not (get-buffer-process (current-buffer))) + (error "%s does not have a process" (buffer-name (current-buffer))) + (make-local-variable 'bridge-start-regexp) + (make-local-variable 'bridge-end-regexp) + (make-local-variable 'bridge-prompt-regexp) + (make-local-variable 'bridge-handlers) + (make-local-variable 'bridge-source-insert) + (make-local-variable 'bridge-destination-insert) + (make-local-variable 'bridge-chunk-size) + (make-local-variable 'bridge-old-filter) + (make-local-variable 'bridge-string) + (make-local-variable 'bridge-in-progress) + (make-local-variable 'bridge-send-to-buffer) + (make-local-variable 'bridge-leftovers) + (setq bridge-string nil bridge-in-progress nil + bridge-send-to-buffer nil) + (if (boundp 'comint-prompt-regexp) + (setq bridge-prompt-regexp comint-prompt-regexp)) + (let ((process (get-buffer-process (current-buffer)))) + (if process + (if (not (eq (process-filter process) 'bridge-filter)) + (progn + (setq bridge-old-filter (process-filter process)) + (set-process-filter process 'bridge-filter))) + (error "%s does not have a process" + (buffer-name (current-buffer))))) + (run-hooks 'bridge-hook) + (message "Process bridge is installed"))) + +;;; +(defun reset-bridge () + "Must be called from the process's buffer. Removes any active bridge." + (interactive) + ;; for when things get wedged + (if bridge-in-progress + (unwind-protect + (funcall bridge-in-progress (get-buffer-process + (current-buffer)) + nil) + (setq bridge-in-progress nil)) + (message "No bridge in progress."))) + +;;; +(defun remove-bridge () + "Remove bridge from the current buffer." + (interactive) + (let ((process (get-buffer-process (current-buffer)))) + (if (or (not process) (not (eq (process-filter process) 'bridge-filter))) + (error "%s has no bridge" (buffer-name (current-buffer))) + ;; remove any bridge-in-progress + (reset-bridge) + (set-process-filter process bridge-old-filter) + (funcall bridge-old-filter process bridge-string) + (message "Process bridge is removed.")))) + +;;;% Utility for testing +(defun hand-bridge (start end) + "With point at bridge-start, sends bridge-start + string + +bridge-end to bridge-filter. With prefix, use current region to send." + (interactive "r") + (let ((p0 (if current-prefix-arg (min start end) + (if (looking-at bridge-start-regexp) (point) + (error "Not looking at bridge-start-regexp")))) + (p1 (if current-prefix-arg (max start end) + (if (re-search-forward bridge-end-regexp nil t) + (point) (error "Didn't see bridge-end-regexp"))))) + + (bridge-filter (get-buffer-process (current-buffer)) + (buffer-substring-no-properties p0 p1)) + )) + +(provide 'bridge) diff --git a/elpa/slime-20200319.1939/contrib/bridge.elc b/elpa/slime-20200319.1939/contrib/bridge.elc new file mode 100644 index 00000000..5287fa84 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/bridge.elc differ diff --git a/elpa/slime-20200319.1939/contrib/inferior-slime.el b/elpa/slime-20200319.1939/contrib/inferior-slime.el new file mode 100644 index 00000000..b176098b --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/inferior-slime.el @@ -0,0 +1,133 @@ +;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers +;; +;; Author: Luke Gorrie +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime))) +;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1))) +(require 'slime) +(require 'cl-lib) + +(define-minor-mode inferior-slime-mode + "\\\ +Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. + +This mode is intended for use with `inferior-lisp-mode'. It provides a +subset of the bindings from `slime-mode'. + +\\{inferior-slime-mode-map}" + :keymap + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined)) + + (slime-setup-completion) + (setq-local tab-always-indent 'complete)) + +(defun inferior-slime-return () + "Handle the return key in the inferior-lisp buffer. +The current input should only be sent if a whole expression has been +entered, i.e. the parenthesis are matched. + +A prefix argument disables this behaviour." + (interactive) + (if (or current-prefix-arg (inferior-slime-input-complete-p)) + (comint-send-input) + (insert "\n") + (inferior-slime-indent-line))) + +(defun inferior-slime-indent-line () + "Indent the current line, ignoring everything before the prompt." + (interactive) + (save-restriction + (let ((indent-start + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((inhibit-field-text-motion t)) + (beginning-of-line 1)) + (point)))) + (narrow-to-region indent-start (point-max))) + (lisp-indent-line))) + +(defun inferior-slime-input-complete-p () + "Return true if the input is complete in the inferior lisp buffer." + (slime-input-complete-p (process-mark (get-buffer-process (current-buffer))) + (point-max))) + +(defun inferior-slime-closing-return () + "Send the current expression to Lisp after closing any open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (process-mark (get-buffer-process (current-buffer))) + (point-max)) + (while (ignore-errors (save-excursion (backward-up-list 1) t)) + (insert ")"))) + (comint-send-input)) + +(defun inferior-slime-change-directory (directory) + "Set default-directory in the *inferior-lisp* buffer to DIRECTORY." + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when buffer + (with-current-buffer buffer + (cd-absolute directory))))) + +(defun inferior-slime-init-keymap () + (let ((map inferior-slime-mode-map)) + (set-keymap-parent map slime-parent-map) + (slime-define-keys map + ([return] 'inferior-slime-return) + ([(control return)] 'inferior-slime-closing-return) + ([(meta control ?m)] 'inferior-slime-closing-return) + ;;("\t" 'slime-indent-and-complete-symbol) + (" " 'slime-space)))) + +(inferior-slime-init-keymap) + +(defun inferior-slime-hook-function () + (inferior-slime-mode 1)) + +(defun inferior-slime-switch-to-repl-buffer () + (switch-to-buffer (process-buffer (slime-inferior-process)))) + +(defun inferior-slime-show-transcript (string) + (remove-hook 'comint-output-filter-functions + 'inferior-slime-show-transcript t) + (with-current-buffer (process-buffer (slime-inferior-process)) + (let ((window (display-buffer (current-buffer) t))) + (set-window-point window (point-max))))) + +(defun inferior-slime-start-transcript () + (let ((proc (slime-inferior-process))) + (when proc + (with-current-buffer (process-buffer proc) + (add-hook 'comint-output-filter-functions + 'inferior-slime-show-transcript + nil t))))) + +(defun inferior-slime-stop-transcript () + (let ((proc (slime-inferior-process))) + (when proc + (with-current-buffer (process-buffer (slime-inferior-process)) + (run-with-timer 0.2 nil + (lambda (buffer) + (with-current-buffer buffer + (remove-hook 'comint-output-filter-functions + 'inferior-slime-show-transcript t))) + (current-buffer)))))) + +(defun inferior-slime-init () + (add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function) + (add-hook 'slime-change-directory-hooks 'inferior-slime-change-directory) + (add-hook 'slime-transcript-start-hook 'inferior-slime-start-transcript) + (add-hook 'slime-transcript-stop-hook 'inferior-slime-stop-transcript) + (def-slime-selector-method ?r + "SLIME Read-Eval-Print-Loop." + (process-buffer (slime-inferior-process)))) + +(provide 'inferior-slime) diff --git a/elpa/slime-20200319.1939/contrib/inferior-slime.elc b/elpa/slime-20200319.1939/contrib/inferior-slime.elc new file mode 100644 index 00000000..12d3b458 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/inferior-slime.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-asdf.el b/elpa/slime-20200319.1939/contrib/slime-asdf.el new file mode 100644 index 00000000..fa4b176e --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-asdf.el @@ -0,0 +1,313 @@ +(require 'slime) +(require 'cl-lib) +(require 'grep) + +(define-slime-contrib slime-asdf + "ASDF support." + (:authors "Daniel Barlow " + "Marco Baringer " + "Edi Weitz " + "Stas Boukarev " + "Tobias C Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-asdf) + (:on-load + (add-to-list 'slime-edit-uses-xrefs :depends-on t) + (define-key slime-who-map [?d] 'slime-who-depends-on))) + +;;; NOTE: `system-name' is a predefined variable in Emacs. Try to +;;; avoid it as local variable name. + +;;; Utilities + +(defgroup slime-asdf nil + "ASDF support for Slime." + :prefix "slime-asdf-" + :group 'slime) + +(defvar slime-system-history nil + "History list for ASDF system names.") + +(defun slime-read-system-name (&optional prompt + default-value + determine-default-accurately) + "Read a system name from the minibuffer, prompting with PROMPT. +If no `default-value' is given, one is tried to be determined: if +`determine-default-accurately' is true, by an RPC request which +grovels through all defined systems; if it's not true, by looking +in the directory of the current buffer." + (let* ((completion-ignore-case nil) + (prompt (or prompt "System")) + (system-names (slime-eval `(swank:list-asdf-systems))) + (default-value + (or default-value + (if determine-default-accurately + (slime-determine-asdf-system (buffer-file-name) + (slime-current-package)) + (slime-find-asd-file (or default-directory + (buffer-file-name)) + system-names)))) + (prompt (concat prompt (if default-value + (format " (default `%s'): " default-value) + ": ")))) + (completing-read prompt (slime-bogus-completion-alist system-names) + nil nil nil + 'slime-system-history default-value))) + + + +(defun slime-find-asd-file (directory system-names) + "Tries to find an ASDF system definition file in the +`directory' and returns it if it's in `system-names'." + (let ((asd-files + (directory-files (file-name-directory directory) nil "\.asd$"))) + (cl-loop for system in asd-files + for candidate = (file-name-sans-extension system) + when (cl-find candidate system-names :test #'string-equal) + do (cl-return candidate)))) + +(defun slime-determine-asdf-system (filename buffer-package) + "Try to determine the asdf system that `filename' belongs to." + (slime-eval + `(swank:asdf-determine-system ,(and filename + (slime-to-lisp-filename filename)) + ,buffer-package))) + +(defun slime-who-depends-on-rpc (system) + (slime-eval `(swank:who-depends-on ,system))) + +(defcustom slime-asdf-collect-notes t + "Collect and display notes produced by the compiler. + +See also `slime-highlight-compiler-notes' and +`slime-compilation-finished-hook'." + :group 'slime-asdf) + +(defun slime-asdf-operation-finished-function (system) + (if slime-asdf-collect-notes + #'slime-compilation-finished + (slime-curry (lambda (system result) + (let (slime-highlight-compiler-notes + slime-compilation-finished-hook) + (slime-compilation-finished result))) + system))) + +(defun slime-oos (system operation &rest keyword-args) + "Operate On System." + (slime-save-some-lisp-buffers) + (slime-display-output-buffer) + (message "Performing ASDF %S%s on system %S" + operation (if keyword-args (format " %S" keyword-args) "") + system) + (slime-repl-shortcut-eval-async + `(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args) + (slime-asdf-operation-finished-function system))) + + +;;; Interactive functions + +(defun slime-load-system (&optional system) + "Compile and load an ASDF system. + +Default system name is taken from first file matching *.asd in current +buffer's working directory" + (interactive (list (slime-read-system-name))) + (slime-oos system 'load-op)) + +(defun slime-open-system (name &optional load interactive) + "Open all files in an ASDF system." + (interactive (list (slime-read-system-name) nil t)) + (when (or load + (and interactive + (not (slime-eval `(swank:asdf-system-loaded-p ,name))) + (y-or-n-p "Load it? "))) + (slime-load-system name)) + (slime-eval-async + `(swank:asdf-system-files ,name) + (lambda (files) + (when files + (let ((files (mapcar 'slime-from-lisp-filename + (nreverse files)))) + (find-file-other-window (car files)) + (mapc 'find-file (cdr files))))))) + +(defun slime-browse-system (name) + "Browse files in an ASDF system using Dired." + (interactive (list (slime-read-system-name))) + (slime-eval-async `(swank:asdf-system-directory ,name) + (lambda (directory) + (when directory + (dired (slime-from-lisp-filename directory)))))) + +(if (fboundp 'rgrep) + (defun slime-rgrep-system (sys-name regexp) + "Run `rgrep' on the base directory of an ASDF system." + (interactive (progn (grep-compute-defaults) + (list (slime-read-system-name nil nil t) + (grep-read-regexp)))) + (rgrep regexp "*.lisp" + (slime-from-lisp-filename + (slime-eval `(swank:asdf-system-directory ,sys-name))))) + (defun slime-rgrep-system () + (interactive) + (error "This command is only supported on GNU Emacs >21.x."))) + +(if (boundp 'multi-isearch-next-buffer-function) + (defun slime-isearch-system (sys-name) + "Run `isearch-forward' on the files of an ASDF system." + (interactive (list (slime-read-system-name nil nil t))) + (let* ((files (mapcar 'slime-from-lisp-filename + (slime-eval `(swank:asdf-system-files ,sys-name)))) + (multi-isearch-next-buffer-function + (lexical-let* + ((buffers-forward (mapcar #'find-file-noselect files)) + (buffers-backward (reverse buffers-forward))) + #'(lambda (current-buffer wrap) + ;; Contrarily to the docstring of + ;; `multi-isearch-next-buffer-function', the first + ;; arg is not necessarily a buffer. Report sent + ;; upstream. (2009-11-17) + (setq current-buffer (or current-buffer (current-buffer))) + (let* ((buffers (if isearch-forward + buffers-forward + buffers-backward))) + (if wrap + (car buffers) + (second (memq current-buffer buffers)))))))) + (isearch-forward))) + (defun slime-isearch-system () + (interactive) + (error "This command is only supported on GNU Emacs >23.1.x."))) + +(defun slime-read-query-replace-args (format-string &rest format-args) + (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook)) + (minibuffer-local-map slime-minibuffer-map) + (common (query-replace-read-args (apply #'format format-string + format-args) + t t))) + (list (nth 0 common) (nth 1 common) (nth 2 common)))) + +(defun slime-query-replace-system (name from to &optional delimited) + "Run `query-replace' on an ASDF system." + (interactive (let ((system (slime-read-system-name nil nil t))) + (cons system (slime-read-query-replace-args + "Query replace throughout `%s'" system)))) + (condition-case c + ;; `tags-query-replace' actually uses `query-replace-regexp' + ;; internally. + (tags-query-replace (regexp-quote from) to delimited + '(mapcar 'slime-from-lisp-filename + (slime-eval `(swank:asdf-system-files ,name)))) + (error + ;; Kludge: `tags-query-replace' does not actually return but + ;; signals an unnamed error with the below error + ;; message. (<=23.1.2, at least.) + (unless (string-equal (error-message-string c) "All files processed") + (signal (car c) (cdr c))) ; resignal + t))) + +(defun slime-query-replace-system-and-dependents + (name from to &optional delimited) + "Run `query-replace' on an ASDF system and all the systems +depending on it." + (interactive (let ((system (slime-read-system-name nil nil t))) + (cons system (slime-read-query-replace-args + "Query replace throughout `%s'+dependencies" + system)))) + (slime-query-replace-system name from to delimited) + (dolist (dep (slime-who-depends-on-rpc name)) + (when (y-or-n-p (format "Descend into system `%s'? " dep)) + (slime-query-replace-system dep from to delimited)))) + +(defun slime-delete-system-fasls (name) + "Delete FASLs produced by compiling a system." + (interactive (list (slime-read-system-name))) + (slime-repl-shortcut-eval-async + `(swank:delete-system-fasls ,name) + 'message)) + +(defun slime-reload-system (system) + "Reload an ASDF system without reloading its dependencies." + (interactive (list (slime-read-system-name))) + (slime-save-some-lisp-buffers) + (slime-display-output-buffer) + (message "Performing ASDF LOAD-OP on system %S" system) + (slime-repl-shortcut-eval-async + `(swank:reload-system ,system) + (slime-asdf-operation-finished-function system))) + +(defun slime-who-depends-on (system-name) + (interactive (list (slime-read-system-name))) + (slime-xref :depends-on system-name)) + +(defun slime-save-system (system) + "Save files belonging to an ASDF system." + (interactive (list (slime-read-system-name))) + (slime-eval-async + `(swank:asdf-system-files ,system) + (lambda (files) + (dolist (file files) + (let ((buffer (get-file-buffer (slime-from-lisp-filename file)))) + (when buffer + (with-current-buffer buffer + (save-buffer buffer))))) + (message "Done.")))) + + +;;; REPL shortcuts + +(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'load-op :force t))) + (:one-liner "Recompile and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-load-system ("load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'load-op))) + (:one-liner "Compile (as needed) and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'test-op :force t))) + (:one-liner "Recompile and test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test-system ("test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'test-op))) + (:one-liner "Compile (as needed) and test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile-system ("compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'compile-op))) + (:one-liner "Compile (but not load) an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile/force-system + ("force-compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) 'compile-op :force t))) + (:one-liner "Recompile (but not completely load) an ASDF system.")) + +(defslime-repl-shortcut slime-repl-open-system ("open-system") + (:handler 'slime-open-system) + (:one-liner "Open all files in an ASDF system.")) + +(defslime-repl-shortcut slime-repl-browse-system ("browse-system") + (:handler 'slime-browse-system) + (:one-liner "Browse files in an ASDF system using Dired.")) + +(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls") + (:handler 'slime-delete-system-fasls) + (:one-liner "Delete FASLs of an ASDF system.")) + +(defslime-repl-shortcut slime-repl-reload-system ("reload-system") + (:handler 'slime-reload-system) + (:one-liner "Recompile and load an ASDF system.")) + +(provide 'slime-asdf) diff --git a/elpa/slime-20200319.1939/contrib/slime-asdf.elc b/elpa/slime-20200319.1939/contrib/slime-asdf.elc new file mode 100644 index 00000000..7ceb57c2 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-asdf.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-autodoc.el b/elpa/slime-20200319.1939/contrib/slime-autodoc.el new file mode 100644 index 00000000..3463b47f --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-autodoc.el @@ -0,0 +1,219 @@ +(require 'slime) +(require 'eldoc) +(require 'cl-lib) +(require 'slime-parse) + +(define-slime-contrib slime-autodoc + "Show fancy arglist in echo area." + (:license "GPL") + (:authors "Luke Gorrie " + "Lawrence Mitchell " + "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:slime-dependencies slime-parse) + (:swank-dependencies swank-arglists) + (:on-load (slime-autodoc--enable)) + (:on-unload (slime-autodoc--disable))) + +(defcustom slime-autodoc-accuracy-depth 10 + "Number of paren levels that autodoc takes into account for + context-sensitive arglist display (local functions. etc)" + :type 'integer + :group 'slime-ui) + +;;;###autoload +(defcustom slime-autodoc-mode-string (purecopy " adoc") + "String to display in mode line when Autodoc Mode is enabled; nil for none." + :type '(choice string (const :tag "None" nil)) + :group 'slime-ui) + + + +(defun slime-arglist (name) + "Show the argument list for NAME." + (interactive (list (slime-read-symbol-name "Arglist of: " t))) + (let ((arglist (slime-retrieve-arglist name))) + (if (eq arglist :not-available) + (error "Arglist not available") + (message "%s" (slime-autodoc--fontify arglist))))) + +;; used also in slime-c-p-c.el. +(defun slime-retrieve-arglist (name) + (let ((name (cl-etypecase name + (string name) + (symbol (symbol-name name))))) + (car (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker)))))) + +(defun slime-autodoc-manually () + "Like autodoc informtion forcing multiline display." + (interactive) + (let ((doc (slime-autodoc t))) + (cond (doc (eldoc-message doc)) + (t (eldoc-message nil))))) + +;; Must call eldoc-add-command otherwise (eldoc-display-message-p) +;; returns nil and eldoc clears the echo area instead. +(eldoc-add-command 'slime-autodoc-manually) + +(defun slime-autodoc-space (n) + "Like `slime-space' but nicer." + (interactive "p") + (self-insert-command n) + (let ((doc (slime-autodoc))) + (when doc + (eldoc-message doc)))) + +(eldoc-add-command 'slime-autodoc-space) + + +;;;; Autodoc cache + +(defvar slime-autodoc--cache-last-context nil) +(defvar slime-autodoc--cache-last-autodoc nil) + +(defun slime-autodoc--cache-get (context) + "Return the cached autodoc documentation for `context', or nil." + (and (equal context slime-autodoc--cache-last-context) + slime-autodoc--cache-last-autodoc)) + +(defun slime-autodoc--cache-put (context autodoc) + "Update the autodoc cache for CONTEXT with AUTODOC." + (setq slime-autodoc--cache-last-context context) + (setq slime-autodoc--cache-last-autodoc autodoc)) + + +;;;; Formatting autodoc + +(defsubst slime-autodoc--canonicalize-whitespace (string) + (replace-regexp-in-string "[ \n\t]+" " " string)) + +(defun slime-autodoc--format (doc multilinep) + (let ((doc (slime-autodoc--fontify doc))) + (cond (multilinep doc) + (t (slime-oneliner (slime-autodoc--canonicalize-whitespace doc)))))) + +(defun slime-autodoc--fontify (string) + "Fontify STRING as `font-lock-mode' does in Lisp mode." + (with-current-buffer (get-buffer-create (slime-buffer-name :fontify 'hidden)) + (erase-buffer) + (unless (eq major-mode 'lisp-mode) + ;; Just calling (lisp-mode) will turn slime-mode on in that buffer, + ;; which may interfere with this function + (setq major-mode 'lisp-mode) + (lisp-mode-variables t)) + (insert string) + (let ((font-lock-verbose nil)) + (font-lock-fontify-buffer)) + (goto-char (point-min)) + (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) + (let ((highlight (match-string 1))) + ;; Can't use (replace-match highlight) here -- broken in Emacs 21 + (delete-region (match-beginning 0) (match-end 0)) + (slime-insert-propertized '(face eldoc-highlight-function-argument) highlight))) + (buffer-substring (point-min) (point-max)))) + +(define-obsolete-function-alias 'slime-fontify-string + 'slime-autodoc--fontify + "SLIME 2.10") + + +;;;; Autodocs (automatic context-sensitive help) + +(defun slime-autodoc (&optional force-multiline) + "Returns the cached arglist information as string, or nil. +If it's not in the cache, the cache will be updated asynchronously." + (save-excursion + (save-match-data + (let ((context (slime-autodoc--parse-context))) + (when context + (let* ((cached (slime-autodoc--cache-get context)) + (multilinep (or force-multiline + eldoc-echo-area-use-multiline-p))) + (cond (cached (slime-autodoc--format cached multilinep)) + (t + (when (slime-background-activities-enabled-p) + (slime-autodoc--async context multilinep)) + nil)))))))) + +;; Return the context around point that can be passed to +;; swank:autodoc. nil is returned if nothing reasonable could be +;; found. +(defun slime-autodoc--parse-context () + (and (slime-autodoc--parsing-safe-p) + (let ((levels slime-autodoc-accuracy-depth)) + (slime-parse-form-upto-point levels)))) + +(defun slime-autodoc--parsing-safe-p () + (cond ((fboundp 'slime-repl-inside-string-or-comment-p) + (not (slime-repl-inside-string-or-comment-p))) + (t + (not (slime-inside-string-or-comment-p))))) + +(defun slime-autodoc--async (context multilinep) + (slime-eval-async + `(swank:autodoc ',context ;; FIXME: misuse of quote + :print-right-margin ,(window-width (minibuffer-window))) + (slime-curry #'slime-autodoc--async% context multilinep))) + +(defun slime-autodoc--async% (context multilinep doc) + (cl-destructuring-bind (doc &optional cache-p) doc + (unless (eq doc :not-available) + (when cache-p + (slime-autodoc--cache-put context doc)) + ;; Now that we've got our information, + ;; get it to the user ASAP. + (when (eldoc-display-message-p) + (eldoc-message (slime-autodoc--format doc multilinep)))))) + + +;;; Minor mode definition + +;; Compute the prefix for slime-doc-map, usually this is C-c C-d. +(defun slime-autodoc--doc-map-prefix () + (concat + (car (rassoc '(slime-prefix-map) slime-parent-bindings)) + (car (rassoc '(slime-doc-map) slime-prefix-bindings)))) + +(define-minor-mode slime-autodoc-mode + "Toggle echo area display of Lisp objects at point." + :lighter slime-autodoc-mode-string + :keymap (let ((prefix (slime-autodoc--doc-map-prefix))) + `((,(concat prefix "A") . slime-autodoc-manually) + (,(concat prefix (kbd "C-A")) . slime-autodoc-manually) + (,(kbd "SPC") . slime-autodoc-space))) + (set (make-local-variable 'eldoc-minor-mode-string) nil) + (if (boundp 'eldoc-documentation-functions) + (add-hook 'eldoc-documentation-functions 'slime-autodoc nil t) + (set (make-local-variable 'eldoc-documentation-function) 'slime-autodoc)) + (eldoc-mode arg) + (setq slime-autodoc-mode t) + (when (called-interactively-p 'interactive) + (message "Slime autodoc mode %s." + (if slime-autodoc-mode "enabled" "disabled")))) + + +;;; Noise to enable/disable slime-autodoc-mode + +(defun slime-autodoc--on () (slime-autodoc-mode 1)) +(defun slime-autodoc--off () (slime-autodoc-mode 0)) + +(defvar slime-autodoc--relevant-hooks + '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) + +(defun slime-autodoc--enable () + (dolist (h slime-autodoc--relevant-hooks) + (add-hook h 'slime-autodoc--on)) + (dolist (b (buffer-list)) + (with-current-buffer b + (when slime-mode + (slime-autodoc--on))))) + +(defun slime-autodoc--disable () + (dolist (h slime-autodoc--relevant-hooks) + (remove-hook h 'slime-autodoc--on)) + (dolist (b (buffer-list)) + (with-current-buffer b + (when slime-autodoc-mode + (slime-autodoc--off))))) + +(provide 'slime-autodoc) diff --git a/elpa/slime-20200319.1939/contrib/slime-autodoc.elc b/elpa/slime-20200319.1939/contrib/slime-autodoc.elc new file mode 100644 index 00000000..d96ab576 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-autodoc.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-banner.el b/elpa/slime-20200319.1939/contrib/slime-banner.el new file mode 100644 index 00000000..f4eb8c45 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-banner.el @@ -0,0 +1,35 @@ +(require 'slime) +(require 'slime-repl) + +(define-slime-contrib slime-banner + "Persistent header line and startup animation." + (:authors "Helmut Eller " + "Luke Gorrie ") + (:license "GPL") + (:on-load (setq slime-repl-banner-function 'slime-startup-message)) + (:on-unload (setq slime-repl-banner-function 'slime-repl-insert-banner))) + +(defcustom slime-startup-animation (fboundp 'animate-string) + "Enable the startup animation." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-ui) + +(defcustom slime-header-line-p (boundp 'header-line-format) + "If non-nil, display a header line in Slime buffers." + :type 'boolean + :group 'slime-repl) + +(defun slime-startup-message () + (when slime-header-line-p + (setq header-line-format + (format "%s Port: %s Pid: %s" + (slime-lisp-implementation-type) + (slime-connection-port (slime-connection)) + (slime-pid)))) + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " slime-version))) + (if slime-startup-animation + (animate-string welcome 0 0) + (insert welcome))))) + +(provide 'slime-banner) diff --git a/elpa/slime-20200319.1939/contrib/slime-banner.elc b/elpa/slime-20200319.1939/contrib/slime-banner.elc new file mode 100644 index 00000000..d952505a Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-banner.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-buffer-streams.el b/elpa/slime-20200319.1939/contrib/slime-buffer-streams.el new file mode 100644 index 00000000..2fa700db --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-buffer-streams.el @@ -0,0 +1,36 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-buffer-streams + "Lisp streams that output to an emacs buffer" + (:authors "Ed Langley ") + (:license "GPL") + (:swank-dependencies swank-buffer-streams)) + +(defslimefun slime-make-buffer-stream-target (thread name) + (message "making target %s" name) + (slime-buffer-streams--get-target-marker name) + `(:stream-target-created ,thread ,name)) + +(defun slime-buffer-streams--get-target-name (target) + (format "*slime-target %s*" target)) + +(defvar-local slime-buffer-stream-target nil) + +;; TODO: tell backend that the buffer has been closed, so it can close +;; the stream +(defun slime-buffer-streams--cleanup-markers () + (when slime-buffer-stream-target + (message "Removing target: %s" slime-buffer-stream-target) + (remhash slime-buffer-stream-target slime-output-target-to-marker))) + +(defun slime-buffer-streams--get-target-marker (target) + (or (gethash target slime-output-target-to-marker) + (with-current-buffer + (generate-new-buffer (slime-buffer-streams--get-target-name target)) + (setq slime-buffer-stream-target target) + (add-hook 'kill-buffer-hook 'slime-buffer-streams--cleanup-markers) + (setf (gethash target slime-output-target-to-marker) + (point-marker))))) + +(provide 'slime-buffer-streams) diff --git a/elpa/slime-20200319.1939/contrib/slime-buffer-streams.elc b/elpa/slime-20200319.1939/contrib/slime-buffer-streams.elc new file mode 100644 index 00000000..247f051f Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-buffer-streams.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-c-p-c.el b/elpa/slime-20200319.1939/contrib/slime-c-p-c.el new file mode 100644 index 00000000..22a267b1 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-c-p-c.el @@ -0,0 +1,305 @@ +(require 'slime) +(require 'cl-lib) + +(defvar slime-c-p-c-init-undo-stack nil) + +(define-slime-contrib slime-c-p-c + "ILISP style Compound Prefix Completion." + (:authors "Luke Gorrie " + "Edi Weitz " + "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-parse slime-editing-commands slime-autodoc) + (:swank-dependencies swank-c-p-c) + (:on-load + (push + `(progn + (remove-hook 'slime-completion-at-point-functions + #'slime-c-p-c-completion-at-point) + (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + ,@(when (featurep 'slime-repl) + `((define-key slime-mode-map "\C-c\C-s" + ',(lookup-key slime-mode-map "\C-c\C-s")) + (define-key slime-repl-mode-map "\C-c\C-s" + ',(lookup-key slime-repl-mode-map "\C-c\C-s"))))) + slime-c-p-c-init-undo-stack) + (add-hook 'slime-completion-at-point-functions + #'slime-c-p-c-completion-at-point) + (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) + (when (featurep 'slime-repl) + (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form))) + (:on-unload + (while slime-c-p-c-init-undo-stack + (eval (pop slime-c-p-c-init-undo-stack))))) + +(defcustom slime-c-p-c-unambiguous-prefix-p t + "If true, set point after the unambigous prefix. +If false, move point to the end of the inserted text." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-complete-symbol*-fancy nil + "Use information from argument lists for DWIM'ish symbol completion." + :group 'slime-mode + :type 'boolean) + + +;; FIXME: this is the old code to display completions. Remove it once +;; `slime-complete-symbol*' and `slime-fuzzy-complete-symbol' can be +;; used together with `completion-at-point'. + +(defvar slime-completions-buffer-name "*Completions*") + +;; FIXME: can probably use quit-window instead +(make-variable-buffer-local + (defvar slime-complete-saved-window-configuration nil + "Window configuration before we show the *Completions* buffer. +This is buffer local in the buffer where the completion is +performed.")) + +(make-variable-buffer-local + (defvar slime-completions-window nil + "The window displaying *Completions* after saving window configuration. +If this window is no longer active or displaying the completions +buffer then we can ignore `slime-complete-saved-window-configuration'.")) + +(defun slime-complete-maybe-save-window-configuration () + "Maybe save the current window configuration. +Return true if the configuration was saved." + (unless (or slime-complete-saved-window-configuration + (get-buffer-window slime-completions-buffer-name)) + (setq slime-complete-saved-window-configuration + (current-window-configuration)) + t)) + +(defun slime-complete-delay-restoration () + (add-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration + 'append + 'local)) + +(defun slime-complete-forget-window-configuration () + (setq slime-complete-saved-window-configuration nil) + (setq slime-completions-window nil)) + +(defun slime-complete-restore-window-configuration () + "Restore the window config if available." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (when (and slime-complete-saved-window-configuration + (slime-completion-window-active-p)) + (save-excursion (set-window-configuration + slime-complete-saved-window-configuration)) + (setq slime-complete-saved-window-configuration nil) + (when (buffer-live-p slime-completions-buffer-name) + (kill-buffer slime-completions-buffer-name)))) + +(defun slime-complete-maybe-restore-window-configuration () + "Restore the window configuration, if the following command +terminates a current completion." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (condition-case err + (cond ((cl-find last-command-event "()\"'`,# \r\n:") + (slime-complete-restore-window-configuration)) + ((not (slime-completion-window-active-p)) + (slime-complete-forget-window-configuration)) + (t + (slime-complete-delay-restoration))) + (error + ;; Because this is called on the pre-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-complete-restore-window-configuration: %S" + err)))) + +(defun slime-completion-window-active-p () + "Is the completion window currently active?" + (and (window-live-p slime-completions-window) + (equal (buffer-name (window-buffer slime-completions-window)) + slime-completions-buffer-name))) + +(defun slime-display-completion-list (completions start end) + (let ((savedp (slime-complete-maybe-save-window-configuration))) + (with-output-to-temp-buffer slime-completions-buffer-name + (display-completion-list completions) + (with-current-buffer standard-output + (setq completion-base-position (list start end)) + (set-syntax-table lisp-mode-syntax-table))) + (when savedp + (setq slime-completions-window + (get-buffer-window slime-completions-buffer-name))))) + +(defun slime-display-or-scroll-completions (completions start end) + (cond ((and (eq last-command this-command) + (slime-completion-window-active-p)) + (slime-scroll-completions)) + (t + (slime-display-completion-list completions start end))) + (slime-complete-delay-restoration)) + +(defun slime-scroll-completions () + (let ((window slime-completions-window)) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + (set-window-start window (point-min)) + (save-selected-window + (select-window window) + (scroll-up)))))) + +(defun slime-minibuffer-respecting-message (format &rest format-args) + "Display TEXT as a message, without hiding any minibuffer contents." + (let ((text (format " [%s]" (apply #'format format format-args)))) + (if (minibuffer-window-active-p (minibuffer-window)) + (minibuffer-message text) + (message "%s" text)))) + +(defun slime-maybe-complete-as-filename () + "If point is at a string starting with \", complete it as filename. + Return nil if point is not at filename." + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" + (max (point-min) + (- (point) 1000)) t)) + (let ((comint-completion-addsuffix '("/" . "\""))) + (comint-replace-by-expanded-filename) + t))) + + +(defun slime-complete-symbol* () + "Expand abbreviations and complete the symbol at point." + ;; NB: It is only the name part of the symbol that we actually want + ;; to complete -- the package prefix, if given, is just context. + (or (slime-maybe-complete-as-filename) + (slime-expand-abbreviations-and-complete))) + +(defun slime-c-p-c-completion-at-point () + #'slime-complete-symbol*) + +;; FIXME: factorize +(defun slime-expand-abbreviations-and-complete () + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end)) + (completion-result (slime-contextual-completions beg end)) + (completion-set (cl-first completion-result)) + (completed-prefix (cl-second completion-result))) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + ;; some XEmacs issue makes this distinction necessary + (cond ((> (length completed-prefix) (- end beg)) + (goto-char end) + (insert-and-inherit completed-prefix) + (delete-region beg end) + (goto-char (+ beg (length completed-prefix)))) + (t nil)) + (cond ((and (member completed-prefix completion-set) + (slime-length= completion-set 1)) + (slime-minibuffer-respecting-message "Sole completion") + (when slime-complete-symbol*-fancy + (slime-complete-symbol*-fancy-bit)) + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (when (member completed-prefix completion-set) + (slime-minibuffer-respecting-message + "Complete but not unique")) + (when slime-c-p-c-unambiguous-prefix-p + (let ((unambiguous-completion-length + (cl-loop for c in completion-set + minimizing (or (cl-mismatch completed-prefix c) + (length completed-prefix))))) + (goto-char (+ beg unambiguous-completion-length)))) + (slime-display-or-scroll-completions completion-set + beg + (max (point) end))))))) + +(defun slime-complete-symbol*-fancy-bit () + "Do fancy tricks after completing a symbol. +\(Insert a space or close-paren based on arglist information.)" + (let ((arglist (slime-retrieve-arglist (slime-symbol-at-point)))) + (unless (eq arglist :not-available) + (let ((args + ;; Don't intern these symbols + (let ((obarray (make-vector 10 0))) + (cdr (read arglist)))) + (function-call-position-p + (save-excursion + (backward-sexp) + (equal (char-before) ?\()))) + (when function-call-position-p + (if (null args) + (execute-kbd-macro ")") + (execute-kbd-macro " ") + (when (and (slime-background-activities-enabled-p) + (not (minibuffer-window-active-p (minibuffer-window)))) + (slime-echo-arglist)))))))) + +(cl-defun slime-contextual-completions (beg end) + "Return a list of completions of the token from BEG to END in the +current buffer." + (let ((token (buffer-substring-no-properties beg end))) + (cond + ((and (< beg (point-max)) + (string= (buffer-substring-no-properties beg (1+ beg)) ":")) + ;; Contextual keyword completion + (let ((completions + (slime-completions-for-keyword token + (save-excursion + (goto-char beg) + (slime-parse-form-upto-point))))) + (when (cl-first completions) + (cl-return-from slime-contextual-completions completions)) + ;; If no matching keyword was found, do regular symbol + ;; completion. + )) + ((and (>= (length token) 2) + (string= (cl-subseq token 0 2) "#\\")) + ;; Character name completion + (cl-return-from slime-contextual-completions + (slime-completions-for-character token)))) + ;; Regular symbol completion + (slime-completions token))) + +(defun slime-completions (prefix) + (slime-eval `(swank:completions ,prefix ',(slime-current-package)))) + +(defun slime-completions-for-keyword (prefix buffer-form) + (slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form))) + +(defun slime-completions-for-character (prefix) + (cl-labels ((append-char-syntax (string) (concat "#\\" string))) + (let ((result (slime-eval `(swank:completions-for-character + ,(cl-subseq prefix 2))))) + (when (car result) + (list (mapcar #'append-char-syntax (car result)) + (append-char-syntax (cadr result))))))) + + +;;; Complete form + +(defun slime-complete-form () + "Complete the form at point. +This is a superset of the functionality of `slime-insert-arglist'." + (interactive) + ;; Find the (possibly incomplete) form around point. + (let ((buffer-form (slime-parse-form-upto-point))) + (let ((result (slime-eval `(swank:complete-form ',buffer-form)))) + (if (eq result :not-available) + (error "Could not generate completion for the form `%s'" buffer-form) + (progn + (just-one-space (if (looking-back "\\s(" (1- (point))) + 0 + 1)) + (save-excursion + (insert result) + (let ((slime-close-parens-limit 1)) + (slime-close-all-parens-in-sexp))) + (save-excursion + (backward-up-list 1) + (indent-sexp))))))) + +(provide 'slime-c-p-c) + diff --git a/elpa/slime-20200319.1939/contrib/slime-c-p-c.elc b/elpa/slime-20200319.1939/contrib/slime-c-p-c.elc new file mode 100644 index 00000000..8fc20ffa Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-c-p-c.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-cl-indent.el b/elpa/slime-20200319.1939/contrib/slime-cl-indent.el new file mode 100644 index 00000000..96ebb587 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-cl-indent.el @@ -0,0 +1,1821 @@ +;;; slime-cl-indent.el --- enhanced lisp-indent mode + +;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc. + +;; Author: Richard Mlynarik +;; Created: July 1987 +;; Maintainer: FSF +;; Keywords: lisp, tools +;; Package: emacs + +;; This file is forked from cl-indent.el, which 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 . + +;;; Commentary: + +;; This package supplies a single entry point, common-lisp-indent-function, +;; which performs indentation in the preferred style for Common Lisp code. +;; To enable it: +;; +;; (setq lisp-indent-function 'common-lisp-indent-function) +;; +;; This file is substantially patched from original cl-indent.el, +;; which is in Emacs proper. It does not require SLIME, but is instead +;; required by one of it's contribs, `slime-indentation'. +;; +;; Before making modifications to this file, consider adding them to +;; Emacs's own `cl-indent' and refactoring this file to be an +;; extension of Emacs's. + +;;; Code: + +(require 'slime) ; only for its cl-lib loading smartness +(require 'cl-lib) +(eval-when-compile (require 'cl)) + +(defgroup lisp-indent nil + "Indentation in Lisp." + :group 'lisp) + +(defcustom lisp-indent-maximum-backtracking 6 + "Maximum depth to backtrack out from a sublist for structured indentation. +If this variable is 0, no backtracking will occur and forms such as `flet' +may not be correctly indented if this value is less than 4." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-tag-indentation 1 + "Indentation of tags relative to containing list. +This variable is used by the function `lisp-indent-tagbody'." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-tag-body-indentation 3 + "Indentation of non-tagged lines relative to containing list. +This variable is used by the function `lisp-indent-tagbody' to indent normal +lines (lines without tags). +The indentation is relative to the indentation of the parenthesis enclosing +the special form. If the value is t, the body of tags will be indented +as a block at the same indentation as the first s-expression following +the tag. In this case, any forms before the first tag are indented +by `lisp-body-indent'." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-backquote-indentation t + "Whether or not to indent backquoted lists as code. +If nil, indent backquoted lists as data, i.e., like quoted lists." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-loop-indent-subclauses t + "Whether or not to indent loop subclauses." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-simple-loop-indentation 2 + "Indentation of forms in simple loop forms." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-clauses-indentation 2 + "Indentation of loop clauses if `loop' is immediately followed by a newline." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-indent-body-forms-relative-to-loop-start nil + "When true, indent loop body clauses relative to the open paren of the loop +form, instead of the keyword position." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-loop-body-forms-indentation 3 + "Indentation of loop body clauses." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-indent-forms-like-keywords nil + "Whether or not to indent loop subforms just like +loop keywords. Only matters when `lisp-loop-indent-subclauses' +is nil." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-align-keywords-in-calls t + "Whether to align keyword arguments vertically or not. +If t (the default), keywords in contexts where no other +indentation rule takes precedence are aligned like this: + +\(make-instance 'foo :bar t + :quux 42) + +If nil, they are indented like any other function +call arguments: + +\(make-instance 'foo :bar t + :quux 42)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-indentation t + "Whether to indent lambda-lists specially. Defaults to t. Setting this to +nil makes `lisp-lambda-list-keyword-alignment', +`lisp-lambda-list-keyword-parameter-alignment', and +`lisp-lambda-list-keyword-parameter-indentation' meaningless, causing +lambda-lists to be indented as if they were data: + +\(defun example (a b &optional o1 o2 + o3 o4 + &rest r + &key k1 k2 + k3 k4) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-alignment nil + "Whether to vertically align lambda-list keywords together. +If nil (the default), keyworded lambda-list parts are aligned +with the initial mandatory arguments, like this: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#) + +If non-nil, alignment is done with the first keyword +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-indentation 2 + "Indentation of lambda list keyword parameters. +See `lisp-lambda-list-keyword-parameter-alignment' +for more information." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-alignment nil + "Whether to vertically align lambda-list keyword parameters together. +If nil (the default), the parameters are aligned +with their corresponding keyword, plus the value of +`lisp-lambda-list-keyword-parameter-indentation', like this: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#) + +If non-nil, alignment is done with the first parameter +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + + +(defvar lisp-indent-defun-method '(4 &lambda &body) + "Defun-like indentation method. +This applies when the value of the `common-lisp-indent-function' property +is set to `defun'.") + + +;;;; Named styles. +;;;; +;;;; -*- common-lisp-style: foo -*- +;;;; +;;;; sets the style for the buffer. +;;;; +;;;; A Common Lisp style is a list of the form: +;;;; +;;;; (NAME INHERIT VARIABLES INDENTATION HOOK DOCSTRING) +;;;; +;;;; where NAME is a symbol naming the style, INHERIT is the name of the style +;;;; it inherits from, VARIABLES is an alist specifying buffer local variables +;;;; for the style, and INDENTATION is an alist specifying non-standard +;;;; indentations for Common Lisp symbols. HOOK is a function to call when +;;;; activating the style. DOCSTRING is the documentation for the style. +;;;; +;;;; Convenience accessors `common-lisp-style-name', &co exist. +;;;; +;;;; `common-lisp-style' stores the name of the current style. +;;;; +;;;; `common-lisp-style-default' stores the name of the style to use when none +;;;; has been specified. +;;;; +;;;; `common-lisp-active-style' stores a cons of the list specifying the +;;;; current style, and a hash-table containing all indentation methods of +;;;; that style and any styles it inherits from. Whenever we're indenting, we +;;;; check that this is up to date, and recompute when necessary. +;;;; +;;;; Just setting the buffer local common-lisp-style will be enough to have +;;;; the style take effect. `common-lisp-set-style' can also be called +;;;; explicitly, however, and offers name completion, etc. + +;;; Convenience accessors +(defun common-lisp-style-name (style) (first style)) +(defun common-lisp-style-inherits (style) (second style)) +(defun common-lisp-style-variables (style) (third style)) +(defun common-lisp-style-indentation (style) (fourth style)) +(defun common-lisp-style-hook (style) (fifth style)) +(defun common-lisp-style-docstring (style) (sixth style)) + +(defun common-lisp-make-style (stylename inherits variables indentation hook + documentation) + (list stylename inherits variables indentation hook documentation)) + +(defvar common-lisp-style nil) + +;;; `define-common-lisp-style' updates the docstring of +;;; `common-lisp-style', using this as the base. +(put 'common-lisp-style 'common-lisp-style-base-doc + "Name of the Common Lisp indentation style used in the current buffer. +Set this by giving eg. + + ;; -*- common-lisp-style: sbcl -*- + +in the first line of the file, or by calling `common-lisp-set-style'. If +buffer has no style specified, but `common-lisp-style-default' is set, that +style is used instead. Use `define-common-lisp-style' to define new styles.") + +(make-variable-buffer-local 'common-lisp-style) +(set-default 'common-lisp-style nil) + +;;; `lisp-mode' kills all buffer-local variables. Setting the +;;; `permanent-local' property allows us to retain the style. +(put 'common-lisp-style 'permanent-local t) + +;;; Mark as safe when the style doesn't evaluate arbitrary code. +(put 'common-lisp-style 'safe-local-variable 'common-lisp-safe-style-p) + +;;; Common Lisp indentation style specifications. +(defvar common-lisp-styles (make-hash-table :test 'equal)) + +(defun common-lisp-delete-style (stylename) + (remhash stylename common-lisp-styles)) + +(defun common-lisp-find-style (stylename) + (let ((name (if (symbolp stylename) + (symbol-name stylename) + stylename))) + (or (gethash name common-lisp-styles) + (error "Unknown Common Lisp style: %s" name)))) + +(defun common-lisp-safe-style-p (stylename) + "True for known Common Lisp style without an :EVAL option. +Ie. styles that will not evaluate arbitrary code on activation." + (let* ((style (ignore-errors (common-lisp-find-style stylename))) + (base (common-lisp-style-inherits style))) + (and style + (not (common-lisp-style-hook style)) + (or (not base) + (common-lisp-safe-style-p base))))) + +(defun common-lisp-add-style (stylename inherits variables indentation hooks + documentation) + ;; Invalidate indentation methods cached in common-lisp-active-style. + (maphash (lambda (k v) + (puthash k (cl-copy-list v) common-lisp-styles)) + common-lisp-styles) + ;; Add/Redefine the specified style. + (puthash stylename + (common-lisp-make-style stylename inherits variables indentation + hooks documentation) + common-lisp-styles) + ;; Frob `common-lisp-style' docstring. + (let ((doc (get 'common-lisp-style 'common-lisp-style-base-doc)) + (all nil)) + (setq doc (concat doc "\n\nAvailable styles are:\n")) + (maphash (lambda (name style) + (push (list name (common-lisp-style-docstring style)) all)) + common-lisp-styles) + (dolist (info (sort all (lambda (a b) (string< (car a) (car b))))) + (let ((style-name (first info)) + (style-doc (second info))) + (if style-doc + (setq doc (concat doc + "\n " style-name "\n" + " " style-doc "\n")) + (setq doc (concat doc + "\n " style-name " (undocumented)\n"))))) + (put 'common-lisp-style 'variable-documentation doc)) + stylename) + +;;; Activate STYLENAME, adding its indentation methods to METHODS -- and +;;; recurse on style inherited from. +(defun common-lisp-activate-style (stylename methods) + (let* ((style (common-lisp-find-style stylename)) + (basename (common-lisp-style-inherits style))) + ;; Recurse on parent. + (when basename + (common-lisp-activate-style basename methods)) + ;; Copy methods + (dolist (spec (common-lisp-style-indentation style)) + (puthash (first spec) (second spec) methods)) + ;; Bind variables. + (dolist (var (common-lisp-style-variables style)) + (set (make-local-variable (first var)) (second var))) + ;; Run hook. + (let ((hook (common-lisp-style-hook style))) + (when hook + (funcall hook))))) + +;;; When a style is being used, `common-lisp-active-style' holds a cons +;;; +;;; (STYLE . METHODS) +;;; +;;; where STYLE is the list specifying the currently active style, and +;;; METHODS is the table of indentation methods -- including inherited +;;; ones -- for it. `common-lisp-active-style-methods' is reponsible +;;; for keeping this up to date. +(make-variable-buffer-local (defvar common-lisp-active-style nil)) + +;;; Makes sure common-lisp-active-style corresponds to common-lisp-style, and +;;; pick up redefinitions, etc. Returns the method table for the currently +;;; active style. +(defun common-lisp-active-style-methods () + (let* ((name common-lisp-style) + (style (when name (common-lisp-find-style name)))) + (if (eq style (car common-lisp-active-style)) + (cdr common-lisp-active-style) + (when style + (let ((methods (make-hash-table :test 'equal))) + (common-lisp-activate-style name methods) + (setq common-lisp-active-style (cons style methods)) + methods))))) + +(defvar common-lisp-set-style-history nil) + +(defun common-lisp-style-names () + (let (names) + (maphash (lambda (k v) + (push (cons k v) names)) + common-lisp-styles) + names)) + +(defun common-lisp-set-style (stylename) + "Set current buffer to use the Common Lisp style STYLENAME. +STYLENAME, a string, must be an existing Common Lisp style. Styles +are added (and updated) using `define-common-lisp-style'. + +The buffer-local variable `common-lisp-style' will get set to STYLENAME. + +A Common Lisp style is composed of local variables, indentation +specifications, and may also contain arbitrary elisp code to run upon +activation." + (interactive + (list (let ((completion-ignore-case t) + (prompt "Specify Common Lisp indentation style: ")) + (completing-read prompt + (common-lisp-style-names) nil t nil + 'common-lisp-set-style-history)))) + (setq common-lisp-style (common-lisp-style-name + (common-lisp-find-style stylename)) + common-lisp-active-style nil) + ;; Actually activates the style. + (common-lisp-active-style-methods) + stylename) + +(defmacro define-common-lisp-style (name documentation &rest options) + "Define a Common Lisp indentation style. + +NAME is the name of the style. + +DOCUMENTATION is the docstring for the style, automatically added to the +docstring of `common-lisp-style'. + +OPTIONS are: + + (:variables (name value) ...) + + Specifying the buffer local variables associated with the style. + + (:indentation (symbol spec) ...) + + Specifying custom indentations associated with the style. SPEC is + a normal `common-lisp-indent-function' indentation specification. + + (:inherit style) + + Inherit variables and indentations from another Common Lisp style. + + (:eval form ...) + + Lisp code to evaluate when activating the style. This can be used to + eg. activate other modes. It is possible that over the lifetime of + a buffer same style gets activated multiple times, so code in :eval + option should cope with that. +" + (when (consp documentation) + (setq options (cons documentation options) + documentation nil)) + `(common-lisp-add-style ,name + ',(cadr (assoc :inherit options)) + ',(cdr (assoc :variables options)) + ',(cdr (assoc :indentation options)) + ,(when (assoc :eval options) + `(lambda () + ,@(cdr (assoc :eval options)))) + ,documentation)) + +(define-common-lisp-style "basic-common" + (:variables + (lisp-indent-maximum-backtracking 6) + (lisp-tag-indentation 1) + (lisp-tag-body-indentation 3) + (lisp-backquote-indentation t) + (lisp-loop-indent-subclauses t) + (lisp-loop-indent-forms-like-keywords nil) + (lisp-simple-loop-indentation 2) + (lisp-align-keywords-in-calls t) + (lisp-lambda-list-indentation t) + (lisp-lambda-list-keyword-alignment nil) + (lisp-lambda-list-keyword-parameter-indentation 2) + (lisp-lambda-list-keyword-parameter-alignment nil) + (lisp-indent-defun-method (4 &lambda &body)) + (lisp-loop-clauses-indentation 2) + (lisp-loop-indent-body-forms-relative-to-loop-start nil) + (lisp-loop-body-forms-indentation 3))) + +(define-common-lisp-style "basic-emacs25" + "This style adds a workaround needed for Emacs 25" + (:inherit "basic-common") + (:variables + ;; Without these (;;foo would get a space inserted between + ;; ( and ; by indent-sexp. + (comment-indent-function (lambda () nil)))) + +(define-common-lisp-style "basic-emacs26" + "This style is the same as basic-common. It doesn't need or + want the workaround used in Emacs 25. In Emacs 26, that + workaround introduces a weird behavior where a single + semicolon breaks the mode and causes the cursor to move to the + start of the line after every character inserted." + (:inherit "basic-common")) + +(if (>= emacs-major-version 26) + (define-common-lisp-style "basic" + "This style merely gives all identation variables their default values, + making it easy to create new styles that are proof against user + customizations. It also adjusts comment indentation from default. + All other predefined modes inherit from basic." + (:inherit "basic-emacs26")) + (define-common-lisp-style "basic" + "This style merely gives all identation variables their default values, + making it easy to create new styles that are proof against user + customizations. It also adjusts comment indentation from default. + All other predefined modes inherit from basic." + (:inherit "basic-emacs25"))) + +(define-common-lisp-style "classic" + "This style of indentation emulates the most striking features of 1995 + vintage cl-indent.el once included as part of Slime: IF indented by two + spaces, and CASE clause bodies indentented more deeply than the keys." + (:inherit "basic") + (:variables + (lisp-lambda-list-keyword-parameter-indentation 0)) + (:indentation + (case (4 &rest (&whole 2 &rest 3))) + (if (4 2 2)))) + +(define-common-lisp-style "modern" + "A good general purpose style. Turns on lambda-list keyword and keyword + parameter alignment, and turns subclause aware loop indentation off. + (Loop indentation so because simpler style is more prevalent in existing + sources, not because it is necessarily preferred.)" + (:inherit "basic") + (:variables + (lisp-lambda-list-keyword-alignment t) + (lisp-lambda-list-keyword-parameter-alignment t) + (lisp-lambda-list-keyword-parameter-indentation 0) + (lisp-loop-indent-subclauses nil))) + +(define-common-lisp-style "sbcl" + "Style used in SBCL sources. A good if somewhat intrusive general purpose + style based on the \"modern\" style. Adds indentation for a few SBCL + specific constructs, sets indentation to use spaces instead of tabs, + fill-column to 78, and activates whitespace-mode to show tabs and trailing + whitespace." + (:inherit "modern") + (:eval + (whitespace-mode 1)) + (:variables + (whitespace-style (tabs trailing)) + (indent-tabs-mode nil) + (comment-fill-column nil) + (fill-column 78)) + (:indentation + (def!constant (as defconstant)) + (def!macro (as defmacro)) + (def!method (as defmethod)) + (def!struct (as defstruct)) + (def!type (as deftype)) + (defmacro-mundanely (as defmacro)) + (define-source-transform (as defun)) + (!def-type-translator (as defun)) + (!def-debug-command (as defun)))) + +(defcustom common-lisp-style-default nil + "Name of the Common Lisp indentation style to use in lisp-mode buffers if +none has been specified." + :type `(choice (const :tag "None" nil) + ,@(mapcar (lambda (spec) + `(const :tag ,(car spec) ,(car spec))) + (common-lisp-style-names)) + (string :tag "Other")) + :group 'lisp-indent) + +;;; If style is being used, that's a sufficient invitation to snag +;;; the indentation function. +(defun common-lisp-lisp-mode-hook () + (let ((style (or common-lisp-style common-lisp-style-default))) + (when style + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (common-lisp-set-style style)))) +(add-hook 'lisp-mode-hook 'common-lisp-lisp-mode-hook) + + +;;;; The indentation specs are stored at three levels. In order of priority: +;;;; +;;;; 1. Indentation as set by current style, from the indentation table +;;;; in the current style. +;;;; +;;;; 2. Globally set indentation, from the `common-lisp-indent-function' +;;;; property of the symbol. +;;;; +;;;; 3. Per-package indentation derived by the system. A live Common Lisp +;;;; system may (via Slime, eg.) add indentation specs to +;;;; common-lisp-system-indentation, where they are associated with +;;;; the package of the symbol. Then we run some lossy heuristics and +;;;; find something that looks promising. +;;;; +;;;; FIXME: for non-system packages the derived indentation should probably +;;;; take precedence. + +;;; This maps symbols into lists of (INDENT . PACKAGES) where INDENT is +;;; an indentation spec, and PACKAGES are the names of packages where this +;;; applies. +;;; +;;; We never add stuff here by ourselves: this is for things like Slime to +;;; fill. +(defvar common-lisp-system-indentation (make-hash-table :test 'equal)) + +(defun common-lisp-guess-current-package () + (let (pkg) + (save-excursion + (ignore-errors + (when (let ((case-fold-search t)) + (search-backward "(in-package ")) + (re-search-forward "[ :\"]+") + (let ((start (point))) + (re-search-forward "[\":)]") + (setf pkg (upcase (buffer-substring-no-properties + start (1- (point))))))))) + pkg)) + +(defvar common-lisp-current-package-function 'common-lisp-guess-current-package + "Used to derive the package name to use for indentation at a +given point. Defaults to `common-lisp-guess-current-package'.") + +(defun common-lisp-symbol-package (string) + (if (and (stringp string) (string-match ":" string)) + (let ((p (match-beginning 0))) + (if (eql 0 p) + "KEYWORD" + (upcase (substring string 0 p)))) + (funcall common-lisp-current-package-function))) + +(defun common-lisp-get-indentation (name &optional full) + "Retrieves the indentation information for NAME." + (let ((method + (or + ;; From style + (when common-lisp-style + (gethash name (common-lisp-active-style-methods))) + ;; From global settings. + (get name 'common-lisp-indent-function) + ;; From system derived information. + (let ((system-info (gethash name common-lisp-system-indentation))) + (if (not (cdr system-info)) + (caar system-info) + (let ((guess nil) + (guess-n 0) + (package (common-lisp-symbol-package full))) + (dolist (info system-info guess) + (let* ((pkgs (cdr info)) + (n (length pkgs))) + (cond ((member package pkgs) + ;; This is it. + (return (car info))) + ((> n guess-n) + ;; If we can't find the real thing, go with the one + ;; accessible in most packages. + (setf guess (car info) + guess-n n))))))))))) + (if (and (consp method) (eq 'as (car method))) + (common-lisp-get-indentation (cadr method)) + method))) + +;;;; LOOP indentation, the simple version + +(defun common-lisp-loop-type (loop-start) + "Returns the type of the loop form at LOOP-START. +Possible types are SIMPLE, SIMPLE/SPLIT, EXTENDED, and EXTENDED/SPLIT. */SPLIT +refers to extended loops whose body does not start on the same line as the +opening parenthesis of the loop." + (let (comment-split) + (condition-case () + (save-excursion + (goto-char loop-start) + (let ((line (line-number-at-pos)) + (maybe-split t)) + (forward-char 1) + (forward-sexp 1) + (save-excursion + (when (looking-at "\\s-*\\\n*;") + (search-forward ";") + (backward-char 1) + (if (= line (line-number-at-pos)) + (setq maybe-split nil) + (setq comment-split t)))) + (forward-sexp 1) + (backward-sexp 1) + (if (eql (char-after) ?\() + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'simple + 'simple/split) + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'extended + 'extended/split)))) + (error + (if comment-split + 'simple/split + 'simple))))) + +(defun common-lisp-trailing-comment () + (ignore-errors + ;; If we had a trailing comment just before this, find it. + (save-excursion + (backward-sexp) + (forward-sexp) + (when (looking-at "\\s-*;") + (search-forward ";") + (1- (current-column)))))) + +;;;###autoload +(defun common-lisp-indent-function (indent-point state) + "Function to indent the arguments of a Lisp function call. +This is suitable for use as the value of the variable +`lisp-indent-function'. INDENT-POINT is the point at which the +indentation function is called, and STATE is the +`parse-partial-sexp' state at that position. Browse the +`lisp-indent' customize group for options affecting the behavior +of this function. + +If the indentation point is in a call to a Lisp function, that +function's common-lisp-indent-function property specifies how +this function should indent it. Possible values for this +property are: + +* defun, meaning indent according to `lisp-indent-defun-method'; + i.e., like (4 &lambda &body), as explained below. + +* any other symbol, meaning a function to call. The function should + take the arguments: PATH STATE INDENT-POINT SEXP-COLUMN NORMAL-INDENT. + PATH is a list of integers describing the position of point in terms of + list-structure with respect to the containing lists. For example, in + ((a b c (d foo) f) g), foo has a path of (0 3 1). In other words, + to reach foo take the 0th element of the outermost list, then + the 3rd element of the next list, and finally the 1st element. + STATE and INDENT-POINT are as in the arguments to + `common-lisp-indent-function'. SEXP-COLUMN is the column of + the open parenthesis of the innermost containing list. + NORMAL-INDENT is the column the indentation point was + originally in. This function should behave like `lisp-indent-259'. + +* an integer N, meaning indent the first N arguments like + function arguments, and any further arguments like a body. + This is equivalent to (4 4 ... &body). + +* a list starting with `as' specifies an indirection: indentation is done as + if the form being indented had started with the second element of the list. + +* any other list. The list element in position M specifies how to indent the + Mth function argument. If there are fewer elements than function arguments, + the last list element applies to all remaining arguments. The accepted list + elements are: + + * nil, meaning the default indentation. + + * an integer, specifying an explicit indentation. + + * &lambda. Indent the argument (which may be a list) by 4. + + * &rest. When used, this must be the penultimate element. The + element after this one applies to all remaining arguments. + + * &body. This is equivalent to &rest lisp-body-indent, i.e., indent + all remaining elements by `lisp-body-indent'. + + * &whole. This must be followed by nil, an integer, or a + function symbol. This indentation is applied to the + associated argument, and as a base indent for all remaining + arguments. For example, an integer P means indent this + argument by P, and all remaining arguments by P, plus the + value specified by their associated list element. + + * a symbol. A function to call, with the 6 arguments specified above. + + * a list, with elements as described above. This applies when the + associated function argument is itself a list. Each element of the list + specifies how to indent the associated argument. + +For example, the function `case' has an indent property +\(4 &rest (&whole 2 &rest 1)), meaning: + * 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." + (common-lisp-indent-function-1 indent-point state)) + +;;; XEmacs doesn't have looking-back, so we define a simple one. Faster to +;;; boot, and sufficient for our needs. +(defun common-lisp-looking-back (string) + (let ((len (length string))) + (dotimes (i len t) + (unless (eql (elt string (- len i 1)) (char-before (- (point) i))) + (return nil))))) + +(defvar common-lisp-feature-expr-regexp "#!?\\(+\\|-\\)") + +;;; Semi-feature-expression aware keyword check. +(defun common-lisp-looking-at-keyword () + (or (looking-at ":") + (and (looking-at common-lisp-feature-expr-regexp) + (save-excursion + (forward-sexp) + (skip-chars-forward " \t\n") + (common-lisp-looking-at-keyword))))) + +;;; Semi-feature-expression aware backwards movement for keyword +;;; argument pairs. +(defun common-lisp-backward-keyword-argument () + (ignore-errors + (backward-sexp 2) + (when (looking-at common-lisp-feature-expr-regexp) + (cond ((ignore-errors + (save-excursion + (backward-sexp 2) + (looking-at common-lisp-feature-expr-regexp))) + (common-lisp-backward-keyword-argument)) + ((ignore-errors + (save-excursion + (backward-sexp 1) + (looking-at ":"))) + (backward-sexp)))) + t)) + +(defun common-lisp-indent-function-1 (indent-point state) + ;; If we're looking at a splice, move to the first comma. + (when (or (common-lisp-looking-back ",") (common-lisp-looking-back ",@")) + (when (re-search-backward "[^,@'],") + (forward-char 1))) + (let ((normal-indent (current-column))) + ;; Walk up list levels until we see something + ;; which does special things with subforms. + (let ((depth 0) + ;; Path describes the position of point in terms of + ;; list-structure with respect to containing lists. + ;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. + (path ()) + ;; set non-nil when somebody works out the indentation to use + calculated + ;; If non-nil, this is an indentation to use + ;; if nothing else specifies it more firmly. + tentative-calculated + (last-point indent-point) + ;; the position of the open-paren of the innermost containing list + (containing-form-start (common-lisp-indent-parse-state-start state)) + ;; the column of the above + sexp-column) + ;; Move to start of innermost containing list + (goto-char containing-form-start) + (setq sexp-column (current-column)) + + ;; Look over successively less-deep containing forms + (while (and (not calculated) + (< depth lisp-indent-maximum-backtracking)) + (let ((containing-sexp (point))) + (forward-char 1) + (parse-partial-sexp (point) indent-point 1 t) + ;; Move to the car of the relevant containing form + (let (tem full function method tentative-defun) + (if (not (looking-at "\\sw\\|\\s_")) + ;; This form doesn't seem to start with a symbol + (setq function nil method nil full nil) + (setq tem (point)) + (forward-sexp 1) + (setq full (downcase (buffer-substring-no-properties + tem (point))) + function full) + (goto-char tem) + (setq tem (intern-soft function) + method (common-lisp-get-indentation tem)) + (cond ((and (null method) + (string-match ":[^:]+" function)) + ;; The pleblisp package feature + (setq function (substring function + (1+ (match-beginning 0))) + method (common-lisp-get-indentation + (intern-soft function) full))) + ((and (null method)) + ;; backwards compatibility + (setq method (common-lisp-get-indentation tem))))) + (let ((n 0)) + ;; How far into the containing form is the current form? + (if (< (point) indent-point) + (while (condition-case () + (progn + (forward-sexp 1) + (if (>= (point) indent-point) + nil + (parse-partial-sexp (point) + indent-point 1 t) + (setq n (1+ n)) + t)) + (error nil)))) + (setq path (cons n path))) + + ;; Guess. + (when (and (not method) function (null (cdr path))) + ;; (package prefix was stripped off above) + (cond ((and (string-match "\\`def" function) + (not (string-match "\\`default" function)) + (not (string-match "\\`definition" function)) + (not (string-match "\\`definer" function))) + (setq tentative-defun t)) + ((string-match + (eval-when-compile + (concat "\\`\\(" + (regexp-opt '("with" "without" "do")) + "\\)-")) + function) + (setq method '(&lambda &body))))) + + ;; #+ and #- cleverness. + (save-excursion + (goto-char indent-point) + (backward-sexp) + (let ((indent (current-column))) + (when (or (looking-at common-lisp-feature-expr-regexp) + (ignore-errors + (backward-sexp) + (when (looking-at + common-lisp-feature-expr-regexp) + (setq indent (current-column)) + (let ((line (line-number-at-pos))) + (while + (ignore-errors + (backward-sexp 2) + (and + (= line (line-number-at-pos)) + (looking-at + common-lisp-feature-expr-regexp))) + (setq indent (current-column)))) + t))) + (setq calculated (list indent containing-form-start))))) + + (cond ((and (or (eq (char-after (1- containing-sexp)) ?\') + (and (not lisp-backquote-indentation) + (eq (char-after (1- containing-sexp)) ?\`))) + (not (eq (char-after (- containing-sexp 2)) ?\#))) + ;; No indentation for "'(...)" elements + (setq calculated (1+ sexp-column))) + ((eq (char-after (1- containing-sexp)) ?\#) + ;; "#(...)" + (setq calculated (1+ sexp-column))) + ((null method) + ;; If this looks like a call to a `def...' form, + ;; think about indenting it as one, but do it + ;; tentatively for cases like + ;; (flet ((defunp () + ;; nil))) + ;; Set both normal-indent and tentative-calculated. + ;; The latter ensures this value gets used + ;; if there are no relevant containing constructs. + ;; The former ensures this value gets used + ;; if there is a relevant containing construct + ;; but we are nested within the structure levels + ;; that it specifies indentation for. + (if tentative-defun + (setq tentative-calculated + (common-lisp-indent-call-method + function lisp-indent-defun-method + path state indent-point + sexp-column normal-indent) + normal-indent tentative-calculated) + (when lisp-align-keywords-in-calls + ;; No method so far. If we're looking at a keyword, + ;; align with the first keyword in this expression. + ;; This gives a reasonable indentation to most things + ;; with keyword arguments. + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (when (common-lisp-looking-at-keyword) + (while (common-lisp-backward-keyword-argument) + (when (common-lisp-looking-at-keyword) + (setq calculated + (list (current-column) + containing-form-start))))))))) + ((integerp method) + ;; convenient top-level hack. + ;; (also compatible with lisp-indent-function) + ;; The number specifies how many `distinguished' + ;; forms there are before the body starts + ;; Equivalent to (4 4 ... &body) + (setq calculated (cond ((cdr path) + normal-indent) + ((<= (car path) method) + ;; `distinguished' form + (list (+ sexp-column 4) + containing-form-start)) + ((= (car path) (1+ method)) + ;; first body form. + (+ sexp-column lisp-body-indent)) + (t + ;; other body form + normal-indent)))) + (t + (setq calculated + (common-lisp-indent-call-method + function method path state indent-point + sexp-column normal-indent))))) + (goto-char containing-sexp) + (setq last-point containing-sexp) + (unless calculated + (condition-case () + (progn (backward-up-list 1) + (setq depth (1+ depth))) + (error + (setq depth lisp-indent-maximum-backtracking)))))) + + (or calculated tentative-calculated + ;; Fallback. + ;; + ;; Instead of punting directly to calculate-lisp-indent we + ;; handle a few of cases it doesn't deal with: + ;; + ;; A: (foo ( + ;; bar zot + ;; quux)) + ;; + ;; would align QUUX with ZOT. + ;; + ;; B: + ;; (foo (or x + ;; y) t + ;; z) + ;; + ;; would align the Z with Y. + ;; + ;; C: + ;; (foo ;; Comment + ;; (bar) + ;; ;; Comment 2 + ;; (quux)) + ;; + ;; would indent BAR and QUUX by one. + (ignore-errors + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (let ((p (point))) + (goto-char containing-form-start) + (down-list) + (let ((one (current-column))) + (skip-chars-forward " \t") + (if (or (eolp) (looking-at ";")) + ;; A. + (list one containing-form-start) + (forward-sexp 2) + (backward-sexp) + (if (/= p (point)) + ;; B. + (list (current-column) containing-form-start) + (backward-sexp) + (forward-sexp) + (let ((tmp (+ (current-column) 1))) + (skip-chars-forward " \t") + (if (looking-at ";") + ;; C. + (list tmp containing-form-start))))))))))))) + + +(defun common-lisp-indent-call-method (function method path state indent-point + sexp-column normal-indent) + (let ((lisp-indent-error-function function)) + (if (symbolp method) + (funcall method + path state indent-point + sexp-column normal-indent) + (lisp-indent-259 method path state indent-point + sexp-column normal-indent)))) + +;; Dynamically bound in common-lisp-indent-call-method. +(defvar lisp-indent-error-function) + +(defun lisp-indent-report-bad-format (m) + (error "%s has a badly-formed %s property: %s" + ;; Love those free variable references!! + lisp-indent-error-function 'common-lisp-indent-function m)) + + +;; Lambda-list indentation is now done in LISP-INDENT-LAMBDA-LIST. +;; See also `lisp-lambda-list-keyword-alignment', +;; `lisp-lambda-list-keyword-parameter-alignment' and +;; `lisp-lambda-list-keyword-parameter-indentation' -- dvl + +(defvar lisp-indent-lambda-list-keywords-regexp + "&\\(\ +optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|\ +environment\\|more\ +\\)\\>" + "Regular expression matching lambda-list keywords.") + +(defun lisp-indent-lambda-list + (indent-point sexp-column containing-form-start) + (if (not lisp-lambda-list-indentation) + (1+ sexp-column) + (lisp-properly-indent-lambda-list + indent-point sexp-column containing-form-start))) + +(defun lisp-properly-indent-lambda-list + (indent-point sexp-column containing-form-start) + (let (limit) + (cond + ((save-excursion + (goto-char indent-point) + (back-to-indentation) + (setq limit (point)) + (looking-at lisp-indent-lambda-list-keywords-regexp)) + ;; We're facing a lambda-list keyword. + (if lisp-lambda-list-keyword-alignment + ;; Align to the first keyword if any, or to the beginning of + ;; the lambda-list. + (save-excursion + (goto-char containing-form-start) + (down-list) + (let ((key-indent nil) + (next t)) + (while (and next (< (point) indent-point)) + (if (looking-at lisp-indent-lambda-list-keywords-regexp) + (setq key-indent (current-column) + next nil) + (setq next (ignore-errors (forward-sexp) t)) + (if next + (ignore-errors + (forward-sexp) + (backward-sexp))))) + (or key-indent + (1+ sexp-column)))) + ;; Align to the beginning of the lambda-list. + (1+ sexp-column))) + (t + ;; Otherwise, align to the first argument of the last lambda-list + ;; keyword, the keyword itself, or the beginning of the + ;; lambda-list. + (save-excursion + (goto-char indent-point) + (let ((indent nil) + (next t)) + (while (and next (> (point) containing-form-start)) + (setq next (ignore-errors (backward-sexp) t)) + (let* ((col (current-column)) + (pos + (save-excursion + (ignore-errors (forward-sexp)) + (skip-chars-forward " \t") + (if (eolp) + (+ col + lisp-lambda-list-keyword-parameter-indentation) + col)))) + (if (looking-at lisp-indent-lambda-list-keywords-regexp) + (setq indent + (if lisp-lambda-list-keyword-parameter-alignment + (or indent pos) + (+ col + lisp-lambda-list-keyword-parameter-indentation)) + next nil) + (setq indent col)))) + (or indent (1+ sexp-column)))))))) + +(defun common-lisp-lambda-list-initial-value-form-p (point) + (let ((state 'x) + (point (save-excursion + (goto-char point) + (back-to-indentation) + (point)))) + (save-excursion + (backward-sexp) + (ignore-errors (down-list 1)) + (while (and point (< (point) point)) + (cond ((or (looking-at "&key") (looking-at "&optional") + (looking-at "&aux")) + (setq state 'key)) + ((looking-at lisp-indent-lambda-list-keywords-regexp) + (setq state 'x))) + (if (not (ignore-errors (forward-sexp) t)) + (setq point nil) + (ignore-errors + (forward-sexp) + (backward-sexp)) + (cond ((> (point) point) + (backward-sexp) + (when (eq state 'var) + (setq state 'x)) + (or (ignore-errors + (down-list 1) + (cond ((> (point) point) + (backward-up-list)) + ((eq 'key state) + (setq state 'var))) + t) + (setq point nil))) + ((eq state 'var) + (setq state 'form)))))) + (eq 'form state))) + +;; Blame the crufty control structure on dynamic scoping +;; -- not on me! +(defun lisp-indent-259 + (method path state indent-point sexp-column normal-indent) + (catch 'exit + (let* ((p (cdr path)) + (containing-form-start (elt state 1)) + (n (1- (car path))) + tem tail) + (if (not (consp method)) + (lisp-indent-report-bad-format method)) + (while n + ;; This while loop is for advancing along a method + ;; until the relevant (possibly &rest/&body) pattern + ;; is reached. + ;; n is set to (1- n) and method to (cdr method) + ;; each iteration. + (setq tem (car method)) + + (or (eq tem 'nil) ;default indentation + (eq tem '&lambda) ;lambda list + (and (eq tem '&body) (null (cdr method))) + (and (eq tem '&rest) + (consp (cdr method)) + (null (cddr method))) + (integerp tem) ;explicit indentation specified + (and (consp tem) ;destructuring + (or (consp (car tem)) + (and (eq (car tem) '&whole) + (or (symbolp (cadr tem)) + (integerp (cadr tem)))))) + (and (symbolp tem) ;a function to call to do the work. + (null (cdr method))) + (lisp-indent-report-bad-format method)) + (cond ((eq tem '&body) + ;; &body means (&rest ) + (throw 'exit + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent))) + ((eq tem '&rest) + ;; this pattern holds for all remaining forms + (setq tail (> n 0) + n 0 + method (cdr method))) + ((> n 0) + ;; try next element of pattern + (setq n (1- n) + method (cdr method)) + (if (< n 0) + ;; Too few elements in pattern. + (throw 'exit normal-indent))) + ((eq tem 'nil) + (throw 'exit (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start)))) + ((eq tem '&lambda) + (throw 'exit + (cond ((not (common-lisp-looking-back ")")) + ;; If it's not a list at all, indent it + ;; like body instead. + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent)) + ((common-lisp-lambda-list-initial-value-form-p + indent-point) + (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start))) + ((null p) + (list (+ sexp-column 4) containing-form-start)) + (t + ;; Indentation within a lambda-list. -- dvl + (list (lisp-indent-lambda-list + indent-point + sexp-column + containing-form-start) + containing-form-start))))) + ((integerp tem) + (throw 'exit + (if (null p) ;not in subforms + (list (+ sexp-column tem) containing-form-start) + normal-indent))) + ((symbolp tem) ;a function to call + (throw 'exit + (funcall tem path state indent-point + sexp-column normal-indent))) + (t + ;; must be a destructing frob + (if p + ;; descend + (setq method (cddr tem) + n (car p) + p (cdr p) + tail nil) + (let ((wholep (eq '&whole (car tem)))) + (setq tem (cadr tem)) + (throw 'exit + (cond (tail + (if (and wholep (integerp tem) + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (looking-at "\\sw"))) + ;; There's a further level of + ;; destructuring, but we're looking at a + ;; word -- indent to sexp. + (+ sexp-column tem) + normal-indent)) + ((not tem) + (list normal-indent + containing-form-start)) + ((integerp tem) + (list (+ sexp-column tem) + containing-form-start)) + (t + (funcall tem path state indent-point + sexp-column normal-indent)))))))))))) + +(defun lisp-indent-tagbody (path state indent-point sexp-column normal-indent) + (if (not (null (cdr path))) + normal-indent + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (list (cond ((looking-at "\\sw\\|\\s_") + ;; a tagbody tag + (+ sexp-column lisp-tag-indentation)) + ((integerp lisp-tag-body-indentation) + (+ sexp-column lisp-tag-body-indentation)) + ((eq lisp-tag-body-indentation 't) + (condition-case () + (progn (backward-sexp 1) (current-column)) + (error (1+ sexp-column)))) + (t (+ sexp-column lisp-body-indent))) +; (cond ((integerp lisp-tag-body-indentation) +; (+ sexp-column lisp-tag-body-indentation)) +; ((eq lisp-tag-body-indentation 't) +; normal-indent) +; (t +; (+ sexp-column lisp-body-indent))) + (elt state 1) + )))) + +(defun lisp-indent-do (path state indent-point sexp-column normal-indent) + (if (>= (car path) 3) + (let ((lisp-tag-body-indentation lisp-body-indent)) + (funcall (function lisp-indent-tagbody) + path state indent-point sexp-column normal-indent)) + (funcall (function lisp-indent-259) + '((&whole nil &rest + ;; the following causes weird indentation + ;;(&whole 1 1 2 nil) + ) + (&whole nil &rest 1)) + path state indent-point sexp-column normal-indent))) + +(defun lisp-indent-defsetf + (path state indent-point sexp-column normal-indent) + (list + (cond + ;; Inside the lambda-list in a long-form defsetf. + ((and (eql 2 (car path)) (cdr path)) + (lisp-indent-lambda-list indent-point sexp-column (elt state 1))) + ;; Long form: has a lambda-list. + ((or (cdr path) + (save-excursion + (goto-char (elt state 1)) + (ignore-errors + (down-list) + (forward-sexp 3) + (backward-sexp) + (looking-at "nil\\|(")))) + (+ sexp-column + (case (car path) + ((1 3) 4) + (2 4) + (t 2)))) + ;; Short form. + (t + (+ sexp-column + (case (car path) + (1 4) + (2 4) + (t 2))))) + (elt state 1))) + +(defun lisp-beginning-of-defmethod-qualifiers () + (let ((regexp-1 "(defmethod\\|(DEFMETHOD") + (regexp-2 "(:method\\|(:METHOD")) + (while (and (not (or (looking-at regexp-1) + (looking-at regexp-2))) + (ignore-errors (backward-up-list) t))) + (cond ((looking-at regexp-1) + (forward-char) + ;; Skip name. + (forward-sexp 2) + 1) + ((looking-at regexp-2) + (forward-char) + (forward-sexp 1) + 0)))) + +;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method +;; qualifier and indents the method's lambda list properly. -- dvl +(defun lisp-indent-defmethod + (path state indent-point sexp-column normal-indent) + (lisp-indent-259 + (let ((nskip nil)) + (if (save-excursion + (when (setq nskip (lisp-beginning-of-defmethod-qualifiers)) + (skip-chars-forward " \t\n") + (while (looking-at "\\sw\\|\\s_") + (incf nskip) + (forward-sexp) + (skip-chars-forward " \t\n")) + t)) + (append (make-list nskip 4) '(&lambda &body)) + (common-lisp-get-indentation 'defun))) + path state indent-point sexp-column normal-indent)) + +(defun lisp-indent-function-lambda-hack (path state indent-point + sexp-column normal-indent) + ;; indent (function (lambda () )) kludgily. + (if (or (cdr path) ; wtf? + (> (car path) 3)) + ;; line up under previous body form + normal-indent + ;; line up under function rather than under lambda in order to + ;; conserve horizontal space. (Which is what #' is for.) + (condition-case () + (save-excursion + (backward-up-list 2) + (forward-char 1) + (if (looking-at "\\(lisp:+\\)?function\\(\\Sw\\|\\S_\\)") + (+ lisp-body-indent -1 (current-column)) + (+ sexp-column lisp-body-indent))) + (error (+ sexp-column lisp-body-indent))))) + +(defun lisp-indent-loop (path state indent-point sexp-column normal-indent) + (if (cdr path) + normal-indent + (let* ((loop-start (elt state 1)) + (type (common-lisp-loop-type loop-start))) + (cond ((and lisp-loop-indent-subclauses + (member type '(extended extended/split))) + (list (common-lisp-indent-loop-macro-1 state indent-point) + (common-lisp-indent-parse-state-start state))) + (t + (common-lisp-loop-part-indentation indent-point state type)))))) + +;;;; LOOP indentation, the complex version -- handles subclause indentation + +;; Regexps matching various varieties of loop macro keyword ... +(defvar common-lisp-body-introducing-loop-macro-keyword + "\\(#?:\\)?\\(do\\(ing\\)?\\|finally\\|initially\\)" + "Regexp matching loop macro keywords which introduce body forms.") + +;; Not currenctly used +(defvar common-lisp-accumlation-loop-macro-keyword + "\\(#?:\\)?\\(collect\\(ing\\)?\\|append\\(ing\\)?\\|nconc\\(ing\\)?\\|\ +count\\(ing\\)?\\|sum\\(ming\\)?\\|maximiz\\(e\\|ing\\)\\|\ +minimiz\\(e\\|ing\\)\\)" + "Regexp matching loop macro keywords which introduce accumulation clauses.") + +;; This is so "and when" and "else when" get handled right +;; (not to mention "else do" !!!) +(defvar common-lisp-prefix-loop-macro-keyword + "\\(#?:\\)?\\(and\\|else\\)" + "Regexp matching loop macro keywords which are prefixes.") + +(defvar common-lisp-indent-clause-joining-loop-macro-keyword + "\\(#?:\\)?and" + "Regexp matching 'and', and anything else there ever comes to be like it.") + +(defvar common-lisp-indent-indented-loop-macro-keyword + "\\(#?:\\)?\\(\\(up\\|down\\)?(from\\|to)\\|below\\|above\\|in\\(to\\)?\\|\ +on\\|=\\|then\\|across\\|being\\|each\\|the\\|of\\|using\\|\ +\\(present-\\|external-\\)?symbols?\\|fixnum\\|float\\|t\\|nil\\|of-type\\)" + "Regexp matching keywords introducing loop subclauses. +Always indented two.") + +(defvar common-lisp-indenting-loop-macro-keyword + "\\(#?:\\)?\\(when\\|unless\\|if\\)" + "Regexp matching keywords introducing conditional clauses. +Cause subsequent clauses to be indented.") + +(defvar common-lisp-loop-macro-else-keyword "\\(#?:\\)?else") + +;;; Attempt to indent the loop macro ... + +(defun common-lisp-indent-parse-state-depth (parse-state) + (car parse-state)) + +(defun common-lisp-indent-parse-state-start (parse-state) + (car (cdr parse-state))) + +(defun common-lisp-indent-parse-state-prev (parse-state) + (car (cdr (cdr parse-state)))) + +(defun common-lisp-loop-part-indentation (indent-point state type) + "Compute the indentation of loop form constituents." + (let* ((loop-start (elt state 1)) + (loop-indentation (save-excursion + (goto-char loop-start) + (if (eq type 'extended/split) + (- (current-column) 4) + (current-column)))) + (indent nil) + (re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)")) + (goto-char indent-point) + (back-to-indentation) + (cond ((eq type 'simple/split) + (+ loop-indentation lisp-simple-loop-indentation)) + ((eq type 'simple) + (+ loop-indentation 6)) + ;; We are already in a body, with forms in it. + ((and (not (looking-at re)) + (save-excursion + (while (and (ignore-errors (backward-sexp) t) + (not (looking-at re))) + (setq indent (current-column))) + (when (and indent + (looking-at + common-lisp-body-introducing-loop-macro-keyword)) + t))) + (list indent loop-start)) + ;; Keyword-style or comment outside body + ((or lisp-loop-indent-forms-like-keywords + (looking-at re) + (looking-at ";")) + (if (and (looking-at ";") + (let ((p (common-lisp-trailing-comment))) + (when p + (setq loop-indentation p)))) + (list loop-indentation loop-start) + (list (+ loop-indentation 6) loop-start))) + ;; Form-style + (t + (list (+ loop-indentation 9) loop-start))))) + +(defun common-lisp-indent-loop-macro-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of loop macro, and use it to establish + ;; base column for indentation + (goto-char (common-lisp-indent-parse-state-start parse-state)) + (let ((loop-start-column (current-column))) + (common-lisp-loop-advance-past-keyword-on-line) + + (when (eolp) + (forward-line 1) + (end-of-line) + ;; If indenting first line after "(loop " + ;; cop out ... + (if (<= indent-point (point)) + (throw 'return-indentation (+ lisp-loop-clauses-indentation + loop-start-column))) + (back-to-indentation)) + + (let* ((case-fold-search t) + (loop-macro-first-clause (point)) + (previous-expression-start + (common-lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (loop-body-p nil) + (loop-body-indentation nil) + (indented-clause-indentation (+ 2 default-value))) + ;; Determine context of this loop clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + + ;; Handle a body-introducing-clause which ends a line specially. + (if (looking-at common-lisp-body-introducing-loop-macro-keyword) + (let ((keyword-position (current-column))) + (setq loop-body-p t) + (setq loop-body-indentation + (if (common-lisp-loop-advance-past-keyword-on-line) + (current-column) + (back-to-indentation) + (if (/= (current-column) keyword-position) + (+ 2 (current-column)) + (+ lisp-loop-body-forms-indentation + (if lisp-loop-indent-body-forms-relative-to-loop-start + loop-start-column + keyword-position)))))) + + (back-to-indentation) + (if (< (point) loop-macro-first-clause) + (goto-char loop-macro-first-clause)) + ;; If there's an "and" or "else," advance over it. + ;; If it is alone on the line, the next "cond" will treat it + ;; as if there were a "when" and indent under it ... + (let ((exit nil)) + (while (and (null exit) + (looking-at common-lisp-prefix-loop-macro-keyword)) + (if (null (common-lisp-loop-advance-past-keyword-on-line)) + (progn (setq exit t) + (back-to-indentation))))) + + ;; Found start of loop clause preceding the one we're + ;; trying to indent. Glean context ... + (cond + ((looking-at "(") + ;; We're in the middle of a clause body ... + (setq loop-body-p t) + (setq loop-body-indentation (current-column))) + ((looking-at common-lisp-body-introducing-loop-macro-keyword) + (setq loop-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (common-lisp-loop-advance-past-keyword-on-line) + (setq loop-body-indentation (current-column))) + (t + (setq loop-body-p nil) + (if (or (looking-at common-lisp-indenting-loop-macro-keyword) + (looking-at common-lisp-prefix-loop-macro-keyword)) + (setq default-value (+ 2 (current-column)))) + (setq indented-clause-indentation (+ 2 (current-column))) + ;; We still need loop-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq loop-body-indentation (current-column))))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((looking-at "(") + ;; Clause body ... + loop-body-indentation) + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if loop-body-p + loop-body-indentation + (or (and (looking-at ";") (common-lisp-trailing-comment)) + default-value))) + ((looking-at common-lisp-indent-indented-loop-macro-keyword) + indented-clause-indentation) + ((looking-at common-lisp-indent-clause-joining-loop-macro-keyword) + (let ((stolen-indent-column nil)) + (forward-line -1) + (while (and (null stolen-indent-column) + (> (point) loop-macro-first-clause)) + (back-to-indentation) + (if (and (< (current-column) loop-body-indentation) + (looking-at "\\(#?:\\)?\\sw")) + (progn + (if (looking-at common-lisp-loop-macro-else-keyword) + (common-lisp-loop-advance-past-keyword-on-line)) + (setq stolen-indent-column + (current-column))) + (forward-line -1))) + (if stolen-indent-column + stolen-indent-column + default-value))) + (t default-value))))))) + +(defun common-lisp-loop-advance-past-keyword-on-line () + (forward-word 1) + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1)) + (if (eolp) + nil + (current-column))) + +;;;; IF* is not standard, but a plague upon the land +;;;; ...let's at least try to indent it. + +(defvar common-lisp-indent-if*-keyword + "threnret\\|elseif\\|then\\|else" + "Regexp matching if* keywords") + +(defun common-lisp-indent-if* + (path parse-state indent-point sexp-column normal-indent) + (list (common-lisp-indent-if*-1 parse-state indent-point) + (common-lisp-indent-parse-state-start parse-state))) + +(defun common-lisp-indent-if*-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of if* macro, and use it to establish + ;; base column for indentation + (goto-char (common-lisp-indent-parse-state-start parse-state)) + (let ((if*-start-column (current-column))) + (common-lisp-indent-if*-advance-past-keyword-on-line) + (let* ((case-fold-search t) + (if*-first-clause (point)) + (previous-expression-start + (common-lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (if*-body-p nil) + (if*-body-indentation nil)) + ;; Determine context of this if* clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + ;; Handle a body-introducing-clause which ends a line specially. + (back-to-indentation) + (if (< (point) if*-first-clause) + (goto-char if*-first-clause)) + ;; Found start of if* clause preceding the one we're trying + ;; to indent. Glean context ... + (cond + ((looking-at common-lisp-indent-if*-keyword) + (setq if*-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (common-lisp-indent-if*-advance-past-keyword-on-line) + (setq if*-body-indentation (current-column))) + ((looking-at "#'\\|'\\|(") + ;; We're in the middle of a clause body ... + (setq if*-body-p t) + (setq if*-body-indentation (current-column))) + (t + (setq if*-body-p nil) + ;; We still need if*-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq if*-body-indentation (current-column)))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if if*-body-p + if*-body-indentation + default-value)) + ((not (looking-at common-lisp-indent-if*-keyword)) + ;; Clause body ... + if*-body-indentation) + (t + (- (+ 7 if*-start-column) + (- (match-end 0) (match-beginning 0)))))))))) + +(defun common-lisp-indent-if*-advance-past-keyword-on-line () + (forward-word 1) + (block move-forward + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1))) + (if (eolp) + nil + (current-column))) + + +;;;; Indentation specs for standard symbols, and a few semistandard ones. +(defun common-lisp-init-standard-indentation () + (let ((l '((block 1) + (case (4 &rest (&whole 2 &rest 1))) + (ccase (as case)) + (ecase (as case)) + (typecase (as case)) + (etypecase (as case)) + (ctypecase (as case)) + (catch 1) + (cond (&rest (&whole 2 &rest nil))) + ;; for DEFSTRUCT + (:constructor (4 &lambda)) + (defvar (4 2 2)) + (defclass (6 (&whole 4 &rest 1) + (&whole 2 &rest 1) + (&whole 2 &rest 1))) + (defconstant (as defvar)) + (defcustom (4 2 2 2)) + (defparameter (as defvar)) + (defconst (as defcustom)) + (define-condition (as defclass)) + (define-modify-macro (4 &lambda &body)) + (defsetf lisp-indent-defsetf) + (defun (4 &lambda &body)) + (defgeneric (4 &lambda &body)) + (define-setf-method (as defun)) + (define-setf-expander (as defun)) + (defmacro (as defun)) + (defsubst (as defun)) + (deftype (as defun)) + (defmethod lisp-indent-defmethod) + (defpackage (4 2)) + (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) + &rest (&whole 2 &rest 1))) + (destructuring-bind (&lambda 4 &body)) + (do lisp-indent-do) + (do* (as do)) + (dolist ((&whole 4 2 1) &body)) + (dotimes (as dolist)) + (eval-when 1) + (flet ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body)) + (labels (as flet)) + (macrolet (as flet)) + (generic-flet (as flet)) + (generic-labels (as flet)) + (handler-case (4 &rest (&whole 2 &lambda &body))) + (restart-case (as handler-case)) + ;; single-else style (then and else equally indented) + (if (&rest nil)) + (if* common-lisp-indent-if*) + (lambda (&lambda &rest lisp-indent-function-lambda-hack)) + (let ((&whole 4 &rest (&whole 1 1 2)) &body)) + (let* (as let)) + (compiler-let (as let)) + (handler-bind (as let)) + (restart-bind (as let)) + (locally 1) + (loop lisp-indent-loop) + (:method lisp-indent-defmethod) ; in `defgeneric' + (multiple-value-bind ((&whole 6 &rest 1) 4 &body)) + (multiple-value-call (4 &body)) + (multiple-value-prog1 1) + (multiple-value-setq (4 2)) + (multiple-value-setf (as multiple-value-setq)) + (named-lambda (4 &lambda &rest lisp-indent-function-lambda-hack)) + (pprint-logical-block (4 2)) + (print-unreadable-object ((&whole 4 1 &rest 1) &body)) + ;; Combines the worst features of BLOCK, LET and TAGBODY + (prog (&lambda &rest lisp-indent-tagbody)) + (prog* (as prog)) + (prog1 1) + (prog2 2) + (progn 0) + (progv (4 4 &body)) + (return 0) + (return-from (nil &body)) + (symbol-macrolet (as let)) + (tagbody lisp-indent-tagbody) + (throw 1) + (unless 1) + (unwind-protect (5 &body)) + (when 1) + (with-accessors (as multiple-value-bind)) + (with-compilation-unit ((&whole 4 &rest 1) &body)) + (with-condition-restarts (as multiple-value-bind)) + (with-output-to-string (4 2)) + (with-slots (as multiple-value-bind)) + (with-standard-io-syntax (2))))) + (dolist (el l) + (let* ((name (car el)) + (spec (cdr el)) + (indentation + (if (symbolp spec) + (error "Old style indirect indentation spec: %s" el) + (when (cdr spec) + (error "Malformed indentation specification: %s" el)) + (car spec)))) + (unless (symbolp name) + (error "Cannot set Common Lisp indentation of a non-symbol: %s" + name)) + (put name 'common-lisp-indent-function indentation))))) +(common-lisp-init-standard-indentation) + +(provide 'cl-indent) +(provide 'slime-cl-indent) + +;;; slime-cl-indent.el ends here diff --git a/elpa/slime-20200319.1939/contrib/slime-cl-indent.elc b/elpa/slime-20200319.1939/contrib/slime-cl-indent.elc new file mode 100644 index 00000000..a2da12a5 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-cl-indent.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-clipboard.el b/elpa/slime-20200319.1939/contrib/slime-clipboard.el new file mode 100644 index 00000000..4f5dd17f --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-clipboard.el @@ -0,0 +1,172 @@ +(require 'slime) +(require 'slime-repl) +(require 'cl-lib) +(eval-when-compile + (require 'cl)) ; lexical-let + +(define-slime-contrib slime-clipboard + "This add a few commands to put objects into a clipboard and to +insert textual references to those objects. + +The clipboard command prefix is C-c @. + + C-c @ + adds an object to the clipboard + C-c @ @ inserts a reference to an object in the clipboard + C-c @ ? displays the clipboard + +This package also also binds the + key in the inspector and +debugger to add the object at point to the clipboard." + (:authors "Helmut Eller ") + (:license "GPL") + (:swank-dependencies swank-clipboard)) + +(define-derived-mode slime-clipboard-mode fundamental-mode + "Slime-Clipboard" + "SLIME Clipboad Mode. + +\\{slime-clipboard-mode-map}") + +(slime-define-keys slime-clipboard-mode-map + ("g" 'slime-clipboard-redisplay) + ((kbd "C-k") 'slime-clipboard-delete-entry) + ("i" 'slime-clipboard-inspect)) + +(defvar slime-clipboard-map (make-sparse-keymap)) + +(slime-define-keys slime-clipboard-map + ("?" 'slime-clipboard-display) + ("+" 'slime-clipboard-add) + ("@" 'slime-clipboard-ref)) + +(define-key slime-mode-map (kbd "C-c @") slime-clipboard-map) +(define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map) + +(slime-define-keys slime-inspector-mode-map + ("+" 'slime-clipboard-add-from-inspector)) + +(slime-define-keys sldb-mode-map + ("+" 'slime-clipboard-add-from-sldb)) + +(defun slime-clipboard-add (exp package) + "Add an object to the clipboard." + (interactive (list (slime-read-from-minibuffer + "Add to clipboard (evaluated): " + (slime-sexp-at-point)) + (slime-current-package))) + (slime-clipboard-add-internal `(:string ,exp ,package))) + +(defun slime-clipboard-add-internal (datum) + (slime-eval-async `(swank-clipboard:add ',datum) + (lambda (result) (message "%s" result)))) + +(defun slime-clipboard-display () + "Display the content of the clipboard." + (interactive) + (slime-eval-async `(swank-clipboard:entries) + #'slime-clipboard-display-entries)) + +(defun slime-clipboard-display-entries (entries) + (slime-with-popup-buffer ((slime-buffer-name :clipboard) + :mode 'slime-clipboard-mode) + (slime-clipboard-insert-entries entries))) + +(defun slime-clipboard-insert-entries (entries) + (let ((fstring "%2s %3s %s\n")) + (insert (format fstring "Nr" "Id" "Value") + (format fstring "--" "--" "-----" )) + (save-excursion + (cl-loop for i from 0 for (ref . value) in entries do + (slime-insert-propertized `(slime-clipboard-entry ,i + slime-clipboard-ref ,ref) + (format fstring i ref value)))))) + +(defun slime-clipboard-redisplay () + "Update the clipboard buffer." + (interactive) + (lexical-let ((saved (point))) + (slime-eval-async + `(swank-clipboard:entries) + (lambda (entries) + (let ((inhibit-read-only t)) + (erase-buffer) + (slime-clipboard-insert-entries entries) + (when (< saved (point-max)) + (goto-char saved))))))) + +(defun slime-clipboard-entry-at-point () + (or (get-text-property (point) 'slime-clipboard-entry) + (error "No clipboard entry at point"))) + +(defun slime-clipboard-ref-at-point () + (or (get-text-property (point) 'slime-clipboard-ref) + (error "No clipboard ref at point"))) + +(defun slime-clipboard-inspect (&optional entry) + "Inspect the current clipboard entry." + (interactive (list (slime-clipboard-ref-at-point))) + (slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry)))) + +(defun slime-clipboard-delete-entry (&optional entry) + "Delete the current entry from the clipboard." + (interactive (list (slime-clipboard-entry-at-point))) + (slime-eval-async `(swank-clipboard:delete-entry ,entry) + (lambda (result) + (slime-clipboard-redisplay) + (message "%s" result)))) + +(defun slime-clipboard-ref () + "Ask for a clipboard entry number and insert a reference to it." + (interactive) + (slime-clipboard-read-entry-number #'slime-clipboard-insert-ref)) + +;; insert a reference to clipboard entry ENTRY at point. The text +;; receives a special 'display property to make it look nicer. We +;; remove this property in a modification when a user tries to modify +;; he real text. +(defun slime-clipboard-insert-ref (entry) + (cl-destructuring-bind (ref . string) + (slime-eval `(swank-clipboard:entry-to-ref ,entry)) + (slime-insert-propertized + `(display ,(format "#@%d%s" ref string) + modification-hooks (slime-clipboard-ref-modified) + rear-nonsticky t) + (format "(swank-clipboard::clipboard-ref %d)" ref)))) + +(defun slime-clipboard-ref-modified (start end) + (when (get-text-property start 'display) + (let ((inhibit-modification-hooks t)) + (save-excursion + (goto-char start) + (cl-destructuring-bind (dstart dend) (slime-property-bounds 'display) + (unless (and (= start dstart) (= end dend)) + (remove-list-of-text-properties + dstart dend '(display modification-hooks)))))))) + +;; Read a entry number. +;; Written in CPS because the display the clipboard before reading. +(defun slime-clipboard-read-entry-number (k) + (slime-eval-async + `(swank-clipboard:entries) + (slime-rcurry + (lambda (entries window-config k) + (slime-clipboard-display-entries entries) + (let ((entry (unwind-protect + (read-from-minibuffer "Entry number: " nil nil t) + (set-window-configuration window-config)))) + (funcall k entry))) + (current-window-configuration) + k))) + +(defun slime-clipboard-add-from-inspector () + (interactive) + (let ((part (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-clipboard-add-internal `(:inspector ,part)))) + +(defun slime-clipboard-add-from-sldb () + (interactive) + (slime-clipboard-add-internal + `(:sldb ,(sldb-frame-number-at-point) + ,(sldb-var-number-at-point)))) + +(provide 'slime-clipboard) diff --git a/elpa/slime-20200319.1939/contrib/slime-clipboard.elc b/elpa/slime-20200319.1939/contrib/slime-clipboard.elc new file mode 100644 index 00000000..00976f4c Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-clipboard.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.el b/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.el new file mode 100644 index 00000000..bada587d --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.el @@ -0,0 +1,184 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-compiler-notes-tree + "Display compiler messages in tree layout. + +M-x slime-list-compiler-notes display the compiler notes in a tree +grouped by severity. + + `slime-maybe-list-compiler-notes' can be used as + `slime-compilation-finished-hook'. +" + (:authors "Helmut Eller ") + (:license "GPL")) + +(defun slime-maybe-list-compiler-notes (notes) + "Show the compiler notes if appropriate." + ;; don't pop up a buffer if all notes are already annotated in the + ;; buffer itself + (unless (cl-every #'slime-note-has-location-p notes) + (slime-list-compiler-notes notes))) + +(defun slime-list-compiler-notes (notes) + "Show the compiler notes NOTES in tree view." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Preparing compiler note tree..." + (slime-with-popup-buffer ((slime-buffer-name :notes) + :mode 'slime-compiler-notes-mode) + (when (null notes) + (insert "[no notes]")) + (let ((collapsed-p)) + (dolist (tree (slime-compiler-notes-to-tree notes)) + (when (slime-tree.collapsed-p tree) (setf collapsed-p t)) + (slime-tree-insert tree "") + (insert "\n")) + (goto-char (point-min)))))) + +(defvar slime-tree-printer 'slime-tree-default-printer) + +(defun slime-tree-for-note (note) + (make-slime-tree :item (slime-note.message note) + :plist (list 'note note) + :print-fn slime-tree-printer)) + +(defun slime-tree-for-severity (severity notes collapsed-p) + (make-slime-tree :item (format "%s (%d)" + (slime-severity-label severity) + (length notes)) + :kids (mapcar #'slime-tree-for-note notes) + :collapsed-p collapsed-p)) + +(defun slime-compiler-notes-to-tree (notes) + (let* ((alist (slime-alistify notes #'slime-note.severity #'eq)) + (collapsed-p (slime-length> alist 1))) + (cl-loop for (severity . notes) in alist + collect (slime-tree-for-severity severity notes + collapsed-p)))) + +(defvar slime-compiler-notes-mode-map) + +(define-derived-mode slime-compiler-notes-mode fundamental-mode + "Compiler-Notes" + "\\\ +\\{slime-compiler-notes-mode-map} +\\{slime-popup-buffer-mode-map} +" + (slime-set-truncate-lines)) + +(slime-define-keys slime-compiler-notes-mode-map + ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) + ([return] 'slime-compiler-notes-default-action-or-show-details) + ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse)) + +(defun slime-compiler-notes-default-action-or-show-details/mouse (event) + "Invoke the action pointed at by the mouse, or show details." + (interactive "e") + (cl-destructuring-bind (mouse-2 (w pos &rest _) &rest __) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) + 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))))) + +(defun slime-compiler-notes-default-action-or-show-details () + "Invoke the action at point, or show details." + (interactive) + (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))) + +(defun slime-compiler-notes-show-details () + (interactive) + (let* ((tree (slime-tree-at-point)) + (note (plist-get (slime-tree.plist tree) 'note)) + (inhibit-read-only t)) + (cond ((not (slime-tree-leaf-p tree)) + (slime-tree-toggle tree)) + (t + (slime-show-source-location (slime-note.location note) t))))) + + +;;;;;; Tree Widget + +(cl-defstruct (slime-tree (:conc-name slime-tree.)) + item + (print-fn #'slime-tree-default-printer :type function) + (kids '() :type list) + (collapsed-p t :type boolean) + (prefix "" :type string) + (start-mark nil) + (end-mark nil) + (plist '() :type list)) + +(defun slime-tree-leaf-p (tree) + (not (slime-tree.kids tree))) + +(defun slime-tree-default-printer (tree) + (princ (slime-tree.item tree) (current-buffer))) + +(defun slime-tree-decoration (tree) + (cond ((slime-tree-leaf-p tree) "-- ") + ((slime-tree.collapsed-p tree) "[+] ") + (t "-+ "))) + +(defun slime-tree-insert-list (list prefix) + "Insert a list of trees." + (cl-loop for (elt . rest) on list + do (cond (rest + (insert prefix " |") + (slime-tree-insert elt (concat prefix " |")) + (insert "\n")) + (t + (insert prefix " `") + (slime-tree-insert elt (concat prefix " ")))))) + +(defun slime-tree-insert-decoration (tree) + (insert (slime-tree-decoration tree))) + +(defun slime-tree-indent-item (start end prefix) + "Insert PREFIX at the beginning of each but the first line. +This is used for labels spanning multiple lines." + (save-excursion + (goto-char end) + (beginning-of-line) + (while (< start (point)) + (insert-before-markers prefix) + (forward-line -1)))) + +(defun slime-tree-insert (tree prefix) + "Insert TREE prefixed with PREFIX at point." + (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree + (let ((line-start (line-beginning-position))) + (setf start-mark (point-marker)) + (slime-tree-insert-decoration tree) + (funcall print-fn tree) + (slime-tree-indent-item start-mark (point) (concat prefix " ")) + (add-text-properties line-start (point) (list 'slime-tree tree)) + (set-marker-insertion-type start-mark t) + (when (and kids (not collapsed-p)) + (terpri (current-buffer)) + (slime-tree-insert-list kids prefix)) + (setf (slime-tree.prefix tree) prefix) + (setf end-mark (point-marker))))) + +(defun slime-tree-at-point () + (cond ((get-text-property (point) 'slime-tree)) + (t (error "No tree at point")))) + +(defun slime-tree-delete (tree) + "Delete the region for TREE." + (delete-region (slime-tree.start-mark tree) + (slime-tree.end-mark tree))) + +(defun slime-tree-toggle (tree) + "Toggle the visibility of TREE's children." + (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree + (setf collapsed-p (not collapsed-p)) + (slime-tree-delete tree) + (insert-before-markers " ") ; move parent's end-mark + (backward-char 1) + (slime-tree-insert tree prefix) + (delete-char 1) + (goto-char start-mark))) + +(provide 'slime-compiler-notes-tree) diff --git a/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.elc b/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.elc new file mode 100644 index 00000000..130ae3ff Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-compiler-notes-tree.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-editing-commands.el b/elpa/slime-20200319.1939/contrib/slime-editing-commands.el new file mode 100644 index 00000000..db7bb01e --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-editing-commands.el @@ -0,0 +1,183 @@ +(require 'slime) +(require 'slime-repl) +(require 'cl-lib) + +(define-slime-contrib slime-editing-commands + "Editing commands without server interaction." + (:authors "Thomas F. Burdick " + "Luke Gorrie " + "Bill Clementson " + "Tobias C. Rittweiler ") + (:license "GPL") + (:on-load + (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun) + (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun) + (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun) + (define-key slime-mode-map "\C-c\C-]" 'slime-close-all-parens-in-sexp))) + +(defun slime-beginning-of-defun () + (interactive) + (if (and (boundp 'slime-repl-input-start-mark) + slime-repl-input-start-mark) + (slime-repl-beginning-of-defun) + (let ((this-command 'beginning-of-defun)) ; needed for push-mark + (call-interactively 'beginning-of-defun)))) + +(defun slime-end-of-defun () + (interactive) + (if (eq major-mode 'slime-repl-mode) + (slime-repl-end-of-defun) + (end-of-defun))) + +(defvar slime-comment-start-regexp + "\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*" + "Regexp to match the start of a comment.") + +(defun slime-beginning-of-comment () + "Move point to beginning of comment. +If point is inside a comment move to beginning of comment and return point. +Otherwise leave point unchanged and return NIL." + (let ((boundary (point))) + (beginning-of-line) + (cond ((re-search-forward slime-comment-start-regexp boundary t) + (point)) + (t (goto-char boundary) + nil)))) + +(defvar slime-close-parens-limit nil + "Maxmimum parens for `slime-close-all-sexp' to insert. NIL +means to insert as many parentheses as necessary to correctly +close the form.") + +(defun slime-close-all-parens-in-sexp (&optional region) + "Balance parentheses of open s-expressions at point. +Insert enough right parentheses to balance unmatched left parentheses. +Delete extra left parentheses. Reformat trailing parentheses +Lisp-stylishly. + +If REGION is true, operate on the region. Otherwise operate on +the top-level sexp before point." + (interactive "P") + (let ((sexp-level 0) + point) + (save-excursion + (save-restriction + (when region + (narrow-to-region (region-beginning) (region-end)) + (goto-char (point-max))) + ;; skip over closing parens, but not into comment + (skip-chars-backward ") \t\n") + (when (slime-beginning-of-comment) + (forward-line) + (skip-chars-forward " \t")) + (setq point (point)) + ;; count sexps until either '(' or comment is found at first column + (while (and (not (looking-at "^[(;]")) + (ignore-errors (backward-up-list 1) t)) + (incf sexp-level)))) + (when (> sexp-level 0) + ;; insert correct number of right parens + (goto-char point) + (dotimes (i sexp-level) (insert ")")) + ;; delete extra right parens + (setq point (point)) + (skip-chars-forward " \t\n)") + (skip-chars-backward " \t\n") + (let* ((deleted-region (delete-and-extract-region point (point))) + (deleted-text (substring-no-properties deleted-region)) + (prior-parens-count (cl-count ?\) deleted-text))) + ;; Remember: we always insert as many parentheses as necessary + ;; and only afterwards delete the superfluously-added parens. + (when slime-close-parens-limit + (let ((missing-parens (- sexp-level prior-parens-count + slime-close-parens-limit))) + (dotimes (i (max 0 missing-parens)) + (delete-char -1)))))))) + +(defun slime-insert-balanced-comments (arg) + "Insert a set of balanced comments around the s-expression +containing the point. If this command is invoked repeatedly +\(without any other command occurring between invocations), the +comment progressively moves outward over enclosing expressions. +If invoked with a positive prefix argument, the s-expression arg +expressions out is enclosed in a set of balanced comments." + (interactive "*p") + (save-excursion + (when (eq last-command this-command) + (when (search-backward "#|" nil t) + (save-excursion + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + (while (> arg 0) + (backward-char 1) + (cond ((looking-at ")") (incf arg)) + ((looking-at "(") (decf arg)))) + (insert "#|") + (forward-sexp) + (insert "|#"))) + +(defun slime-remove-balanced-comments () + "Remove a set of balanced comments enclosing point." + (interactive "*") + (save-excursion + (when (search-backward "#|" nil t) + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + + +;; SLIME-CLOSE-PARENS-AT-POINT is obsolete: + +;; It doesn't work correctly on the REPL, because there +;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to +;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and +;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the +;; way how they're expect to work (i.e. END-OF-DEFUN does not signal +;; an UNBOUND-PARENTHESES error.) + +;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead. + +;; (defun slime-close-parens-at-point () +;; "Close parenthesis at point to complete the top-level-form. Simply +;; inserts ')' characters at point until `beginning-of-defun' and +;; `end-of-defun' execute without errors, or `slime-close-parens-limit' +;; is exceeded." +;; (interactive) +;; (loop for i from 1 to slime-close-parens-limit +;; until (save-excursion +;; (slime-beginning-of-defun) +;; (ignore-errors (slime-end-of-defun) t)) +;; do (insert ")"))) + +(defun slime-reindent-defun (&optional force-text-fill) + "Reindent the current defun, or refill the current paragraph. +If point is inside a comment block, the text around point will be +treated as a paragraph and will be filled with `fill-paragraph'. +Otherwise, it will be treated as Lisp code, and the current defun +will be reindented. If the current defun has unbalanced parens, +an attempt will be made to fix it before reindenting. + +When given a prefix argument, the text around point will always +be treated as a paragraph. This is useful for filling docstrings." + (interactive "P") + (save-excursion + (if (or force-text-fill (slime-beginning-of-comment)) + (fill-paragraph nil) + (let ((start (progn (unless (or (and (zerop (current-column)) + (eq ?\( (char-after))) + (and slime-repl-input-start-mark + (slime-repl-at-prompt-start-p))) + (slime-beginning-of-defun)) + (point))) + (end (ignore-errors (slime-end-of-defun) (point)))) + (unless end + (forward-paragraph) + (slime-close-all-parens-in-sexp) + (slime-end-of-defun) + (setf end (point))) + (indent-region start end nil))))) + +(provide 'slime-editing-commands) diff --git a/elpa/slime-20200319.1939/contrib/slime-editing-commands.elc b/elpa/slime-20200319.1939/contrib/slime-editing-commands.elc new file mode 100644 index 00000000..9c54fcaf Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-editing-commands.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-enclosing-context.el b/elpa/slime-20200319.1939/contrib/slime-enclosing-context.el new file mode 100644 index 00000000..53cee76a --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-enclosing-context.el @@ -0,0 +1,226 @@ +(require 'slime) +(require 'slime-parse) +(require 'cl-lib) + +(define-slime-contrib slime-enclosing-context + "Utilities on top of slime-parse." + (:authors "Tobias C. Rittweiler ") + (:license "GPL")) + +(defun slime-parse-sexp-at-point (&optional n) + "Returns the sexps at point as a list of strings, otherwise nil. +\(If there are not as many sexps as N, a list with < N sexps is +returned.\) +If SKIP-BLANKS-P is true, leading whitespaces &c are skipped. +" + (interactive "p") (or n (setq n 1)) + (save-excursion + (let ((result nil)) + (dotimes (i n) + ;; Is there an additional sexp in front of us? + (save-excursion + (unless (slime-point-moves-p (ignore-errors (forward-sexp))) + (cl-return))) + (push (slime-sexp-at-point) result) + ;; Skip current sexp + (ignore-errors (forward-sexp) (skip-chars-forward "[:space:]"))) + (nreverse result)))) + +(defun slime-has-symbol-syntax-p (string) + (if (and string (not (zerop (length string)))) + (member (char-syntax (aref string 0)) + '(?w ?_ ?\' ?\\)))) + +(defun slime-beginning-of-string () + (let* ((parser-state (slime-current-parser-state)) + (inside-string-p (nth 3 parser-state)) + (string-start-pos (nth 8 parser-state))) + (if inside-string-p + (goto-char string-start-pos) + (error "We're not within a string")))) + +(defun slime-enclosing-form-specs (&optional max-levels) + "Return the list of ``raw form specs'' of all the forms +containing point from right to left. + +As a secondary value, return a list of indices: Each index tells +for each corresponding form spec in what argument position the +user's point is. + +As tertiary value, return the positions of the operators that are +contained in the returned form specs. + +When MAX-LEVELS is non-nil, go up at most this many levels of +parens. + +\(See SWANK::PARSE-FORM-SPEC for more information about what +exactly constitutes a ``raw form specs'') + +Examples: + + A return value like the following + + (values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3)) + + can be interpreted as follows: + + The user point is located in the 3rd argument position of a + form with the operator name \"quux\" (which starts at P1.) + + This form is located in the 2nd argument position of a form + with the operator name \"bar\" (which starts at P2.) + + This form again is in the 1st argument position of a form + with the operator name \"foo\" (which itself begins at P3.) + + For instance, the corresponding buffer content could have looked + like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point. +" + (let ((level 1) + (parse-sexp-lookup-properties nil) + (initial-point (point)) + (result '()) (arg-indices '()) (points '())) + ;; The expensive lookup of syntax-class text properties is only + ;; used for interactive balancing of #<...> in presentations; we + ;; do not need them in navigating through the nested lists. + ;; This speeds up this function significantly. + (ignore-errors + (save-excursion + ;; Make sure we get the whole thing at point. + (if (not (slime-inside-string-p)) + (slime-end-of-symbol) + (slime-beginning-of-string) + (forward-sexp)) + (save-restriction + ;; Don't parse more than 20000 characters before point, so we don't spend + ;; too much time. + (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) + (narrow-to-region (save-excursion (beginning-of-defun) (point)) + (min (1+ (point)) (point-max))) + (while (or (not max-levels) + (<= level max-levels)) + (let ((arg-index 0)) + ;; Move to the beginning of the current sexp if not already there. + (if (or (and (char-after) + (member (char-syntax (char-after)) '(?\( ?'))) + (member (char-syntax (char-before)) '(?\ ?>))) + (cl-incf arg-index)) + (ignore-errors (backward-sexp 1)) + (while (and (< arg-index 64) + (ignore-errors (backward-sexp 1) + (> (point) (point-min)))) + (cl-incf arg-index)) + (backward-up-list 1) + (when (member (char-syntax (char-after)) '(?\( ?')) + (cl-incf level) + (forward-char 1) + (let ((name (slime-symbol-at-point))) + (push (and name `(,name)) result) + (push arg-index arg-indices) + (push (point) points)) + (backward-up-list 1))))))) + (cl-values + (nreverse result) + (nreverse arg-indices) + (nreverse points)))) + +(defvar slime-variable-binding-ops-alist + '((let &bindings &body) + (let* &bindings &body))) + +(defvar slime-function-binding-ops-alist + '((flet &bindings &body) + (labels &bindings &body) + (macrolet &bindings &body))) + +(defun slime-lookup-binding-op (op &optional binding-type) + (cl-labels ((lookup-in (list) (cl-assoc op list :test 'cl-equalp :key 'symbol-name))) + (cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist)) + ((eq binding-type :function) (lookup-in slime-function-binding-ops-alist)) + (t (or (lookup-in slime-variable-binding-ops-alist) + (lookup-in slime-function-binding-ops-alist)))))) + +(defun slime-binding-op-p (op &optional binding-type) + (and (slime-lookup-binding-op op binding-type) t)) + +(defun slime-binding-op-body-pos (op) + (let ((special-lambda-list (slime-lookup-binding-op op))) + (if special-lambda-list (cl-position '&body special-lambda-list)))) + +(defun slime-binding-op-bindings-pos (op) + (let ((special-lambda-list (slime-lookup-binding-op op))) + (if special-lambda-list (cl-position '&bindings special-lambda-list)))) + +(defun slime-enclosing-bound-names () + "Returns all bound function names as first value, and the +points where their bindings are established as second value." + (cl-multiple-value-call #'slime-find-bound-names + (slime-enclosing-form-specs))) + +(defun slime-find-bound-names (ops indices points) + (let ((binding-names) (binding-start-points)) + (save-excursion + (cl-loop for (op . nil) in ops + for index in indices + for point in points + do (when (and (slime-binding-op-p op) + ;; Are the bindings of OP in scope? + (>= index (slime-binding-op-body-pos op))) + (goto-char point) + (forward-sexp (slime-binding-op-bindings-pos op)) + (down-list) + (ignore-errors + (cl-loop + (down-list) + (push (slime-symbol-at-point) binding-names) + (push (save-excursion (backward-up-list) (point)) + binding-start-points) + (up-list))))) + (cl-values (nreverse binding-names) (nreverse binding-start-points))))) + + +(defun slime-enclosing-bound-functions () + (cl-multiple-value-call #'slime-find-bound-functions + (slime-enclosing-form-specs))) + +(defun slime-find-bound-functions (ops indices points) + (let ((names) (arglists) (start-points)) + (save-excursion + (cl-loop for (op . nil) in ops + for index in indices + for point in points + do (when (and (slime-binding-op-p op :function) + ;; Are the bindings of OP in scope? + (>= index (slime-binding-op-body-pos op))) + (goto-char point) + (forward-sexp (slime-binding-op-bindings-pos op)) + (down-list) + ;; If we're at the end of the bindings, an error will + ;; be signalled by the `down-list' below. + (ignore-errors + (cl-loop + (down-list) + (cl-destructuring-bind (name arglist) + (slime-parse-sexp-at-point 2) + (cl-assert (slime-has-symbol-syntax-p name)) + (cl-assert arglist) + (push name names) + (push arglist arglists) + (push (save-excursion (backward-up-list) (point)) + start-points)) + (up-list))))) + (cl-values (nreverse names) + (nreverse arglists) + (nreverse start-points))))) + + +(defun slime-enclosing-bound-macros () + (cl-multiple-value-call #'slime-find-bound-macros + (slime-enclosing-form-specs))) + +(defun slime-find-bound-macros (ops indices points) + ;; Kludgy! + (let ((slime-function-binding-ops-alist '((macrolet &bindings &body)))) + (slime-find-bound-functions ops indices points))) + +(provide 'slime-enclosing-context) diff --git a/elpa/slime-20200319.1939/contrib/slime-enclosing-context.elc b/elpa/slime-20200319.1939/contrib/slime-enclosing-context.elc new file mode 100644 index 00000000..b521078f Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-enclosing-context.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.el b/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.el new file mode 100644 index 00000000..02d01319 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.el @@ -0,0 +1,42 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-fancy-inspector + "Fancy inspector for CLOS objects." + (:authors "Marco Baringer and others") + (:license "GPL") + (:slime-dependencies slime-parse) + (:swank-dependencies swank-fancy-inspector) + (:on-load + (add-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part)) + (:on-unload + (remove-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part))) + +(defun slime-inspect-definition () + "Inspect definition at point" + (interactive) + (slime-inspect (slime-definition-at-point))) + +(defun slime-disassemble-definition () + "Disassemble definition at point" + (interactive) + (slime-eval-describe `(swank:disassemble-form + ,(slime-definition-at-point t)))) + +(defun slime-edit-inspector-part (name &optional where) + (and (eq major-mode 'slime-inspector-mode) + (cl-destructuring-bind (&optional property value) + (slime-inspector-property-at-point) + (when (eq property 'slime-part-number) + (let ((location (slime-eval `(swank:find-definition-for-thing + (swank:inspector-nth-part ,value)))) + (name (format "Inspector part %s" value))) + (when (and (consp location) + (not (eq (car location) :error))) + (slime-edit-definition-cont + (list (make-slime-xref :dspec `(,name) + :location location)) + name + where))))))) + +(provide 'slime-fancy-inspector) diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.elc b/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.elc new file mode 100644 index 00000000..6b3bed21 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-fancy-inspector.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy-trace.el b/elpa/slime-20200319.1939/contrib/slime-fancy-trace.el new file mode 100644 index 00000000..06a1fab2 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-fancy-trace.el @@ -0,0 +1,68 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-fancy-trace + "Enhanced version of slime-trace capable of tracing local functions, +methods, setf functions, and other entities supported by specific +swank:swank-toggle-trace backends. Invoke via C-u C-t." + (:authors "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-parse)) + +(defun slime-trace-query (spec) + "Ask the user which function to trace; SPEC is the default. +The result is a string." + (cond ((null spec) + (slime-read-from-minibuffer "(Un)trace: ")) + ((stringp spec) + (slime-read-from-minibuffer "(Un)trace: " spec)) + ((symbolp spec) ; `slime-extract-context' can return symbols. + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + (t + (slime-dcase spec + ((setf n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:defun n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) + ((:defgeneric n) + (let* ((name (prin1-to-string n)) + (answer (slime-read-from-minibuffer "(Un)trace: " name))) + (cond ((and (string= name answer) + (y-or-n-p (concat "(Un)trace also all " + "methods implementing " + name "? "))) + (prin1-to-string `(:defgeneric ,n))) + (t + answer)))) + ((:defmethod &rest _) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:call caller callee) + (let* ((callerstr (prin1-to-string caller)) + (calleestr (prin1-to-string callee)) + (answer (slime-read-from-minibuffer "(Un)trace: " + calleestr))) + (cond ((and (string= calleestr answer) + (y-or-n-p (concat "(Un)trace only when " calleestr + " is called by " callerstr "? "))) + (prin1-to-string `(:call ,caller ,callee))) + (t + answer)))) + (((:labels :flet) &rest _) + (slime-read-from-minibuffer "(Un)trace local function: " + (prin1-to-string spec))) + (t (error "Don't know how to trace the spec %S" spec)))))) + +(defun slime-toggle-fancy-trace (&optional using-context-p) + "Toggle trace." + (interactive "P") + (let* ((spec (if using-context-p + (slime-extract-context) + (slime-symbol-at-point))) + (spec (slime-trace-query spec))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))) + +;; override slime-toggle-trace-fdefinition +(define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace) + +(provide 'slime-fancy-trace) diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy-trace.elc b/elpa/slime-20200319.1939/contrib/slime-fancy-trace.elc new file mode 100644 index 00000000..12ef28cc Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-fancy-trace.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy.el b/elpa/slime-20200319.1939/contrib/slime-fancy.el new file mode 100644 index 00000000..5aba81c4 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-fancy.el @@ -0,0 +1,38 @@ +(require 'slime) + +(define-slime-contrib slime-fancy + "Make SLIME fancy." + (:authors "Matthias Koeppe " + "Tobias C Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-repl + slime-autodoc + slime-c-p-c + slime-editing-commands + slime-fancy-inspector + slime-fancy-trace + slime-fuzzy + slime-mdot-fu + slime-macrostep + slime-presentations + slime-scratch + slime-references + slime-package-fu + slime-fontifying-fu + slime-trace-dialog) + (:on-load + (slime-trace-dialog-init) + (slime-repl-init) + (slime-autodoc-init) + (slime-c-p-c-init) + (slime-editing-commands-init) + (slime-fancy-inspector-init) + (slime-fancy-trace-init) + (slime-fuzzy-init) + (slime-presentations-init) + (slime-scratch-init) + (slime-references-init) + (slime-package-fu-init) + (slime-fontifying-fu-init))) + +(provide 'slime-fancy) diff --git a/elpa/slime-20200319.1939/contrib/slime-fancy.elc b/elpa/slime-20200319.1939/contrib/slime-fancy.elc new file mode 100644 index 00000000..d6c0f7d4 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-fancy.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.el b/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.el new file mode 100644 index 00000000..42de251b --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.el @@ -0,0 +1,231 @@ +(require 'slime) +(require 'slime-parse) +(require 'slime-autodoc) +(require 'font-lock) +(require 'cl-lib) + +;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. +;;; Fontify CHECK-FOO like CHECK-TYPE. +(defvar slime-additional-font-lock-keywords + '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face) + ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) + +;;;; Specially fontify forms suppressed by a reader conditional. +(defcustom slime-highlight-suppressed-forms t + "Display forms disabled by reader conditionals as comments." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-mode) + +(define-slime-contrib slime-fontifying-fu + "Additional fontification tweaks: +Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros. +Fontify CHECK-FOO like CHECK-TYPE." + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:on-load + (font-lock-add-keywords + 'lisp-mode slime-additional-font-lock-keywords) + (when slime-highlight-suppressed-forms + (slime-activate-font-lock-magic))) + (:on-unload + ;; FIXME: remove `slime-search-suppressed-forms', and remove the + ;; extend-region hook. + (font-lock-remove-keywords + 'lisp-mode slime-additional-font-lock-keywords))) + +(defface slime-reader-conditional-face + '((t (:inherit font-lock-comment-face))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +(defvar slime-search-suppressed-forms-match-data (list nil nil)) + +(defun slime-search-suppressed-forms-internal (limit) + (when (search-forward-regexp slime-reader-conditionals-regexp limit t) + (let ((start (match-beginning 0)) ; save match data + (state (slime-current-parser-state))) + (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? + (slime-search-suppressed-forms-internal limit) + (let* ((char (char-before)) + (expr (read (current-buffer))) + (val (slime-eval-feature-expression expr))) + (when (<= (point) limit) + (if (or (and (eq char ?+) (not val)) + (and (eq char ?-) val)) + ;; If `slime-extend-region-for-font-lock' did not + ;; fully extend the region, the assertion below may + ;; fail. This should only happen on XEmacs and older + ;; versions of GNU Emacs. + (ignore-errors + (forward-sexp) (backward-sexp) + ;; Try to suppress as far as possible. + (slime-forward-sexp) + (cl-assert (<= (point) limit)) + (let ((md (match-data nil slime-search-suppressed-forms-match-data))) + (setf (cl-first md) start) + (setf (cl-second md) (point)) + (set-match-data md) + t)) + (slime-search-suppressed-forms-internal limit)))))))) + +(defun slime-search-suppressed-forms (limit) + "Find reader conditionalized forms where the test is false." + (when (and slime-highlight-suppressed-forms + (slime-connected-p)) + (let ((result 'retry)) + (while (and (eq result 'retry) (<= (point) limit)) + (condition-case condition + (setq result (slime-search-suppressed-forms-internal limit)) + (end-of-file ; e.g. #+( + (setq result nil)) + ;; We found a reader conditional we couldn't process for + ;; some reason; however, there may still be other reader + ;; conditionals before `limit'. + (invalid-read-syntax ; e.g. #+#.foo + (setq result 'retry)) + (scan-error ; e.g. #+nil (foo ... + (setq result 'retry)) + (slime-incorrect-feature-expression ; e.g. #+(not foo bar) + (setq result 'retry)) + (slime-unknown-feature-expression ; e.g. #+(foo) + (setq result 'retry)) + (error + (setq result nil) + (slime-display-warning + (concat "Caught error during fontification while searching for forms\n" + "that are suppressed by reader-conditionals. The error was: %S.") + condition)))) + result))) + + +(defun slime-search-directly-preceding-reader-conditional () + "Search for a directly preceding reader conditional. Return its +position, or nil." + ;;; We search for a preceding reader conditional. Then we check that + ;;; between the reader conditional and the point where we started is + ;;; no other intervening sexp, and we check that the reader + ;;; conditional is at the same nesting level. + (condition-case nil + (let* ((orig-pt (point)) + (reader-conditional-pt + (search-backward-regexp slime-reader-conditionals-regexp + ;; We restrict the search to the + ;; beginning of the /previous/ defun. + (save-excursion + (beginning-of-defun) + (point)) + t))) + (when reader-conditional-pt + (let* ((parser-state + (parse-partial-sexp + (progn (goto-char (+ reader-conditional-pt 2)) + (forward-sexp) ; skip feature expr. + (point)) + orig-pt)) + (paren-depth (car parser-state)) + (last-sexp-pt (cl-caddr parser-state))) + (if (and paren-depth + (not (cl-plusp paren-depth)) ; no '(' in between? + (not last-sexp-pt)) ; no complete sexp in between? + reader-conditional-pt + nil)))) + (scan-error nil))) ; improper feature expression + + +;;; We'll push this onto `font-lock-extend-region-functions'. In past, +;;; we didn't do so which made our reader-conditional font-lock magic +;;; pretty unreliable (it wouldn't highlight all suppressed forms, and +;;; worked quite non-deterministic in general.) +;;; +;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs. +;;; +;;; We make sure that `font-lock-beg' and `font-lock-end' always point +;;; to the beginning or end of a toplevel form. So we never miss a +;;; reader-conditional, or point in mid of one. +(defvar font-lock-beg) ; shoosh compiler +(defvar font-lock-end) + +(defun slime-extend-region-for-font-lock () + (when slime-highlight-suppressed-forms + (condition-case c + (let (changedp) + (cl-multiple-value-setq (changedp font-lock-beg font-lock-end) + (slime-compute-region-for-font-lock font-lock-beg font-lock-end)) + changedp) + (error + (slime-display-warning + (concat "Caught error when trying to extend the region for fontification.\n" + "The error was: %S\n" + "Further: font-lock-beg=%d, font-lock-end=%d.") + c font-lock-beg font-lock-end))))) + +(defun slime-beginning-of-tlf () + (let ((pos (syntax-ppss-toplevel-pos (slime-current-parser-state)))) + (if pos (goto-char pos)))) + +(defun slime-compute-region-for-font-lock (orig-beg orig-end) + (let ((beg orig-beg) + (end orig-end)) + (goto-char beg) + (inline (slime-beginning-of-tlf)) + (cl-assert (not (cl-plusp (nth 0 (slime-current-parser-state))))) + (setq beg (let ((pt (point))) + (cond ((> (- beg pt) 20000) beg) + ((slime-search-directly-preceding-reader-conditional)) + (t pt)))) + (goto-char end) + (while (search-backward-regexp slime-reader-conditionals-regexp beg t) + (setq end (max end (save-excursion + (ignore-errors (slime-forward-reader-conditional)) + (point))))) + (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end))) + + +(defun slime-activate-font-lock-magic () + (if (featurep 'xemacs) + (let ((pattern `((slime-search-suppressed-forms + (0 slime-reader-conditional-face t))))) + (dolist (sym '(lisp-font-lock-keywords + lisp-font-lock-keywords-1 + lisp-font-lock-keywords-2)) + (set sym (append (symbol-value sym) pattern)))) + (font-lock-add-keywords + 'lisp-mode + `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t))) + + (add-hook 'lisp-mode-hook + #'(lambda () + (add-hook 'font-lock-extend-region-functions + 'slime-extend-region-for-font-lock t t))))) + +(let ((byte-compile-warnings '())) + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (byte-code-function-p (symbol-function sym)) + (byte-compile sym))) + (t (error "%S is not fbound" sym)))) + '(slime-extend-region-for-font-lock + slime-compute-region-for-font-lock + slime-search-directly-preceding-reader-conditional + slime-search-suppressed-forms + slime-beginning-of-tlf))) + +(cl-defun slime-initialize-lisp-buffer-for-test-suite + (&key (font-lock-magic t) (autodoc t)) + (let ((hook lisp-mode-hook)) + (unwind-protect + (progn + (set (make-local-variable 'slime-highlight-suppressed-forms) + font-lock-magic) + (setq lisp-mode-hook nil) + (lisp-mode) + (slime-mode 1) + (when (boundp 'slime-autodoc-mode) + (if autodoc + (slime-autodoc-mode 1) + (slime-autodoc-mode -1)))) + (setq lisp-mode-hook hook)))) + +(provide 'slime-fontifying-fu) diff --git a/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.elc b/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.elc new file mode 100644 index 00000000..0f80eef8 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-fontifying-fu.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-fuzzy.el b/elpa/slime-20200319.1939/contrib/slime-fuzzy.el new file mode 100644 index 00000000..b2f22f1f --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-fuzzy.el @@ -0,0 +1,604 @@ +(require 'slime) +(require 'slime-repl) +(require 'slime-c-p-c) +(require 'cl-lib) + +(define-slime-contrib slime-fuzzy + "Fuzzy symbol completion." + (:authors "Brian Downing " + "Tobias C. Rittweiler " + "Attila Lendvai ") + (:license "GPL") + (:swank-dependencies swank-fuzzy) + (:on-load + (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol) + (when (featurep 'slime-repl) + (define-key slime-repl-mode-map "\C-c\M-i" + 'slime-fuzzy-complete-symbol)))) + +(defcustom slime-fuzzy-completion-in-place t + "When non-NIL the fuzzy symbol completion is done in place as +opposed to moving the point to the completion buffer." + :group 'slime-mode + :type 'boolean) + +(defcustom slime-fuzzy-completion-limit 300 + "Only return and present this many symbols from swank." + :group 'slime-mode + :type 'integer) + +(defcustom slime-fuzzy-completion-time-limit-in-msec 1500 + "Limit the time spent (given in msec) in swank while gathering +completions." + :group 'slime-mode + :type 'integer) + +(defcustom slime-when-complete-filename-expand nil + "Use comint-replace-by-expanded-filename instead of +comint-filename-completion to complete file names" + :group 'slime-mode + :type 'boolean) + + +(defvar slime-fuzzy-target-buffer nil + "The buffer that is the target of the completion activities.") +(defvar slime-fuzzy-saved-window-configuration nil + "The saved window configuration before the fuzzy completion +buffer popped up.") +(defvar slime-fuzzy-start nil + "The beginning of the completion slot in the target buffer. +This is a non-advancing marker.") +(defvar slime-fuzzy-end nil + "The end of the completion slot in the target buffer. +This is an advancing marker.") +(defvar slime-fuzzy-original-text nil + "The original text that was in the completion slot in the +target buffer. This is what is put back if completion is +aborted.") +(defvar slime-fuzzy-text nil + "The text that is currently in the completion slot in the +target buffer. If this ever doesn't match, the target buffer has +been modified and we abort without touching it.") +(defvar slime-fuzzy-first nil + "The position of the first completion in the completions buffer. +The descriptive text and headers are above this.") +(defvar slime-fuzzy-last nil + "The position of the last completion in the completions buffer. +If the time limit has exhausted during generation possible completion +choices inside SWANK, an indication is printed below this.") +(defvar slime-fuzzy-current-completion nil + "The current completion object. If this is the same before and +after point moves in the completions buffer, the text is not +replaced in the target for efficiency.") +(defvar slime-fuzzy-current-completion-overlay nil + "The overlay representing the current completion in the completion +buffer. This is used to hightlight the text.") + +;;;;;;; slime-target-buffer-fuzzy-completions-mode +;; NOTE: this mode has to be able to override key mappings in slime-mode + +(defvar slime-target-buffer-fuzzy-completions-map + (let ((map (make-sparse-keymap))) + (cl-labels ((def (keys command) + (unless (listp keys) + (setq keys (list keys))) + (dolist (key keys) + (define-key map key command)))) + (def `([remap keyboard-quit] + ,(kbd "C-g")) + 'slime-fuzzy-abort) + (def `([remap slime-fuzzy-indent-and-complete-symbol] + [remap slime-indent-and-complete-symbol] + ,(kbd "")) + 'slime-fuzzy-select-or-update-completions) + (def `([remap previous-line] + ,(kbd "")) + 'slime-fuzzy-prev) + (def `([remap next-line] + ,(kbd "")) + 'slime-fuzzy-next) + (def `([remap isearch-forward] + ,(kbd "C-s")) + 'slime-fuzzy-continue-isearch-in-fuzzy-buffer) + ;; some unconditional direct bindings + (def (list (kbd "") (kbd "RET") (kbd "") "(" ")" "[" "]") + 'slime-fuzzy-select-and-process-event-in-target-buffer)) + map) + "Keymap for slime-target-buffer-fuzzy-completions-mode. +This will override the key bindings in the target buffer +temporarily during completion.") + +;; Make sure slime-fuzzy-target-buffer-completions-mode's map is +;; before everything else. +(setf minor-mode-map-alist + (cl-stable-sort minor-mode-map-alist + (lambda (a b) + (eq a 'slime-fuzzy-target-buffer-completions-mode)) + :key #'car)) + +(defun slime-fuzzy-continue-isearch-in-fuzzy-buffer () + (interactive) + (select-window (get-buffer-window (slime-get-fuzzy-buffer))) + (call-interactively 'isearch-forward)) + +(define-minor-mode slime-fuzzy-target-buffer-completions-mode + "This minor mode is intented to override key bindings during +fuzzy completions in the target buffer. Most of the bindings will +do an implicit select in the completion window and let the +keypress be processed in the target buffer." + nil + nil + slime-target-buffer-fuzzy-completions-map) + +(add-to-list 'minor-mode-alist + '(slime-fuzzy-target-buffer-completions-mode + " Fuzzy Target Buffer Completions")) + +(defvar slime-fuzzy-completions-map + (let ((map (make-sparse-keymap))) + (cl-labels ((def (keys command) + (unless (listp keys) + (setq keys (list keys))) + (dolist (key keys) + (define-key map key command)))) + (def `([remap keyboard-quit] + "q" + ,(kbd "C-g")) + 'slime-fuzzy-abort) + (def `([remap previous-line] + "p" + "\M-p" + ,(kbd "")) + 'slime-fuzzy-prev) + (def `([remap next-line] + "n" + "\M-n" + ,(kbd "")) + 'slime-fuzzy-next) + (def "\d" 'scroll-down) + (def `([remap slime-fuzzy-indent-and-complete-symbol] + [remap slime-indent-and-complete-symbol] + ,(kbd "")) + 'slime-fuzzy-select) + (def (kbd "") 'slime-fuzzy-select/mouse) + (def `(,(kbd "RET") + ,(kbd "")) + 'slime-fuzzy-select)) + map) + "Keymap for slime-fuzzy-completions-mode when in the completion buffer.") + +(define-derived-mode slime-fuzzy-completions-mode + fundamental-mode "Fuzzy Completions" + "Major mode for presenting fuzzy completion results. + +When you run `slime-fuzzy-complete-symbol', the symbol token at +point is completed using the Fuzzy Completion algorithm; this +means that the token is taken as a sequence of characters and all +the various possibilities that this sequence could meaningfully +represent are offered as selectable choices, sorted by how well +they deem to be a match for the token. (For instance, the first +choice of completing on \"mvb\" would be \"multiple-value-bind\".) + +Therefore, a new buffer (*Fuzzy Completions*) will pop up that +contains the different completion choices. Simultaneously, a +special minor-mode will be temporarily enabled in the original +buffer where you initiated fuzzy completion (also called the +``target buffer'') in order to navigate through the *Fuzzy +Completions* buffer without leaving. + +With focus in *Fuzzy Completions*: + Type `n' and `p' (`UP', `DOWN') to navigate between completions. + Type `RET' or `TAB' to select the completion near point. + Type `q' to abort. + +With focus in the target buffer: + Type `UP' and `DOWN' to navigate between completions. + Type a character that does not constitute a symbol name + to insert the current choice and then that character (`(', `)', + `SPACE', `RET'.) Use `TAB' to simply insert the current choice. + Use C-g to abort. + +Alternatively, you can click on a completion to select it. + + +Complete listing of keybindings within the target buffer: + +\\\ +\\{slime-target-buffer-fuzzy-completions-map} + +Complete listing of keybindings with *Fuzzy Completions*: + +\\\ +\\{slime-fuzzy-completions-map}" + (use-local-map slime-fuzzy-completions-map) + (set (make-local-variable 'slime-fuzzy-current-completion-overlay) + (make-overlay (point) (point) nil t nil))) + +(defun slime-fuzzy-completions (prefix &optional default-package) + "Get the list of sorted completion objects from completing +`prefix' in `package' from the connected Lisp." + (let ((prefix (cl-etypecase prefix + (symbol (symbol-name prefix)) + (string prefix)))) + (slime-eval `(swank:fuzzy-completions ,prefix + ,(or default-package + (slime-current-package)) + :limit ,slime-fuzzy-completion-limit + :time-limit-in-msec + ,slime-fuzzy-completion-time-limit-in-msec)))) + +(defun slime-fuzzy-selected (prefix completion) + "Tell the connected Lisp that the user selected completion +`completion' as the completion for `prefix'." + (let ((no-properties (copy-sequence prefix))) + (set-text-properties 0 (length no-properties) nil no-properties) + (slime-eval `(swank:fuzzy-completion-selected ,no-properties + ',completion)))) + +(defun slime-fuzzy-indent-and-complete-symbol () + "Indent the current line and perform fuzzy symbol completion. First +indent the line. If indenting doesn't move point, complete the +symbol. If there's no symbol at the point, show the arglist for the +most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (slime-fuzzy-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(cl-defun slime-fuzzy-complete-symbol () + "Fuzzily completes the abbreviation at point into a symbol." + (interactive) + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (cl-return-from slime-fuzzy-complete-symbol + ;; don't add space after completion + (let ((comint-completion-addsuffix '("/" . ""))) + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + ;; FIXME: use `comint-filename-completion' when dropping emacs23 + (funcall (if (>= emacs-major-version 24) + 'comint-filename-completion + 'comint-dynamic-complete-as-filename)))))) + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end))) + (cl-destructuring-bind (completion-set interrupted-p) + (slime-fuzzy-completions prefix) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-fuzzy-done)) + (goto-char end) + (cond ((slime-length= completion-set 1) + ;; insert completed string + (insert-and-inherit (caar completion-set)) + (delete-region beg end) + (goto-char (+ beg (length (caar completion-set)))) + (slime-minibuffer-respecting-message "Sole completion") + (slime-fuzzy-done)) + ;; Incomplete + (t + (slime-fuzzy-choices-buffer completion-set interrupted-p + beg end) + (slime-minibuffer-respecting-message + "Complete but not unique"))))))) + + +(defun slime-get-fuzzy-buffer () + (get-buffer-create "*Fuzzy Completions*")) + +(defvar slime-fuzzy-explanation + "For help on how the use this buffer, see `slime-fuzzy-completions-mode'. + +Flags: boundp fboundp generic-function class macro special-operator package +\n" + "The explanation that gets inserted at the beginning of the +*Fuzzy Completions* buffer.") + +(defun slime-fuzzy-insert-completion-choice (completion max-length) + "Inserts the completion object `completion' as a formatted +completion choice into the current buffer, and mark it with the +proper text properties." + (cl-destructuring-bind (symbol-name score chunks classification-string) + completion + (let ((start (point)) + (end)) + (insert symbol-name) + (setq end (point)) + (dolist (chunk chunks) + (put-text-property (+ start (cl-first chunk)) + (+ start (cl-first chunk) + (length (cl-second chunk))) + 'face 'bold)) + (put-text-property start (point) 'mouse-face 'highlight) + (dotimes (i (- max-length (- end start))) + (insert " ")) + (insert (format " %s %s\n" + classification-string + score)) + (put-text-property start (point) 'completion completion)))) + +(defun slime-fuzzy-insert (text) + "Inserts `text' into the target buffer in the completion slot. +If the buffer has been modified in the meantime, abort the +completion process. Otherwise, update all completion variables +so that the new text is present." + (with-current-buffer slime-fuzzy-target-buffer + (cond + ((not (string-equal slime-fuzzy-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end))) + (slime-fuzzy-done) + (beep) + (message "Target buffer has been modified!")) + (t + (goto-char slime-fuzzy-start) + (delete-region slime-fuzzy-start slime-fuzzy-end) + (insert-and-inherit text) + (setq slime-fuzzy-text text) + (goto-char slime-fuzzy-end))))) + +(defun slime-minibuffer-p (buffer) + (if (featurep 'xemacs) + (eq buffer (window-buffer (minibuffer-window))) + (minibufferp buffer))) + +(defun slime-fuzzy-choices-buffer (completions interrupted-p start end) + "Creates (if neccessary), populates, and pops up the *Fuzzy +Completions* buffer with the completions from `completions' and +the completion slot in the current buffer bounded by `start' and +`end'. This saves the window configuration before popping the +buffer so that it can possibly be restored when the user is +done." + (let ((new-completion-buffer (not slime-fuzzy-target-buffer)) + (connection (slime-connection))) + (when new-completion-buffer + (setq slime-fuzzy-saved-window-configuration + (current-window-configuration))) + (slime-fuzzy-enable-target-buffer-completions-mode) + (setq slime-fuzzy-target-buffer (current-buffer)) + (setq slime-fuzzy-start (move-marker (make-marker) start)) + (setq slime-fuzzy-end (move-marker (make-marker) end)) + (set-marker-insertion-type slime-fuzzy-end t) + (setq slime-fuzzy-original-text (buffer-substring start end)) + (setq slime-fuzzy-text slime-fuzzy-original-text) + (slime-fuzzy-fill-completions-buffer completions interrupted-p) + (pop-to-buffer (slime-get-fuzzy-buffer)) + (slime-fuzzy-next) + (setq slime-buffer-connection connection) + (when new-completion-buffer + ;; Hook to nullify window-config restoration if the user changes + ;; the window configuration himself. + (when (boundp 'window-configuration-change-hook) + (add-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (add-hook 'kill-buffer-hook 'slime-fuzzy-abort 'append t) + (set (make-local-variable 'cursor-type) nil) + (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc + (when slime-fuzzy-completion-in-place + ;; switch back to the original buffer + (if (slime-minibuffer-p slime-fuzzy-target-buffer) + (select-window (minibuffer-window)) + (switch-to-buffer-other-window slime-fuzzy-target-buffer))))) + +(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p) + "Erases and fills the completion buffer with the given completions." + (with-current-buffer (slime-get-fuzzy-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (slime-fuzzy-completions-mode) + (insert slime-fuzzy-explanation) + (let ((max-length 12)) + (dolist (completion completions) + (setf max-length (max max-length (length (cl-first completion))))) + + (insert "Completion:") + (dotimes (i (- max-length 10)) (insert " ")) + ;; Flags: Score: + ;; ... ------- -------- + ;; bfgctmsp + (let* ((example-classification-string (cl-fourth (cl-first completions))) + (classification-length (length example-classification-string)) + (spaces (- classification-length (length "Flags:")))) + (insert "Flags:") + (dotimes (i spaces) (insert " ")) + (insert " Score:\n") + (dotimes (i max-length) (insert "-")) + (insert " ") + (dotimes (i classification-length) (insert "-")) + (insert " --------\n") + (setq slime-fuzzy-first (point))) + + (dolist (completion completions) + (setq slime-fuzzy-last (point)) ; will eventually become the last entry + (slime-fuzzy-insert-completion-choice completion max-length)) + + (when interrupted-p + (insert "...\n") + (insert "[Interrupted: time limit exhausted]")) + + (setq buffer-read-only t)) + (setq slime-fuzzy-current-completion + (caar completions)) + (goto-char 0))) + +(defun slime-fuzzy-enable-target-buffer-completions-mode () + "Store the target buffer's local map, so that we can restore it." + (unless slime-fuzzy-target-buffer-completions-mode +; (slime-log-event "Enabling target buffer completions mode") + (slime-fuzzy-target-buffer-completions-mode 1))) + +(defun slime-fuzzy-disable-target-buffer-completions-mode () + "Restores the target buffer's local map when completion is finished." + (when slime-fuzzy-target-buffer-completions-mode +; (slime-log-event "Disabling target buffer completions mode") + (slime-fuzzy-target-buffer-completions-mode 0))) + +(defun slime-fuzzy-insert-from-point () + "Inserts the completion that is under point in the completions +buffer into the target buffer. If the completion in question had +already been inserted, it does nothing." + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((current-completion (get-text-property (point) 'completion))) + (when (and current-completion + (not (eq slime-fuzzy-current-completion + current-completion))) + (slime-fuzzy-insert + (cl-first (get-text-property (point) 'completion))) + (setq slime-fuzzy-current-completion + current-completion))))) + +(defun slime-fuzzy-post-command-hook () + "The post-command-hook for the *Fuzzy Completions* buffer. +This makes sure the completion slot in the target buffer matches +the completion that point is on in the completions buffer." + (condition-case err + (when slime-fuzzy-target-buffer + (slime-fuzzy-insert-from-point)) + (error + ;; Because this is called on the post-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-fuzzy-post-command-hook: %S" err)))) + +(defun slime-fuzzy-next () + "Moves point directly to the next completion in the completions +buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((point (next-single-char-property-change + (point) 'completion nil slime-fuzzy-last))) + (set-window-point (get-buffer-window (current-buffer)) point) + (goto-char point)) + (slime-fuzzy-highlight-current-completion))) + +(defun slime-fuzzy-prev () + "Moves point directly to the previous completion in the +completions buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((point (previous-single-char-property-change + (point) + 'completion nil slime-fuzzy-first))) + (set-window-point (get-buffer-window (current-buffer)) point) + (goto-char point)) + (slime-fuzzy-highlight-current-completion))) + +(defun slime-fuzzy-highlight-current-completion () + "Highlights the current completion, +so that the user can see it on the screen." + (let ((pos (point))) + (when (overlayp slime-fuzzy-current-completion-overlay) + (move-overlay slime-fuzzy-current-completion-overlay + (point) (1- (search-forward " "))) + (overlay-put slime-fuzzy-current-completion-overlay + 'face 'secondary-selection)) + (goto-char pos))) + +(defun slime-fuzzy-abort () + "Aborts the completion process, setting the completions slot in +the target buffer back to its original contents." + (interactive) + (when slime-fuzzy-target-buffer + (slime-fuzzy-done))) + +(defun slime-fuzzy-select () + "Selects the current completion, making sure that it is inserted +into the target buffer. This tells the connected Lisp what completion +was selected." + (interactive) + (when slime-fuzzy-target-buffer + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((completion (get-text-property (point) 'completion))) + (when completion + (slime-fuzzy-insert (cl-first completion)) + (slime-fuzzy-selected slime-fuzzy-original-text + completion) + (slime-fuzzy-done)))))) + +(defun slime-fuzzy-select-or-update-completions () + "If there were no changes since the last time fuzzy completion was started +this function will select the current completion. +Otherwise refreshes the completion list based on the changes made." + (interactive) +; (slime-log-event "Selecting or updating completions") + (if (string-equal slime-fuzzy-original-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end)) + (slime-fuzzy-select) + (slime-fuzzy-complete-symbol))) + +(defun slime-fuzzy-process-event-in-completions-buffer () + "Simply processes the event in the target buffer" + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (push last-input-event unread-command-events))) + +(defun slime-fuzzy-select-and-process-event-in-target-buffer () + "Selects the current completion, making sure that it is inserted +into the target buffer and processes the event in the target buffer." + (interactive) +; (slime-log-event "Selecting and processing event in target buffer") + (when slime-fuzzy-target-buffer + (let ((buff slime-fuzzy-target-buffer)) + (slime-fuzzy-select) + (with-current-buffer buff + (slime-fuzzy-disable-target-buffer-completions-mode) + (push last-input-event unread-command-events))))) + +(defun slime-fuzzy-select/mouse (event) + "Handle a mouse-2 click on a completion choice as if point were +on the completion choice and the slime-fuzzy-select command was +run." + (interactive "e") + (with-current-buffer (window-buffer (posn-window (event-end event))) + (save-excursion + (goto-char (posn-point (event-end event))) + (when (get-text-property (point) 'mouse-face) + (slime-fuzzy-insert-from-point) + (slime-fuzzy-select))))) + +(defun slime-fuzzy-done () + "Cleans up after the completion process. This removes all hooks, +and attempts to restore the window configuration. If this fails, +it just burys the completions buffer and leaves the window +configuration alone." + (when slime-fuzzy-target-buffer + (set-buffer slime-fuzzy-target-buffer) + (slime-fuzzy-disable-target-buffer-completions-mode) + (if (slime-fuzzy-maybe-restore-window-configuration) + (bury-buffer (slime-get-fuzzy-buffer)) + ;; We couldn't restore the windows, so just bury the fuzzy + ;; completions buffer and let something else fill it in. + (pop-to-buffer (slime-get-fuzzy-buffer)) + (bury-buffer)) + (if (slime-minibuffer-p slime-fuzzy-target-buffer) + (select-window (minibuffer-window)) + (pop-to-buffer slime-fuzzy-target-buffer)) + (goto-char slime-fuzzy-end) + (setq slime-fuzzy-target-buffer nil) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change))) + +(defun slime-fuzzy-maybe-restore-window-configuration () + "Restores the saved window configuration if it has not been +nullified." + (when (boundp 'window-configuration-change-hook) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (if (not slime-fuzzy-saved-window-configuration) + nil + (set-window-configuration slime-fuzzy-saved-window-configuration) + (setq slime-fuzzy-saved-window-configuration nil) + t)) + +(defun slime-fuzzy-window-configuration-change () + "Called on window-configuration-change-hook. Since the window +configuration was changed, we nullify our saved configuration." + (setq slime-fuzzy-saved-window-configuration nil)) + +(provide 'slime-fuzzy) diff --git a/elpa/slime-20200319.1939/contrib/slime-fuzzy.elc b/elpa/slime-20200319.1939/contrib/slime-fuzzy.elc new file mode 100644 index 00000000..7ee43879 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-fuzzy.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-highlight-edits.el b/elpa/slime-20200319.1939/contrib/slime-highlight-edits.el new file mode 100644 index 00000000..2a3f0a83 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-highlight-edits.el @@ -0,0 +1,81 @@ +(require 'slime) +(require 'slime-parse) + +(define-slime-contrib slime-highlight-edits + "Highlight edited, i.e. not yet compiled, code." + (:authors "William Bland ") + (:license "GPL") + (:on-load (add-hook 'slime-mode-hook 'slime-activate-highlight-edits)) + (:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits))) + +(defun slime-activate-highlight-edits () + (slime-highlight-edits-mode 1)) + +(defface slime-highlight-edits-face + `((((class color) (background light)) + (:background "lightgray")) + (((class color) (background dark)) + (:background "dimgray")) + (t (:background "yellow"))) + "Face for displaying edit but not compiled code." + :group 'slime-mode-faces) + +(define-minor-mode slime-highlight-edits-mode + "Minor mode to highlight not-yet-compiled code." nil) + +(add-hook 'slime-highlight-edits-mode-on-hook + 'slime-highlight-edits-init-buffer) + +(add-hook 'slime-highlight-edits-mode-off-hook + 'slime-highlight-edits-reset-buffer) + +(defun slime-highlight-edits-init-buffer () + (make-local-variable 'after-change-functions) + (add-to-list 'after-change-functions + 'slime-highlight-edits) + (add-to-list 'slime-before-compile-functions + 'slime-highlight-edits-compile-hook)) + +(defun slime-highlight-edits-reset-buffer () + (setq after-change-functions + (remove 'slime-highlight-edits after-change-functions)) + (slime-remove-edits (point-min) (point-max))) + +;; FIXME: what's the LEN arg for? +(defun slime-highlight-edits (beg end &optional len) + (save-match-data + (when (and (slime-connected-p) + (not (slime-inside-comment-p)) + (not (slime-only-whitespace-p beg end))) + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'slime-highlight-edits-face) + (overlay-put overlay 'slime-edit t))))) + +(defun slime-remove-edits (start end) + "Delete the existing Slime edit hilights in the current buffer." + (save-excursion + (goto-char start) + (while (< (point) end) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime-edit) + (delete-overlay o))) + (goto-char (next-overlay-change (point)))))) + +(defun slime-highlight-edits-compile-hook (start end) + (when slime-highlight-edits-mode + (let ((start (save-excursion (goto-char start) + (skip-chars-backward " \t\n\r") + (point))) + (end (save-excursion (goto-char end) + (skip-chars-forward " \t\n\r") + (point)))) + (slime-remove-edits start end)))) + +(defun slime-only-whitespace-p (beg end) + "Contains the region from BEG to END only whitespace?" + (save-excursion + (goto-char beg) + (skip-chars-forward " \n\t\r" end) + (<= end (point)))) + +(provide 'slime-highlight-edits) diff --git a/elpa/slime-20200319.1939/contrib/slime-highlight-edits.elc b/elpa/slime-20200319.1939/contrib/slime-highlight-edits.elc new file mode 100644 index 00000000..95d4072e Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-highlight-edits.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-hyperdoc.el b/elpa/slime-20200319.1939/contrib/slime-hyperdoc.el new file mode 100644 index 00000000..64de7ee7 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-hyperdoc.el @@ -0,0 +1,48 @@ +(require 'slime) +(require 'url-http) +(require 'browse-url) +(eval-when-compile (require 'cl)) ; lexical-let + +(defvar slime-old-documentation-lookup-function + slime-documentation-lookup-function) + +(define-slime-contrib slime-hyperdoc + "Extensible C-c C-d h." + (:authors "Tobias C Rittweiler ") + (:license "GPL") + (:swank-dependencies swank-hyperdoc) + (:on-load + (setq slime-documentation-lookup-function 'slime-hyperdoc-lookup)) + (:on-unload + (setq slime-documentation-lookup-function + slime-old-documentation-lookup-function))) + +;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour. + +(defun slime-hyperdoc-lookup-rpc (symbol-name) + (slime-eval-async `(swank:hyperdoc ,symbol-name) + (lexical-let ((symbol-name symbol-name)) + #'(lambda (result) + (slime-log-event result) + (cl-loop with foundp = nil + for (doc-type . url) in result do + (when (and url (stringp url) + (let ((url-show-status nil)) + (url-http-file-exists-p url))) + (message "Visiting documentation for %s `%s'..." + (substring (symbol-name doc-type) 1) + symbol-name) + (browse-url url) + (setq foundp t)) + finally + (unless foundp + (error "Could not find documentation for `%s'." + symbol-name))))))) + +(defun slime-hyperdoc-lookup (symbol-name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (if (memq :hyperdoc (slime-lisp-features)) + (slime-hyperdoc-lookup-rpc symbol-name) + (slime-hyperspec-lookup symbol-name))) + +(provide 'slime-hyperdoc) diff --git a/elpa/slime-20200319.1939/contrib/slime-hyperdoc.elc b/elpa/slime-20200319.1939/contrib/slime-hyperdoc.elc new file mode 100644 index 00000000..f947d0d1 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-hyperdoc.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-indentation.el b/elpa/slime-20200319.1939/contrib/slime-indentation.el new file mode 100644 index 00000000..8e323e05 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-indentation.el @@ -0,0 +1,31 @@ +(require 'slime) +(require 'slime-cl-indent) +(require 'cl-lib) + +(define-slime-contrib slime-indentation + "Contrib interfacing `slime-cl-indent' and SLIME." + (:swank-dependencies swank-indentation) + (:on-load + (setq common-lisp-current-package-function 'slime-current-package))) + +(defun slime-update-system-indentation (symbol indent packages) + (let ((list (gethash symbol common-lisp-system-indentation)) + (ok nil)) + (if (not list) + (puthash symbol (list (cons indent packages)) + common-lisp-system-indentation) + (dolist (spec list) + (cond ((equal (car spec) indent) + (dolist (p packages) + (unless (member p (cdr spec)) + (push p (cdr spec)))) + (setf ok t)) + (t + (setf (cdr spec) + (cl-set-difference (cdr spec) packages :test 'equal))))) + (unless ok + (puthash symbol (cons (cons indent packages) + list) + common-lisp-system-indentation))))) + +(provide 'slime-indentation) diff --git a/elpa/slime-20200319.1939/contrib/slime-indentation.elc b/elpa/slime-20200319.1939/contrib/slime-indentation.elc new file mode 100644 index 00000000..d5f889a2 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-indentation.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-listener-hooks.el b/elpa/slime-20200319.1939/contrib/slime-listener-hooks.el new file mode 100644 index 00000000..ec573daf --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-listener-hooks.el @@ -0,0 +1,11 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-listener-hooks + "Enable slime integration in an application'w event loop" + (:authors "Alan Ruttenberg , R. Mattes ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-listener-hooks)) + +(provide 'slime-listener-hooks) diff --git a/elpa/slime-20200319.1939/contrib/slime-listener-hooks.elc b/elpa/slime-20200319.1939/contrib/slime-listener-hooks.elc new file mode 100644 index 00000000..4fe6b4d3 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-listener-hooks.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-macrostep.el b/elpa/slime-20200319.1939/contrib/slime-macrostep.el new file mode 100644 index 00000000..a9dff734 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-macrostep.el @@ -0,0 +1,129 @@ +;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el + +;; Authors: Luís Oliveira +;; Jon Oddie " + "Jon Oddie ") + (:license "GPL") + (:swank-dependencies swank-macrostep) + (:on-load + (easy-menu-add-item slime-mode-map '(menu-bar SLIME Debugging) + ["Macro stepper..." macrostep-expand (slime-connected-p)] + "Create Trace Buffer") + (add-hook 'slime-mode-hook #'macrostep-slime-mode-hook) + (define-key slime-mode-map (kbd "C-c M-e") #'macrostep-expand) + (eval-after-load 'slime-repl + '(progn + (add-hook 'slime-repl-mode-hook #'macrostep-slime-mode-hook) + (define-key slime-repl-mode-map (kbd "C-c M-e") #'macrostep-expand))))) + +(defun macrostep-slime-mode-hook () + (setq macrostep-sexp-at-point-function #'macrostep-slime-sexp-at-point) + (setq macrostep-environment-at-point-function #'macrostep-slime-context) + (setq macrostep-expand-1-function #'macrostep-slime-expand-1) + (setq macrostep-print-function #'macrostep-slime-insert) + (setq macrostep-macro-form-p-function #'macrostep-slime-macro-form-p)) + +(defun macrostep-slime-sexp-at-point (&rest _ignore) + (slime-sexp-at-point)) + +(defun macrostep-slime-context () + (let (defun-start defun-end) + (save-excursion + (while + (condition-case nil + (progn (backward-up-list) t) + (scan-error nil))) + (setq defun-start (point)) + (setq defun-end (scan-sexps (point) 1))) + (list (buffer-substring-no-properties + defun-start (point)) + (buffer-substring-no-properties + (scan-sexps (point) 1) defun-end)))) + +(defun macrostep-slime-expand-1 (string context) + (slime-dcase + (slime-eval + `(swank-macrostep:macrostep-expand-1 + ,string ,macrostep-expand-compiler-macros ',context)) + ((:error error-message) + (error "%s" error-message)) + ((:ok expansion positions) + (list expansion positions)))) + +(defun macrostep-slime-insert (result _ignore) + "Insert RESULT at point, indenting to match the current column." + (cl-destructuring-bind (expansion positions) result + (let ((start (point)) + (column-offset (current-column))) + (insert expansion) + (macrostep-slime--propertize-macros start positions) + (indent-rigidly start (point) column-offset)))) + +(defun macrostep-slime--propertize-macros (start-offset positions) + "Put text properties on macro forms." + (dolist (position positions) + (cl-destructuring-bind (operator type start) + position + (let ((open-paren-position + (+ start-offset start))) + (put-text-property open-paren-position + (1+ open-paren-position) + 'macrostep-macro-start + t) + ;; this assumes that the operator starts right next to the + ;; opening parenthesis. We could probably be more robust. + (let ((op-start (1+ open-paren-position))) + (put-text-property op-start + (+ op-start (length operator)) + 'font-lock-face + (if (eq type :macro) + 'macrostep-macro-face + 'macrostep-compiler-macro-face))))))) + +(defun macrostep-slime-macro-form-p (string context) + (slime-dcase + (slime-eval + `(swank-macrostep:macro-form-p + ,string ,macrostep-expand-compiler-macros ',context)) + ((:error error-message) + (error "%s" error-message)) + ((:ok result) + result))) + + + +(provide 'slime-macrostep) diff --git a/elpa/slime-20200319.1939/contrib/slime-macrostep.elc b/elpa/slime-20200319.1939/contrib/slime-macrostep.elc new file mode 100644 index 00000000..ab5cdac6 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-macrostep.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-mdot-fu.el b/elpa/slime-20200319.1939/contrib/slime-mdot-fu.el new file mode 100644 index 00000000..ed2e96ae --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-mdot-fu.el @@ -0,0 +1,31 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-mdot-fu + "Making M-. work on local functions." + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-enclosing-context) + (:on-load + (add-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)) + (:on-unload + (remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition))) + + +(defun slime-edit-local-definition (name &optional where) + "Like `slime-edit-definition', but tries to find the definition +in a local function binding near point." + (interactive (list (slime-read-symbol-name "Name: "))) + (cl-multiple-value-bind (binding-name point) + (cl-multiple-value-call #'cl-some #'(lambda (binding-name point) + (when (cl-equalp binding-name name) + (cl-values binding-name point))) + (slime-enclosing-bound-names)) + (when (and binding-name point) + (slime-edit-definition-cont + `((,binding-name + ,(make-slime-buffer-location (buffer-name (current-buffer)) point))) + name + where)))) + +(provide 'slime-mdot-fu) diff --git a/elpa/slime-20200319.1939/contrib/slime-mdot-fu.elc b/elpa/slime-20200319.1939/contrib/slime-mdot-fu.elc new file mode 100644 index 00000000..e13ea05b Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-mdot-fu.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-media.el b/elpa/slime-20200319.1939/contrib/slime-media.el new file mode 100644 index 00000000..cb839eb2 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-media.el @@ -0,0 +1,46 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-media + "Display things other than text in SLIME buffers" + (:authors "Christophe Rhodes ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-media) + (:on-load + (add-hook 'slime-event-hooks 'slime-dispatch-media-event))) + +(defun slime-media-decode-image (image) + (mapcar (lambda (image) + (if (plist-get image :data) + (plist-put image :data (base64-decode-string (plist-get image :data))) + image)) + image)) + +(defun slime-dispatch-media-event (event) + (slime-dcase event + ((:write-image image string) + (let ((img (or (find-image (slime-media-decode-image image)) + (create-image image)))) + (slime-media-insert-image img string)) + t) + ((:popup-buffer bufname string mode) + (slime-with-popup-buffer (bufname :connection t :package t) + (when mode (funcall mode)) + (princ string) + (goto-char (point-min))) + t) + (t nil))) + +(defun slime-media-insert-image (image string &optional bol) + (with-current-buffer (slime-output-buffer) + (let ((marker (slime-repl-output-target-marker :repl-result))) + (goto-char marker) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert-image image string)) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point))) + (slime-repl-show-maximum-output))) + +(provide 'slime-media) diff --git a/elpa/slime-20200319.1939/contrib/slime-media.elc b/elpa/slime-20200319.1939/contrib/slime-media.elc new file mode 100644 index 00000000..16087ad6 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-media.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-mrepl.el b/elpa/slime-20200319.1939/contrib/slime-mrepl.el new file mode 100644 index 00000000..d9ebc38b --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-mrepl.el @@ -0,0 +1,150 @@ +;; An experimental implementation of multiple REPLs multiplexed over a +;; single Slime socket. M-x slime-new-mrepl creates a new REPL buffer. +;; +(require 'slime) +(require 'inferior-slime) ; inferior-slime-indent-lime +(require 'cl-lib) + +(define-slime-contrib slime-mrepl + "Multiple REPLs." + (:authors "Helmut Eller ") + (:license "GPL") + (:swank-dependencies swank-mrepl)) + +(require 'comint) + +(defvar slime-mrepl-remote-channel nil) +(defvar slime-mrepl-expect-sexp nil) + +(define-derived-mode slime-mrepl-mode comint-mode "mrepl" + ;; idea lifted from ielm + (unless (get-buffer-process (current-buffer)) + (let* ((process-connection-type nil) + (proc (start-process "mrepl (dummy)" (current-buffer) "hexl"))) + (set-process-query-on-exit-flag proc nil))) + (set (make-local-variable 'comint-use-prompt-regexp) nil) + (set (make-local-variable 'comint-inhibit-carriage-motion) t) + (set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender) + (set (make-local-variable 'comint-output-filter-functions) nil) + (set (make-local-variable 'slime-mrepl-expect-sexp) t) + ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input) + (set-syntax-table lisp-mode-syntax-table) + ) + +(slime-define-keys slime-mrepl-mode-map + ((kbd "RET") 'slime-mrepl-return) + ([return] 'slime-mrepl-return) + ;;((kbd "TAB") 'slime-indent-and-complete-symbol) + ((kbd "C-c C-b") 'slime-interrupt) + ((kbd "C-c C-c") 'slime-interrupt)) + +(defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid +(defun slime-mrepl-mark () (process-mark (slime-mrepl-process%))) + +(defun slime-mrepl-insert (string) + (comint-output-filter (slime-mrepl-process%) string)) + +(slime-define-channel-type listener) + +(slime-define-channel-method listener :prompt (package prompt) + (with-current-buffer (slime-channel-get self 'buffer) + (slime-mrepl-prompt package prompt))) + +(defun slime-mrepl-prompt (package prompt) + (setf slime-buffer-package package) + (slime-mrepl-insert (format "%s%s> " + (cl-case (current-column) + (0 "") + (t "\n")) + prompt)) + (slime-mrepl-recenter)) + +(defun slime-mrepl-recenter () + (when (get-buffer-window) + (recenter -1))) + +(slime-define-channel-method listener :write-result (result) + (with-current-buffer (slime-channel-get self 'buffer) + (goto-char (point-max)) + (slime-mrepl-insert result))) + +(slime-define-channel-method listener :evaluation-aborted () + (with-current-buffer (slime-channel-get self 'buffer) + (goto-char (point-max)) + (slime-mrepl-insert "; Evaluation aborted\n"))) + +(slime-define-channel-method listener :write-string (string) + (slime-mrepl-write-string self string)) + +(defun slime-mrepl-write-string (self string) + (with-current-buffer (slime-channel-get self 'buffer) + (goto-char (slime-mrepl-mark)) + (slime-mrepl-insert string))) + +(slime-define-channel-method listener :set-read-mode (mode) + (with-current-buffer (slime-channel-get self 'buffer) + (cl-ecase mode + (:read (setq slime-mrepl-expect-sexp nil) + (message "[Listener is waiting for input]")) + (:eval (setq slime-mrepl-expect-sexp t))))) + +(defun slime-mrepl-return (&optional end-of-input) + (interactive "P") + (slime-check-connected) + (goto-char (point-max)) + (cond ((and slime-mrepl-expect-sexp + (or (slime-input-complete-p (slime-mrepl-mark) (point)) + end-of-input)) + (comint-send-input)) + ((not slime-mrepl-expect-sexp) + (unless end-of-input + (insert "\n")) + (comint-send-input t)) + (t + (insert "\n") + (inferior-slime-indent-line) + (message "[input not complete]"))) + (slime-mrepl-recenter)) + +(defun slime-mrepl-input-sender (proc string) + (slime-mrepl-send-string (substring-no-properties string))) + +(defun slime-mrepl-send-string (string &optional command-string) + (slime-mrepl-send `(:process ,string))) + +(defun slime-mrepl-send (msg) + "Send MSG to the remote channel." + (slime-send-to-remote-channel slime-mrepl-remote-channel msg)) + +(defun slime-new-mrepl () + "Create a new listener window." + (interactive) + (let ((channel (slime-make-channel slime-listener-channel-methods))) + (slime-eval-async + `(swank-mrepl:create-mrepl ,(slime-channel.id channel)) + (slime-rcurry + (lambda (result channel) + (cl-destructuring-bind (remote thread-id package prompt) result + (pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl))) + (slime-mrepl-mode) + (setq slime-current-thread thread-id) + (setq slime-buffer-connection (slime-connection)) + (set (make-local-variable 'slime-mrepl-remote-channel) remote) + (slime-channel-put channel 'buffer (current-buffer)) + (slime-channel-send channel `(:prompt ,package ,prompt)))) + channel)))) + +(defun slime-mrepl () + (let ((conn (slime-connection))) + (cl-find-if (lambda (x) + (with-current-buffer x + (and (eq major-mode 'slime-mrepl-mode) + (eq (slime-current-connection) conn)))) + (buffer-list)))) + +(def-slime-selector-method ?m + "First mrepl-buffer" + (or (slime-mrepl) + (error "No mrepl buffer (%s)" (slime-connection-name)))) + +(provide 'slime-mrepl) diff --git a/elpa/slime-20200319.1939/contrib/slime-mrepl.elc b/elpa/slime-20200319.1939/contrib/slime-mrepl.elc new file mode 100644 index 00000000..3d206a5d Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-mrepl.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-package-fu.el b/elpa/slime-20200319.1939/contrib/slime-package-fu.el new file mode 100644 index 00000000..c18f0fe2 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-package-fu.el @@ -0,0 +1,320 @@ +(require 'slime) +(require 'slime-c-p-c) +(require 'slime-parse) + +(defvar slime-package-fu-init-undo-stack nil) + +(define-slime-contrib slime-package-fu + "Exporting/Unexporting symbols at point." + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:swank-dependencies swank-package-fu) + (:on-load + (push `(progn (define-key slime-mode-map "\C-cx" + ',(lookup-key slime-mode-map "\C-cx"))) + slime-package-fu-init-undo-stack) + (define-key slime-mode-map "\C-cx" 'slime-export-symbol-at-point)) + (:on-unload + (while slime-c-p-c-init-undo-stack + (eval (pop slime-c-p-c-init-undo-stack))))) + +(defvar slime-package-file-candidates + (mapcar #'file-name-nondirectory + '("package.lisp" "packages.lisp" "pkgdcl.lisp" + "defpackage.lisp"))) + +(defvar slime-export-symbol-representation-function + #'(lambda (n) (format "#:%s" n))) + +(defvar slime-export-symbol-representation-auto t + "Determine automatically which style is used for symbols, #: or : +If it's mixed or no symbols are exported so far, +use `slime-export-symbol-representation-function'.") + +(defvar slime-export-save-file nil + "Save the package file after each automatic modification") + +(defvar slime-defpackage-regexp + "^(\\(cl:\\|common-lisp:\\|uiop:\\|uiop/package:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*") + +(defun slime-find-package-definition-rpc (package) + (slime-eval `(swank:find-definition-for-thing + (swank::guess-package ,package)))) + +(defun slime-find-package-definition-regexp (package) + (save-excursion + (save-match-data + (goto-char (point-min)) + (cl-block nil + (while (re-search-forward slime-defpackage-regexp nil t) + (when (slime-package-equal package (slime-sexp-at-point)) + (backward-sexp) + (cl-return (make-slime-file-location (buffer-file-name) + (1- (point)))))))))) + +(defun slime-package-equal (designator1 designator2) + ;; First try to be lucky and compare the strings themselves (for the + ;; case when one of the designated packages isn't loaded in the + ;; image.) Then try to do it properly using the inferior Lisp which + ;; will also resolve nicknames for us &c. + (or (cl-equalp (slime-cl-symbol-name designator1) + (slime-cl-symbol-name designator2)) + (slime-eval `(swank:package= ,designator1 ,designator2)))) + +(defun slime-export-symbol (symbol package) + "Unexport `symbol' from `package' in the Lisp image." + (slime-eval `(swank:export-symbol-for-emacs ,symbol ,package))) + +(defun slime-unexport-symbol (symbol package) + "Export `symbol' from `package' in the Lisp image." + (slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package))) + + +(defun slime-find-possible-package-file (buffer-file-name) + (cl-labels ((file-name-subdirectory (dirname) + (expand-file-name + (concat (file-name-as-directory (slime-to-lisp-filename dirname)) + (file-name-as-directory "..")))) + (try (dirname) + (cl-dolist (package-file-name slime-package-file-candidates) + (let ((f (slime-to-lisp-filename + (concat dirname package-file-name)))) + (when (file-readable-p f) + (cl-return f)))))) + (when buffer-file-name + (let ((buffer-cwd (file-name-directory buffer-file-name))) + (or (try buffer-cwd) + (try (file-name-subdirectory buffer-cwd)) + (try (file-name-subdirectory + (file-name-subdirectory buffer-cwd)))))))) + +(defun slime-goto-package-source-definition (package) + "Tries to find the DEFPACKAGE form of `package'. If found, +places the cursor at the start of the DEFPACKAGE form." + (cl-labels ((try (location) + (when (slime-location-p location) + (slime-goto-source-location location) + t))) + (or (try (slime-find-package-definition-rpc package)) + (try (slime-find-package-definition-regexp package)) + (try (let ((package-file (slime-find-possible-package-file + (buffer-file-name)))) + (when package-file + (with-current-buffer (find-file-noselect package-file t) + (slime-find-package-definition-regexp package))))) + (error "Couldn't find source definition of package: %s" package)))) + +(defun slime-at-expression-p (pattern) + (when (ignore-errors + ;; at a list? + (= (point) (progn (down-list 1) + (backward-up-list 1) + (point)))) + (save-excursion + (down-list 1) + (slime-in-expression-p pattern)))) + +(defun slime-goto-next-export-clause () + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (let ((point)) + (save-excursion + (cl-block nil + (while (ignore-errors (slime-forward-sexp) t) + (skip-chars-forward " \n\t") + (when (slime-at-expression-p '(:export *)) + (setq point (point)) + (cl-return))))) + (if point + (goto-char point) + (error "No next (:export ...) clause found")))) + +(defun slime-search-exports-in-defpackage (symbol-name) + "Look if `symbol-name' is mentioned in one of the :EXPORT clauses." + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (cl-labels ((target-symbol-p (symbol) + (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$" + (regexp-quote symbol-name)) + symbol))) + (save-excursion + (cl-block nil + (while (ignore-errors (slime-goto-next-export-clause) t) + (let ((clause-end (save-excursion (forward-sexp) (point)))) + (save-excursion + (while (search-forward symbol-name clause-end t) + (when (target-symbol-p (slime-symbol-at-point)) + (cl-return (if (slime-inside-string-p) + ;; Include the following " + (1+ (point)) + (point)))))))))))) + +(defun slime-export-symbols () + "Return a list of symbols inside :export clause of a defpackage." + ;; Assumes we're at the beginning of :export + (cl-labels ((read-sexp () + (ignore-errors + (forward-comment (point-max)) + (buffer-substring-no-properties + (point) (progn (forward-sexp) (point)))))) + (save-excursion + (cl-loop for sexp = (read-sexp) while sexp collect sexp)))) + +(defun slime-defpackage-exports () + "Return a list of symbols inside :export clause of a defpackage." + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (cl-labels ((normalize-name (name) + (if (string-prefix-p "\"" name) + (read name) + (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)" + "" name)))) + (save-excursion + (mapcar #'normalize-name + (cl-loop while (ignore-errors (slime-goto-next-export-clause) t) + do (down-list) (forward-sexp) + append (slime-export-symbols) + do (up-list) (backward-sexp)))))) + +(defun slime-symbol-exported-p (name symbols) + (cl-member name symbols :test 'cl-equalp)) + +(defun slime-frob-defpackage-form (current-package do-what symbols) + "Adds/removes `symbol' from the DEFPACKAGE form of `current-package' +depending on the value of `do-what' which can either be `:export', +or `:unexport'. + +Returns t if the symbol was added/removed. Nil if the symbol was +already exported/unexported." + (save-excursion + (slime-goto-package-source-definition current-package) + (down-list 1) ; enter DEFPACKAGE form + (forward-sexp) ; skip DEFPACKAGE symbol + ;; Don't or will fail if (:export ...) is immediately following + ;; (forward-sexp) ; skip package name + (let ((exported-symbols (slime-defpackage-exports)) + (symbols (if (consp symbols) + symbols + (list symbols))) + (number-of-actions 0)) + (cl-ecase do-what + (:export + (slime-add-export) + (dolist (symbol symbols) + (let ((symbol-name (slime-cl-symbol-name symbol))) + (unless (slime-symbol-exported-p symbol-name exported-symbols) + (cl-incf number-of-actions) + (slime-insert-export symbol-name))))) + (:unexport + (dolist (symbol symbols) + (let ((symbol-name (slime-cl-symbol-name symbol))) + (when (slime-symbol-exported-p symbol-name exported-symbols) + (slime-remove-export symbol-name) + (cl-incf number-of-actions)))))) + (when slime-export-save-file + (save-buffer)) + number-of-actions))) + +(defun slime-add-export () + (let (point) + (save-excursion + (while (ignore-errors (slime-goto-next-export-clause) t) + (setq point (point)))) + (cond (point + (goto-char point) + (down-list) + (slime-end-of-list)) + (t + (slime-end-of-list) + (unless (looking-back "^\\s-*") + (newline-and-indent)) + (insert "(:export ") + (save-excursion (insert ")")))))) + +(defun slime-determine-symbol-style () + ;; Assumes we're inside :export + (save-excursion + (slime-beginning-of-list) + (slime-forward-sexp) + (let ((symbols (slime-export-symbols))) + (cond ((null symbols) + slime-export-symbol-representation-function) + ((cl-every (lambda (x) + (string-match "^:" x)) + symbols) + (lambda (n) (format ":%s" n))) + ((cl-every (lambda (x) + (string-match "^#:" x)) + symbols) + (lambda (n) (format "#:%s" n))) + ((cl-every (lambda (x) + (string-prefix-p "\"" x)) + symbols) + (lambda (n) (prin1-to-string (upcase (substring-no-properties n))))) + (t + slime-export-symbol-representation-function))))) + +(defun slime-format-symbol-for-defpackage (symbol-name) + (funcall (if slime-export-symbol-representation-auto + (slime-determine-symbol-style) + slime-export-symbol-representation-function) + symbol-name)) + +(defun slime-insert-export (symbol-name) + ;; Assumes we're at the inside :export after the last symbol + (let ((symbol-name (slime-format-symbol-for-defpackage symbol-name))) + (unless (looking-back "^\\s-*") + (newline-and-indent)) + (insert symbol-name))) + +(defun slime-remove-export (symbol-name) + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (let ((point)) + (while (setq point (slime-search-exports-in-defpackage symbol-name)) + (save-excursion + (goto-char point) + (backward-sexp) + (delete-region (point) point) + (beginning-of-line) + (when (looking-at "^\\s-*$") + (join-line) + (delete-trailing-whitespace (point) (line-end-position))))))) + +(defun slime-export-symbol-at-point () + "Add the symbol at point to the defpackage source definition +belonging to the current buffer-package. With prefix-arg, remove +the symbol again. Additionally performs an EXPORT/UNEXPORT of the +symbol in the Lisp image if possible." + (interactive) + (let ((package (slime-current-package)) + (symbol (slime-symbol-at-point))) + (unless symbol (error "No symbol at point.")) + (cond (current-prefix-arg + (if (cl-plusp (slime-frob-defpackage-form package :unexport symbol)) + (message "Symbol `%s' no longer exported form `%s'" + symbol package) + (message "Symbol `%s' is not exported from `%s'" + symbol package)) + (slime-unexport-symbol symbol package)) + (t + (if (cl-plusp (slime-frob-defpackage-form package :export symbol)) + (message "Symbol `%s' now exported from `%s'" + symbol package) + (message "Symbol `%s' already exported from `%s'" + symbol package)) + (slime-export-symbol symbol package))))) + +(defun slime-export-class (name) + "Export acessors, constructors, etc. associated with a structure or a class" + (interactive (list (slime-read-from-minibuffer "Export structure named: " + (slime-symbol-at-point)))) + (let* ((package (slime-current-package)) + (symbols (slime-eval `(swank:export-structure ,name ,package)))) + (message "%s symbols exported from `%s'" + (slime-frob-defpackage-form package :export symbols) + package))) + +(defalias 'slime-export-structure 'slime-export-class) + +(provide 'slime-package-fu) + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: diff --git a/elpa/slime-20200319.1939/contrib/slime-package-fu.elc b/elpa/slime-20200319.1939/contrib/slime-package-fu.elc new file mode 100644 index 00000000..e0164da2 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-package-fu.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-parse.el b/elpa/slime-20200319.1939/contrib/slime-parse.el new file mode 100644 index 00000000..ed81eb3d --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-parse.el @@ -0,0 +1,358 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-parse + "Utility contrib containg functions to parse forms in a buffer." + (:authors "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:license "GPL")) + +(defun slime-parse-form-until (limit form-suffix) + "Parses form from point to `limit'." + ;; For performance reasons, this function does not use recursion. + (let ((todo (list (point))) ; stack of positions + (sexps) ; stack of expressions + (cursexp) + (curpos) + (depth 1)) ; This function must be called from the + ; start of the sexp to be parsed. + (while (and (setq curpos (pop todo)) + (progn + (goto-char curpos) + ;; (Here we also move over suppressed + ;; reader-conditionalized code! Important so CL-side + ;; of autodoc won't see that garbage.) + (ignore-errors (slime-forward-cruft)) + (< (point) limit))) + (setq cursexp (pop sexps)) + (cond + ;; End of an sexp? + ((or (looking-at "\\s)") (eolp)) + (cl-decf depth) + (push (nreverse cursexp) (car sexps))) + ;; Start of a new sexp? + ((looking-at "\\s'*@*\\s(") + (let ((subpt (match-end 0))) + (ignore-errors + (forward-sexp) + ;; (In case of error, we're at an incomplete sexp, and + ;; nothing's left todo after it.) + (push (point) todo)) + (push cursexp sexps) + (push subpt todo) ; to descend into new sexp + (push nil sexps) + (cl-incf depth))) + ;; In mid of an sexp.. + (t + (let ((pt1 (point)) + (pt2 (condition-case e + (progn (forward-sexp) (point)) + (scan-error + (cl-fourth e))))) ; end of sexp + (push (buffer-substring-no-properties pt1 pt2) cursexp) + (push pt2 todo) + (push cursexp sexps))))) + (when sexps + (setf (car sexps) (cl-nreconc form-suffix (car sexps))) + (while (> depth 1) + (push (nreverse (pop sexps)) (car sexps)) + (cl-decf depth)) + (nreverse (car sexps))))) + +(defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped) + "Returns t if the character that `get-char-fn' yields has +characer syntax of `syntax'. If `unescaped' is true, it's ensured +that the character is not escaped." + (let ((char (funcall get-char-fn (point))) + (char-before (funcall get-char-fn (1- (point))))) + (if (and char (eq (char-syntax char) (aref syntax 0))) + (if unescaped + (or (null char-before) + (not (eq (char-syntax char-before) ?\\))) + t) + nil))) + +(defconst slime-cursor-marker 'swank::%cursor-marker%) + +(defun slime-parse-form-upto-point (&optional max-levels) + (save-restriction + ;; Don't parse more than 500 lines before point, so we don't spend + ;; too much time. NB. Make sure to go to beginning of line, and + ;; not possibly anywhere inside comments or strings. + (narrow-to-region (line-beginning-position -500) (point-max)) + (save-excursion + (let ((suffix (list slime-cursor-marker))) + (cond ((slime-compare-char-syntax #'char-after "(" t) + ;; We're at the start of some expression, so make sure + ;; that SWANK::%CURSOR-MARKER% will come after that + ;; expression. If the expression is not balanced, make + ;; still sure that the marker does *not* come directly + ;; after the preceding expression. + (or (ignore-errors (forward-sexp) t) + (push "" suffix))) + ((or (bolp) (slime-compare-char-syntax #'char-before " " t)) + ;; We're after some expression, so we have to make sure + ;; that %CURSOR-MARKER% does *not* come directly after + ;; that expression. + (push "" suffix)) + ((slime-compare-char-syntax #'char-before "(" t) + ;; We're directly after an opening parenthesis, so we + ;; have to make sure that something comes before + ;; %CURSOR-MARKER%. + (push "" suffix)) + (t + ;; We're at a symbol, so make sure we get the whole symbol. + (slime-end-of-symbol))) + (let ((pt (point))) + (ignore-errors (up-list (if max-levels (- max-levels) -5))) + (ignore-errors (down-list)) + (slime-parse-form-until pt suffix)))))) + +(require 'bytecomp) + +(mapc (lambda (sym) + (cond ((fboundp sym) + (unless (byte-code-function-p (symbol-function sym)) + (byte-compile sym))) + (t (error "%S is not fbound" sym)))) + '(slime-parse-form-upto-point + slime-parse-form-until + slime-compare-char-syntax)) + +;;;; Test cases +(defun slime-extract-context () + "Parse the context for the symbol at point. +Nil is returned if there's no symbol at point. Otherwise we detect +the following cases (the . shows the point position): + + (defun n.ame (...) ...) -> (:defun name) + (defun (setf n.ame) (...) ...) -> (:defun (setf name)) + (defmethod n.ame (...) ...) -> (:defmethod name (...)) + (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) + (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) + (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) + (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) + + (defmacro n.ame (...) ...) -> (:defmacro name) + (defsetf n.ame (...) ...) -> (:defsetf name) + (define-setf-expander n.ame (...) ...) -> (:define-setf-expander name) + (define-modify-macro n.ame (...) ...) -> (:define-modify-macro name) + (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name) + (defvar n.ame (...) ...) -> (:defvar name) + (defparameter n.ame ...) -> (:defparameter name) + (defconstant n.ame ...) -> (:defconstant name) + (defclass n.ame ...) -> (:defclass name) + (defstruct n.ame ...) -> (:defstruct name) + (defpackage n.ame ...) -> (:defpackage name) +For other contexts we return the symbol at point." + (let ((name (slime-symbol-at-point))) + (if name + (let ((symbol (read name))) + (or (progn ;;ignore-errors + (slime-parse-context symbol)) + symbol))))) + +(defun slime-parse-context (name) + (save-excursion + (cond ((slime-in-expression-p '(defun *)) `(:defun ,name)) + ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name)) + ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) + ((slime-in-expression-p '(setf *)) + ;;a setf-definition, but which? + (backward-up-list 1) + (slime-parse-context `(setf ,name))) + ((slime-in-expression-p '(defmethod *)) + (unless (looking-at "\\s ") + (forward-sexp 1)) ; skip over the methodname + (let (qualifiers arglist) + (cl-loop for e = (read (current-buffer)) + until (listp e) do (push e qualifiers) + finally (setq arglist e)) + `(:defmethod ,name ,@qualifiers + ,(slime-arglist-specializers arglist)))) + ((and (symbolp name) + (slime-in-expression-p `(,name))) + ;; looks like a regular call + (let ((toplevel (ignore-errors (slime-parse-toplevel-form)))) + (cond ((slime-in-expression-p `(setf (*))) ;a setf-call + (if toplevel + `(:call ,toplevel (setf ,name)) + `(setf ,name))) + ((not toplevel) + name) + ((slime-in-expression-p `(labels ((*)))) + `(:labels ,toplevel ,name)) + ((slime-in-expression-p `(flet ((*)))) + `(:flet ,toplevel ,name)) + (t + `(:call ,toplevel ,name))))) + ((slime-in-expression-p '(define-compiler-macro *)) + `(:define-compiler-macro ,name)) + ((slime-in-expression-p '(define-modify-macro *)) + `(:define-modify-macro ,name)) + ((slime-in-expression-p '(define-setf-expander *)) + `(:define-setf-expander ,name)) + ((slime-in-expression-p '(defsetf *)) + `(:defsetf ,name)) + ((slime-in-expression-p '(defvar *)) `(:defvar ,name)) + ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name)) + ((slime-in-expression-p '(defconstant *)) `(:defconstant ,name)) + ((slime-in-expression-p '(defclass *)) `(:defclass ,name)) + ((slime-in-expression-p '(defpackage *)) `(:defpackage ,name)) + ((slime-in-expression-p '(defstruct *)) + `(:defstruct ,(if (consp name) + (car name) + name))) + (t + name)))) + + +(defun slime-in-expression-p (pattern) + "A helper function to determine the current context. +The pattern can have the form: + pattern ::= () ;matches always + | (*) ;matches inside a list + | ( ) ;matches if the first element in + ; the current list is and + ; if matches. + | (()) ;matches if we are in a nested list." + (save-excursion + (let ((path (reverse (slime-pattern-path pattern)))) + (cl-loop for p in path + always (ignore-errors + (cl-etypecase p + (symbol (slime-beginning-of-list) + (eq (read (current-buffer)) p)) + (number (backward-up-list p) + t))))))) + +(defun slime-pattern-path (pattern) + ;; Compute the path to the * in the pattern to make matching + ;; easier. The path is a list of symbols and numbers. A number + ;; means "(down-list )" and a symbol "(look-at )") + (if (null pattern) + '() + (cl-etypecase (car pattern) + ((member *) '()) + (symbol (cons (car pattern) (slime-pattern-path (cdr pattern)))) + (cons (cons 1 (slime-pattern-path (car pattern))))))) + +(defun slime-beginning-of-list (&optional up) + "Move backward to the beginning of the current expression. +Point is placed before the first expression in the list." + (backward-up-list (or up 1)) + (down-list 1) + (skip-syntax-forward " ")) + +(defun slime-end-of-list (&optional up) + (backward-up-list (or up 1)) + (forward-list 1) + (down-list -1)) + +(defun slime-parse-toplevel-form () + (ignore-errors ; (foo) + (save-excursion + (goto-char (car (slime-region-for-defun-at-point))) + (down-list 1) + (forward-sexp 1) + (slime-parse-context (read (current-buffer)))))) + +(defun slime-arglist-specializers (arglist) + (cond ((or (null arglist) + (member (cl-first arglist) '(&optional &key &rest &aux))) + (list)) + ((consp (cl-first arglist)) + (cons (cl-second (cl-first arglist)) + (slime-arglist-specializers (cl-rest arglist)))) + (t + (cons 't + (slime-arglist-specializers (cl-rest arglist)))))) + +(defun slime-definition-at-point (&optional only-functional) + "Return object corresponding to the definition at point." + (let ((toplevel (slime-parse-toplevel-form))) + (if (or (symbolp toplevel) + (and only-functional + (not (member (car toplevel) + '(:defun :defgeneric :defmethod + :defmacro :define-compiler-macro))))) + (error "Not in a definition") + (slime-dcase toplevel + (((:defun :defgeneric) symbol) + (format "#'%s" symbol)) + (((:defmacro :define-modify-macro) symbol) + (format "(macro-function '%s)" symbol)) + ((:define-compiler-macro symbol) + (format "(compiler-macro-function '%s)" symbol)) + ((:defmethod symbol &rest args) + (declare (ignore args)) + (format "#'%s" symbol)) + (((:defparameter :defvar :defconstant) symbol) + (format "'%s" symbol)) + (((:defclass :defstruct) symbol) + (format "(find-class '%s)" symbol)) + ((:defpackage symbol) + (format "(or (find-package '%s) (error \"Package %s not found\"))" + symbol symbol)) + (t + (error "Not in a definition")))))) + +(defsubst slime-current-parser-state () + ;; `syntax-ppss' does not save match data as it invokes + ;; `beginning-of-defun' implicitly which does not save match + ;; data. This issue has been reported to the Emacs maintainer on + ;; Feb27. + (syntax-ppss)) + +(defun slime-inside-string-p () + (nth 3 (slime-current-parser-state))) + +(defun slime-inside-comment-p () + (nth 4 (slime-current-parser-state))) + +(defun slime-inside-string-or-comment-p () + (let ((state (slime-current-parser-state))) + (or (nth 3 state) (nth 4 state)))) + +;;; The following two functions can be handy when inspecting +;;; source-location while debugging `M-.'. +;;; +(defun slime-current-tlf-number () + "Return the current toplevel number." + (interactive) + (let ((original-pos (car (slime-region-for-defun-at-point))) + (n 0)) + (save-excursion + ;; We use this and no repeated `beginning-of-defun's to get + ;; reader conditionals right. + (goto-char (point-min)) + (while (progn (slime-forward-sexp) + (< (point) original-pos)) + (cl-incf n))) + n)) + +;;; This is similiar to `slime-enclosing-form-paths' in the +;;; `slime-parse' contrib except that this does not do any duck-tape +;;; parsing, and gets reader conditionals right. +(defun slime-current-form-path () + "Returns the path from the beginning of the current toplevel +form to the atom at point, or nil if we're in front of a tlf." + (interactive) + (let ((source-path nil)) + (save-excursion + ;; Moving forward to get reader conditionals right. + (cl-loop for inner-pos = (point) + for outer-pos = (cl-nth-value 1 (slime-current-parser-state)) + while outer-pos do + (goto-char outer-pos) + (unless (eq (char-before) ?#) ; when at #(...) continue. + (forward-char) + (let ((n 0)) + (while (progn (slime-forward-sexp) + (< (point) inner-pos)) + (cl-incf n)) + (push n source-path) + (goto-char outer-pos))))) + source-path)) + +(provide 'slime-parse) diff --git a/elpa/slime-20200319.1939/contrib/slime-parse.elc b/elpa/slime-20200319.1939/contrib/slime-parse.elc new file mode 100644 index 00000000..c1047963 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-parse.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-presentation-streams.el b/elpa/slime-20200319.1939/contrib/slime-presentation-streams.el new file mode 100644 index 00000000..786c549c --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-presentation-streams.el @@ -0,0 +1,18 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-presentation-streams + "Streams that allow attaching object identities to portions of + output." + (:authors "Alan Ruttenberg " + "Matthias Koeppe " + "Helmut Eller ") + (:license "GPL") + (:on-load + (add-hook 'slime-connected-hook 'slime-presentation-streams-on-connected)) + (:swank-dependencies swank-presentation-streams)) + +(defun slime-presentation-streams-on-connected () + (slime-eval `(swank:init-presentation-streams))) + +(provide 'slime-presentation-streams) diff --git a/elpa/slime-20200319.1939/contrib/slime-presentation-streams.elc b/elpa/slime-20200319.1939/contrib/slime-presentation-streams.elc new file mode 100644 index 00000000..4f82b7f5 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-presentation-streams.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-presentations.el b/elpa/slime-20200319.1939/contrib/slime-presentations.el new file mode 100644 index 00000000..75bf7d03 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-presentations.el @@ -0,0 +1,872 @@ +(require 'slime) +(require 'bridge) +(require 'cl-lib) +(eval-when-compile + (require 'cl)) + +(define-slime-contrib slime-presentations + "Imitate LispM presentations." + (:authors "Alan Ruttenberg " + "Matthias Koeppe ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-presentations) + (:on-load + (add-hook 'slime-repl-mode-hook + (lambda () + ;; Respect the syntax text properties of presentation. + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (add-hook 'after-change-functions + 'slime-after-change-function 'append t))) + (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event) + (setq slime-write-string-function 'slime-presentation-write) + (add-hook 'slime-connected-hook 'slime-presentations-on-connected) + (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) + (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) + (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) + (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) + (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation) + (setq sldb-insert-frame-variable-value-function + 'slime-presentation-sldb-insert-frame-variable-value) + (slime-presentation-init-keymaps) + (slime-presentation-add-easy-menu))) + +;; To get presentations in the inspector as well, add this to your +;; init file. +;; +;; (eval-after-load 'slime-presentations +;; '(setq slime-inspector-insert-ispec-function +;; 'slime-presentation-inspector-insert-ispec)) +;; +(defface slime-repl-output-mouseover-face + '((t (:box (:line-width 1 :color "black" :style released-button) + :inherit slime-repl-inputed-output-face))) + "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" + :group 'slime-repl) + +(defface slime-repl-inputed-output-face + '((((class color) (background light)) (:foreground "Red")) + (((class color) (background dark)) (:foreground "light salmon")) + (t (:slant italic))) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +;; FIXME: This conditional is not right - just used because the code +;; here does not work in XEmacs. +(when (boundp 'text-property-default-nonsticky) + (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky + :test 'equal) + (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky + :test 'equal)) + +(make-variable-buffer-local + (defvar slime-presentation-start-to-point (make-hash-table))) + +(defun slime-mark-presentation-start (id &optional target) + "Mark the beginning of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (setf (gethash id slime-presentation-start-to-point) + ;; We use markers because text can also be inserted before this presentation. + ;; (Output arrives while we are writing presentations within REPL results.) + (copy-marker (slime-repl-output-target-marker target) nil))) + +(defun slime-mark-presentation-start-handler (process string) + (if (and string (string-match "<\\([-0-9]+\\)" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-start id)))) + +(defun slime-mark-presentation-end (id &optional target) + "Mark the end of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (let ((start (gethash id slime-presentation-start-to-point))) + (remhash id slime-presentation-start-to-point) + (when start + (let* ((marker (slime-repl-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (with-current-buffer buffer + (let ((end (marker-position marker))) + (slime-add-presentation-properties start end + id nil))))))) + +(defun slime-mark-presentation-end-handler (process string) + (if (and string (string-match ">\\([-0-9]+\\)" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-end id)))) + +(cl-defstruct slime-presentation text id) + +(defvar slime-presentation-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This allows to use C-M-k, C-M-SPC, + ;; etc. to deal with a whole presentation. (For Lisp mode, this + ;; is not desirable, since we do not wish to get a mismatched + ;; paren highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(>" table) + (modify-syntax-entry ?> ")<" table) + table) + "Syntax table for presentations.") + +(defun slime-add-presentation-properties (start end id result-p) + "Make the text between START and END a presentation with ID. +RESULT-P decides whether a face for a return value or output text is used." + (let* ((text (buffer-substring-no-properties start end)) + (presentation (make-slime-presentation :text text :id id))) + (let ((inhibit-modification-hooks t)) + (add-text-properties start end + `(modification-hooks (slime-after-change-function) + insert-in-front-hooks (slime-after-change-function) + insert-behind-hooks (slime-after-change-function) + syntax-table ,slime-presentation-syntax-table + rear-nonsticky t)) + ;; Use the presentation as the key of a text property + (case (- end start) + (0) + (1 + (add-text-properties start end + `(slime-repl-presentation ,presentation + ,presentation :start-and-end))) + (t + (add-text-properties start (1+ start) + `(slime-repl-presentation ,presentation + ,presentation :start)) + (when (> (- end start) 2) + (add-text-properties (1+ start) (1- end) + `(,presentation :interior))) + (add-text-properties (1- end) end + `(slime-repl-presentation ,presentation + ,presentation :end)))) + ;; Also put an overlay for the face and the mouse-face. This enables + ;; highlighting of nested presentations. However, overlays get lost + ;; when we copy a presentation; their removal is also not undoable. + ;; In these cases the mouse-face text properties need to take over --- + ;; but they do not give nested highlighting. + (slime-ensure-presentation-overlay start end presentation)))) + +(defvar slime-presentation-map (make-sparse-keymap)) + +(defun slime-ensure-presentation-overlay (start end presentation) + (unless (cl-find presentation (overlays-at start) + :key (lambda (overlay) + (overlay-get overlay 'slime-repl-presentation))) + (let ((overlay (make-overlay start end (current-buffer) t nil))) + (overlay-put overlay 'slime-repl-presentation presentation) + (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) + (overlay-put overlay 'help-echo + (if (eq major-mode 'slime-repl-mode) + "mouse-2: copy to input; mouse-3: menu" + "mouse-2: inspect; mouse-3: menu")) + (overlay-put overlay 'face 'slime-repl-inputed-output-face) + (overlay-put overlay 'keymap slime-presentation-map)))) + +(defun slime-remove-presentation-properties (from to presentation) + (let ((inhibit-read-only t)) + (remove-text-properties from to + `(,presentation t syntax-table t rear-nonsticky t)) + (when (eq (get-text-property from 'slime-repl-presentation) presentation) + (remove-text-properties from (1+ from) `(slime-repl-presentation t))) + (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) + (remove-text-properties (1- to) to `(slime-repl-presentation t))) + (dolist (overlay (overlays-at from)) + (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) + (delete-overlay overlay))))) + +(defun slime-insert-presentation (string output-id &optional rectangle) + "Insert STRING in current buffer and mark it as a presentation +corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line +strings to line up below the current point." + (cl-labels ((insert-it () + (if rectangle + (slime-insert-indented string) + (insert string)))) + (let ((start (point))) + (insert-it) + (slime-add-presentation-properties start (point) output-id t)))) + +(defun slime-presentation-whole-p (presentation start end &optional object) + (let ((object (or object (current-buffer)))) + (string= (etypecase object + (buffer (with-current-buffer object + (buffer-substring-no-properties start end))) + (string (substring-no-properties object start end))) + (slime-presentation-text presentation)))) + +(defun slime-presentations-around-point (point &optional object) + (let ((object (or object (current-buffer)))) + (loop for (key value . rest) on (text-properties-at point object) by 'cddr + when (slime-presentation-p key) + collect key))) + +(defun slime-presentation-start-p (tag) + (memq tag '(:start :start-and-end))) + +(defun slime-presentation-stop-p (tag) + (memq tag '(:end :start-and-end))) + +(cl-defun slime-presentation-start (point presentation + &optional (object (current-buffer))) + "Find start of `presentation' at `point' in `object'. +Return buffer index and whether a start-tag was found." + (let* ((this-presentation (get-text-property point presentation object))) + (while (not (slime-presentation-start-p this-presentation)) + (let ((change-point (previous-single-property-change + point presentation object (point-min)))) + (unless change-point + (return-from slime-presentation-start + (values (etypecase object + (buffer (with-current-buffer object 1)) + (string 0)) + nil))) + (setq this-presentation (get-text-property change-point + presentation object)) + (unless this-presentation + (return-from slime-presentation-start + (values point nil))) + (setq point change-point))) + (values point t))) + +(cl-defun slime-presentation-end (point presentation + &optional (object (current-buffer))) + "Find end of presentation at `point' in `object'. Return buffer +index (after last character of the presentation) and whether an +end-tag was found." + (let* ((this-presentation (get-text-property point presentation object))) + (while (not (slime-presentation-stop-p this-presentation)) + (let ((change-point (next-single-property-change + point presentation object))) + (unless change-point + (return-from slime-presentation-end + (values (etypecase object + (buffer (with-current-buffer object (point-max))) + (string (length object))) + nil))) + (setq point change-point) + (setq this-presentation (get-text-property point + presentation object)))) + (if this-presentation + (let ((after-end (next-single-property-change point + presentation object))) + (if (not after-end) + (values (etypecase object + (buffer (with-current-buffer object (point-max))) + (string (length object))) + t) + (values after-end t))) + (values point nil)))) + +(cl-defun slime-presentation-bounds (point presentation + &optional (object (current-buffer))) + "Return start index and end index of `presentation' around `point' +in `object', and whether the presentation is complete." + (multiple-value-bind (start good-start) + (slime-presentation-start point presentation object) + (multiple-value-bind (end good-end) + (slime-presentation-end point presentation object) + (values start end + (and good-start good-end + (slime-presentation-whole-p presentation + start end object)))))) + +(defun slime-presentation-around-point (point &optional object) + "Return presentation, start index, end index, and whether the +presentation is complete." + (let ((object (or object (current-buffer))) + (innermost-presentation nil) + (innermost-start 0) + (innermost-end most-positive-fixnum)) + (dolist (presentation (slime-presentations-around-point point object)) + (multiple-value-bind (start end whole-p) + (slime-presentation-bounds point presentation object) + (when whole-p + (when (< (- end start) (- innermost-end innermost-start)) + (setq innermost-start start + innermost-end end + innermost-presentation presentation))))) + (values innermost-presentation + innermost-start innermost-end))) + +(defun slime-presentation-around-or-before-point (point &optional object) + (let ((object (or object (current-buffer)))) + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-point point object) + (if (or presentation (= point (point-min))) + (values presentation start end whole-p) + (slime-presentation-around-point (1- point) object))))) + +(defun slime-presentation-around-or-before-point-or-error (point) + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-or-before-point point) + (unless presentation + (error "No presentation at point")) + (values presentation start end whole-p))) + +(cl-defun slime-for-each-presentation-in-region (from to function + &optional (object (current-buffer))) + "Call `function' with arguments `presentation', `start', `end', +`whole-p' for every presentation in the region `from'--`to' in the +string or buffer `object'." + (cl-labels ((handle-presentation (presentation point) + (multiple-value-bind (start end whole-p) + (slime-presentation-bounds point presentation object) + (funcall function presentation start end whole-p)))) + ;; Handle presentations active at `from'. + (dolist (presentation (slime-presentations-around-point from object)) + (handle-presentation presentation from)) + ;; Use the `slime-repl-presentation' property to search for new presentations. + (let ((point from)) + (while (< point to) + (setq point (next-single-property-change point 'slime-repl-presentation + object to)) + (let* ((presentation (get-text-property point 'slime-repl-presentation object)) + (status (get-text-property point presentation object))) + (when (slime-presentation-start-p status) + (handle-presentation presentation point))))))) + +;; XEmacs compatibility hack, from message by Stephen J. Turnbull on +;; xemacs-beta@xemacs.org of 18 Mar 2002 +(unless (boundp 'undo-in-progress) + (defvar undo-in-progress nil + "Placeholder defvar for XEmacs compatibility from SLIME.") + (defadvice undo-more (around slime activate) + (let ((undo-in-progress t)) ad-do-it))) + +(defun slime-after-change-function (start end &rest ignore) + "Check all presentations within and adjacent to the change. +When a presentation has been altered, change it to plain text." + (let ((inhibit-modification-hooks t)) + (let ((real-start (max 1 (1- start))) + (real-end (min (1+ (buffer-size)) (1+ end))) + (any-change nil)) + ;; positions around the change + (slime-for-each-presentation-in-region + real-start real-end + (lambda (presentation from to whole-p) + (cond + (whole-p + (slime-ensure-presentation-overlay from to presentation)) + ((not undo-in-progress) + (slime-remove-presentation-properties from to + presentation) + (setq any-change t))))) + (when any-change + (undo-boundary))))) + +(defun slime-presentation-around-click (event) + "Return the presentation around the position of the mouse-click EVENT. +If there is no presentation, signal an error. +Also return the start position, end position, and buffer of the presentation." + (when (and (featurep 'xemacs) (not (button-press-event-p event))) + (error "Command must be bound to a button-press-event")) + (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event)))) + (with-current-buffer (window-buffer window) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point point) + (unless presentation + (error "No presentation at click")) + (values presentation start end (current-buffer)))))) + +(defun slime-check-presentation (from to buffer presentation) + (unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object + ',(slime-presentation-id presentation)))) + (with-current-buffer buffer + (slime-remove-presentation-properties from to presentation)))) + +(defun slime-copy-or-inspect-presentation-at-mouse (event) + (interactive "e") ; no "@" -- we don't want to select the clicked-at window + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (slime-check-presentation start end buffer presentation) + (if (with-current-buffer buffer + (eq major-mode 'slime-repl-mode)) + (slime-copy-presentation-at-mouse-to-repl event) + (slime-inspect-presentation-at-mouse event)))) + +(defun slime-inspect-presentation (presentation start end buffer) + (let ((reset-p + (with-current-buffer buffer + (not (eq major-mode 'slime-inspector-mode))))) + (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) + 'slime-open-inspector))) + +(defun slime-inspect-presentation-at-mouse (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (slime-inspect-presentation presentation start end buffer))) + +(defun slime-inspect-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-inspect-presentation presentation start end (current-buffer)))) + + +(defun slime-M-.-presentation (presentation start end buffer &optional where) + (let* ((id (slime-presentation-id presentation)) + (presentation-string (format "Presentation %s" id)) + (location (slime-eval `(swank:find-definition-for-thing + (swank:lookup-presented-object + ',(slime-presentation-id presentation)))))) + (unless (eq (car location) :error) + (slime-edit-definition-cont + (and location (list (make-slime-xref :dspec `(,presentation-string) + :location location))) + presentation-string + where)))) + +(defun slime-M-.-presentation-at-mouse (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (slime-M-.-presentation presentation start end buffer))) + +(defun slime-M-.-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-M-.-presentation presentation start end (current-buffer)))) + +(defun slime-edit-presentation (name &optional where) + (if (or current-prefix-arg (not (equal (slime-symbol-at-point) name))) + nil ; NAME came from user explicitly, so decline. + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-or-before-point (point)) + (when presentation + (slime-M-.-presentation presentation start end (current-buffer) where))))) + +(defun slime-copy-presentation-to-repl (presentation start end buffer) + (let ((text (with-current-buffer buffer + ;; we use the buffer-substring rather than the + ;; presentation text to capture any overlays + (buffer-substring start end))) + (id (slime-presentation-id presentation))) + (unless (integerp id) + (setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id)))) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (cl-flet ((do-insertion () + (unless (looking-back "\\s-" (- (point) 1)) + (insert " ")) + (slime-insert-presentation text id) + (unless (or (eolp) (looking-at "\\s-")) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion)))))) + +(defun slime-copy-presentation-at-mouse-to-repl (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (slime-copy-presentation-to-repl presentation start end buffer))) + +(defun slime-copy-presentation-at-point-to-repl (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-copy-presentation-to-repl presentation start end (current-buffer)))) + +(defun slime-copy-presentation-at-mouse-to-point (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (slime-after-change-function (point) (point)) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " "))))) + +(defun slime-copy-presentation-to-kill-ring (presentation start end buffer) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (kill-new presentation-text) + (message "Saved presentation \"%s\" to kill ring" presentation-text))) + +(defun slime-copy-presentation-at-mouse-to-kill-ring (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (slime-copy-presentation-to-kill-ring presentation start end buffer))) + +(defun slime-copy-presentation-at-point-to-kill-ring (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (slime-copy-presentation-to-kill-ring presentation start end (current-buffer)))) + +(defun slime-describe-presentation (presentation) + (slime-eval-describe + `(swank::describe-to-string + (swank:lookup-presented-object ',(slime-presentation-id presentation))))) + +(defun slime-describe-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-describe-presentation presentation))) + +(defun slime-describe-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation) + (slime-presentation-around-or-before-point-or-error point) + (slime-describe-presentation presentation))) + +(defun slime-pretty-print-presentation (presentation) + (slime-eval-describe + `(swank::swank-pprint + (cl:list + (swank:lookup-presented-object ',(slime-presentation-id presentation)))))) + +(defun slime-pretty-print-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-pretty-print-presentation presentation))) + +(defun slime-pretty-print-presentation-at-point (point) + (interactive "d") + (multiple-value-bind (presentation) + (slime-presentation-around-or-before-point-or-error point) + (slime-pretty-print-presentation presentation))) + +(defun slime-mark-presentation (point) + (interactive "d") + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error point) + (goto-char start) + (push-mark end nil t))) + +(defun slime-previous-presentation (&optional arg) + "Move point to the beginning of the first presentation before point. +With ARG, do this that many times. +A negative argument means move forward instead." + (interactive "p") + (unless arg (setq arg 1)) + (slime-next-presentation (- arg))) + +(defun slime-next-presentation (&optional arg) + "Move point to the beginning of the next presentation after point. +With ARG, do this that many times. +A negative argument means move backward instead." + (interactive "p") + (unless arg (setq arg 1)) + (cond + ((plusp arg) + (dotimes (i arg) + ;; First skip outside the current surrounding presentation (if any) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point (point)) + (when presentation + (goto-char end))) + (let ((p (next-single-property-change (point) 'slime-repl-presentation))) + (unless p + (error "No next presentation")) + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error p) + (goto-char start))))) + ((minusp arg) + (dotimes (i (- arg)) + ;; First skip outside the current surrounding presentation (if any) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point (point)) + (when presentation + (goto-char start))) + (let ((p (previous-single-property-change (point) 'slime-repl-presentation))) + (unless p + (error "No previous presentation")) + (multiple-value-bind (presentation start end) + (slime-presentation-around-or-before-point-or-error p) + (goto-char start))))))) + +(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse) +(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) + +(when (featurep 'xemacs) + (define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse) + (define-key slime-presentation-map [button3] 'slime-presentation-menu)) + +;; protocol for handling up a menu. +;; 1. Send lisp message asking for menu choices for this object. +;; Get back list of strings. +;; 2. Let used choose +;; 3. Call back to execute menu choice, passing nth and string of choice + +(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda) + "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'." + (let* ((what (slime-presentation-id presentation)) + (choices (with-current-buffer buffer + (slime-eval + `(swank::menu-choices-for-presentation-id ',what))))) + (cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name + (let ((sym (cl-gensym))) + (setf (gethash sym choice-to-lambda) f) + sym))) + (etypecase choices + (list + `(,(format "Presentation %s" (truncate-string-to-width + (slime-presentation-text presentation) + 30 nil nil t)) + ("" + ("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse)) + ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) + ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) + ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) + ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl)) + ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring)) + ,@(unless buffer-read-only + `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point)))) + ,@(let ((nchoice 0)) + (mapcar + (lambda (choice) + (incf nchoice) + (cons choice + (savel `(lambda () + (interactive) + (slime-eval + '(swank::execute-menu-choice-for-presentation-id + ',what ,nchoice ,(nth (1- nchoice) choices))))))) + choices))))) + (symbol ; not-present + (with-current-buffer buffer + (slime-remove-presentation-properties from to presentation)) + (sit-for 0) ; allow redisplay + `("Object no longer recorded" + ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))))))) + +(defun slime-presentation-menu (event) + (interactive "e") + (let* ((point (if (featurep 'xemacs) (event-point event) + (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event))) + (buffer (window-buffer window)) + (choice-to-lambda (make-hash-table))) + (multiple-value-bind (presentation from to) + (with-current-buffer buffer + (slime-presentation-around-point point)) + (unless presentation + (error "No presentation at event position")) + (let ((menu (slime-menu-choices-for-presentation + presentation buffer from to choice-to-lambda))) + (let ((choice (x-popup-menu event menu))) + (when choice + (call-interactively (gethash choice choice-to-lambda)))))))) + +(defun slime-presentation-expression (presentation) + "Return a string that contains a CL s-expression accessing +the presented object." + (let ((id (slime-presentation-id presentation))) + (etypecase id + (number + ;; Make sure it works even if *read-base* is not 10. + (format "(swank:lookup-presented-object-or-lose %d.)" id)) + (list + ;; for frame variables and inspector parts + (format "(swank:lookup-presented-object-or-lose '%s)" id))))) + +(defun slime-buffer-substring-with-reified-output (start end) + (let ((str-props (buffer-substring start end)) + (str-no-props (buffer-substring-no-properties start end))) + (slime-reify-old-output str-props str-no-props))) + +(defun slime-reify-old-output (str-props str-no-props) + (let ((pos (slime-property-position 'slime-repl-presentation str-props))) + (if (null pos) + str-no-props + (multiple-value-bind (presentation start-pos end-pos whole-p) + (slime-presentation-around-point pos str-props) + (if (not presentation) + str-no-props + (concat (substring str-no-props 0 pos) + ;; Eval in the reader so that we play nice with quote. + ;; -luke (19/May/2005) + "#." (slime-presentation-expression presentation) + (slime-reify-old-output (substring str-props end-pos) + (substring str-no-props end-pos)))))))) + + + +(defun slime-repl-grab-old-output (replace) + "Resend the old REPL output at point. +If replace it non-nil the current input is replaced with the old +output; otherwise the new input is appended." + (multiple-value-bind (presentation beg end) + (slime-presentation-around-or-before-point (point)) + (slime-check-presentation beg end (current-buffer) presentation) + (let ((old-output (buffer-substring beg end))) ;;keep properties + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char (point-max)) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) (point-max)) + (let ((inhibit-read-only t)) + (insert old-output))))) + +;;; Presentation-related key bindings, non-context menu + +(defvar slime-presentation-command-map nil + "Keymap for presentation-related commands. Bound to a prefix key.") + +(defvar slime-presentation-bindings + '((?i slime-inspect-presentation-at-point) + (?d slime-describe-presentation-at-point) + (?w slime-copy-presentation-at-point-to-kill-ring) + (?r slime-copy-presentation-at-point-to-repl) + (?p slime-previous-presentation) + (?n slime-next-presentation) + (?\ slime-mark-presentation))) + +(defun slime-presentation-init-keymaps () + (slime-init-keymap 'slime-presentation-command-map nil t + slime-presentation-bindings) + (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations) + ;; C-c C-v is the prefix for the presentation-command map. + (define-key slime-prefix-map "\C-v" slime-presentation-command-map)) + +(defun slime-presentation-around-or-before-point-p () + (multiple-value-bind (presentation beg end) + (slime-presentation-around-or-before-point (point)) + presentation)) + +(defvar slime-presentation-easy-menu + (let ((P '(slime-presentation-around-or-before-point-p))) + `("Presentations" + [ "Find Definition" slime-M-.-presentation-at-point ,P ] + [ "Inspect" slime-inspect-presentation-at-point ,P ] + [ "Describe" slime-describe-presentation-at-point ,P ] + [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ] + [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ] + [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ] + [ "Mark" slime-mark-presentation ,P ] + "--" + [ "Previous presentation" slime-previous-presentation ] + [ "Next presentation" slime-next-presentation ] + "--" + [ "Clear all presentations" slime-clear-presentations ]))) + +(defun slime-presentation-add-easy-menu () + (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu) + (easy-menu-add slime-presentation-easy-menu 'slime-mode-map) + (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map) + (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map) + (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map)) + +;;; hook functions (hard to isolate stuff) + +(defun slime-dispatch-presentation-event (event) + (slime-dcase event + ((:presentation-start id &optional target) + (slime-mark-presentation-start id target) + t) + ((:presentation-end id &optional target) + (slime-mark-presentation-end id target) + t) + (t nil))) + +(defun slime-presentation-write-result (string) + (with-current-buffer (slime-output-buffer) + (let ((marker (slime-repl-output-target-marker :repl-result)) + (saved-point (point-marker))) + (goto-char marker) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert string)) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point)) + (set-marker slime-output-end (point)) + ;; Restore point before insertion but only it if was farther + ;; than `marker'. Omitting this breaks REPL test + ;; `repl-type-ahead'. + (when (> saved-point (point)) + (goto-char saved-point))) + (slime-repl-show-maximum-output))) + +(defun slime-presentation-write (string &optional target) + (case target + ((nil) ; Regular process output + (slime-repl-emit string)) + (:repl-result + (slime-presentation-write-result string)) + (t (slime-repl-emit-to-target string target)))) + +(defun slime-presentation-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer. Presentations of old results are expanded into code." + (slime-buffer-substring-with-reified-output (slime-repl-history-yank-start) + (if until-point-p + (point) + (point-max)))) + +(defun slime-presentation-on-return-pressed (end-of-input) + (when (and (car (slime-presentation-around-or-before-point (point))) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-output end-of-input) + (slime-repl-recenter-if-needed) + t)) + +(defun slime-presentation-bridge-insert (process output) + (slime-output-filter process (or output ""))) + +(defun slime-presentation-on-stream-open (stream) + (install-bridge) + (setq bridge-insert-function #'slime-presentation-bridge-insert) + (setq bridge-destination-insert nil) + (setq bridge-source-insert nil) + (setq bridge-handlers + (list* '("<" . slime-mark-presentation-start-handler) + '(">" . slime-mark-presentation-end-handler) + bridge-handlers))) + +(defun slime-clear-presentations () + "Forget all objects associated to SLIME presentations. +This allows the garbage collector to remove these objects +even on Common Lisp implementations without weak hash tables." + (interactive) + (slime-eval-async `(swank:clear-repl-results)) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (slime-for-each-presentation-in-region 1 (1+ (buffer-size)) + (lambda (presentation from to whole-p) + (slime-remove-presentation-properties from to + presentation)))) + +(defun slime-presentation-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (slime-dcase ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (slime-insert-presentation string `(:inspected-part ,id) t))) + ((:label string) + (insert (slime-inspector-fontify label string))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-presentation-sldb-insert-frame-variable-value (value frame index) + (slime-insert-presentation + (sldb-in-face local-value value) + `(:frame-var ,slime-current-thread ,(car frame) ,index) t)) + +(defun slime-presentations-on-connected () + (slime-eval-async `(swank:init-presentations))) + +(provide 'slime-presentations) diff --git a/elpa/slime-20200319.1939/contrib/slime-presentations.elc b/elpa/slime-20200319.1939/contrib/slime-presentations.elc new file mode 100644 index 00000000..8442f011 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-presentations.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-quicklisp.el b/elpa/slime-20200319.1939/contrib/slime-quicklisp.el new file mode 100644 index 00000000..97f5ece8 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-quicklisp.el @@ -0,0 +1,51 @@ +(require 'slime) +(require 'cl-lib) + +;;; bits of the following taken from slime-asdf.el + +(define-slime-contrib slime-quicklisp + "Quicklisp support." + (:authors "Matthew Kennedy ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-quicklisp)) + +;;; Utilities + +(defgroup slime-quicklisp nil + "Quicklisp support for Slime." + :prefix "slime-quicklisp-" + :group 'slime) + +(defvar slime-quicklisp-system-history nil + "History list for Quicklisp system names.") + + + +(defun slime-read-quicklisp-system-name (&optional prompt default-value) + "Read a Quick system name from the minibuffer, prompting with PROMPT." + (let* ((completion-ignore-case nil) + (prompt (or prompt "Quicklisp system")) + (quicklisp-system-names (slime-eval `(swank:list-quicklisp-systems))) + (prompt (concat prompt (if default-value + (format " (default `%s'): " default-value) + ": ")))) + (completing-read prompt (slime-bogus-completion-alist quicklisp-system-names) + nil nil nil + 'slime-quicklisp-system-history default-value))) + +(defun slime-quicklisp-quickload (system) + "Load a Quicklisp system." + (slime-save-some-lisp-buffers) + (slime-display-output-buffer) + (slime-repl-shortcut-eval-async `(ql:quickload ,system))) + +;;; REPL shortcuts + +(defslime-repl-shortcut slime-repl-quicklisp-quickload ("quicklisp-quickload" "ql") + (:handler (lambda () + (interactive) + (slime-quicklisp-quickload (slime-read-quicklisp-system-name)))) + (:one-liner "Load a system known to Quicklisp.")) + +(provide 'slime-quicklisp) diff --git a/elpa/slime-20200319.1939/contrib/slime-quicklisp.elc b/elpa/slime-20200319.1939/contrib/slime-quicklisp.elc new file mode 100644 index 00000000..6e6b74ff Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-quicklisp.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-references.el b/elpa/slime-20200319.1939/contrib/slime-references.el new file mode 100644 index 00000000..93389ae8 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-references.el @@ -0,0 +1,156 @@ +(require 'slime) +(require 'advice) +(require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library. + +(define-slime-contrib slime-references + "Clickable references to documentation (SBCL only)." + (:authors "Christophe Rhodes " + "Luke Gorrie " + "Tobias C. Rittweiler ") + (:license "GPL") + (:on-load + (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references) + (ad-activate 'slime-note.message) + (setq slime-tree-printer 'slime-tree-print-with-references) + (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + (:on-unload + (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references) + (ad-deactivate 'slime-note.message) + (setq slime-tree-printer 'slime-tree-default-printer) + (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))) + +(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/" + "*The base URL of the SBCL manual, for documentation lookup." + :type '(choice (string :tag "HTML Documentation") + (const :tag "Info Documentation" :info)) + :group 'slime-mode) + +(defface sldb-reference-face + (list (list t '(:underline t))) + "Face for references." + :group 'slime-debugger) + + +;;;;; SBCL-style references + +(defvar slime-references-local-keymap + (let ((map (make-sparse-keymap "local keymap for slime references"))) + (define-key map [mouse-2] 'slime-lookup-reference-at-mouse) + (define-key map [return] 'slime-lookup-reference-at-point) + map)) + +(defun slime-reference-properties (reference) + "Return the properties for a reference. +Only add clickability to properties we actually know how to lookup." + (cl-destructuring-bind (where type what) reference + (if (or (and (eq where :sbcl) (eq type :node)) + (and (eq where :ansi-cl) + (memq type '(:function :special-operator :macro + :type :system-class + :section :glossary :issue)))) + `(slime-reference ,reference + font-lock-face sldb-reference-face + follow-link t + mouse-face highlight + help-echo "mouse-2: visit documentation." + keymap ,slime-references-local-keymap)))) + +(defun slime-insert-reference (reference) + "Insert documentation reference from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (cl-destructuring-bind (where type what) reference + (insert "\n" (slime-format-reference-source where) ", ") + (slime-insert-propertized (slime-reference-properties reference) + (slime-format-reference-node what)) + (insert (format " [%s]" type)))) + +(defun slime-insert-references (references) + (when references + (insert "\nSee also:") + (slime-with-rigid-indentation 2 + (mapc #'slime-insert-reference references)))) + +(defun slime-format-reference-source (where) + (cl-case where + (:amop "The Art of the Metaobject Protocol") + (:ansi-cl "Common Lisp Hyperspec") + (:sbcl "SBCL Manual") + (t (format "%S" where)))) + +(defun slime-format-reference-node (what) + (if (listp what) + (mapconcat #'prin1-to-string what ".") + what)) + +(defun slime-lookup-reference-at-point () + "Browse the documentation reference at point." + (interactive) + (let ((refs (get-text-property (point) 'slime-reference))) + (if (null refs) + (error "No references at point") + (cl-destructuring-bind (where type what) refs + (cl-case where + (:ansi-cl + (cl-case type + (:section + (browse-url (funcall common-lisp-hyperspec-section-fun what))) + (:glossary + (browse-url (funcall common-lisp-hyperspec-glossary-function what))) + (:issue + (browse-url (common-lisp-issuex what))) + (:special-operator + (browse-url (common-lisp-special-operator (downcase name)))) + (t + (hyperspec-lookup what)))) + (t + (case slime-sbcl-manual-root + (:info + (info (format "(sbcl)%s" what))) + (t + (browse-url + (format "%s#%s" slime-sbcl-manual-root + (subst-char-in-string ?\ ?\- what))))))))))) + +(defun slime-lookup-reference-at-mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (cl-destructuring-bind (mouse-1 (w pos . _) . _) event + (save-excursion + (goto-char pos) + (slime-lookup-reference-at-point)))) + +;;;;; Hook into *SLIME COMPILATION* + +(defun slime-note.references (note) + (plist-get note :references)) + +;;; FIXME: `compilation-mode' will swallow the `mouse-face' +;;; etc. properties. +(defadvice slime-note.message (after slime-note.message+references) + (setq ad-return-value + (concat ad-return-value + (with-temp-buffer + (slime-insert-references + (slime-note.references (ad-get-arg 0))) + (buffer-string))))) + +;;;;; Hook into slime-compiler-notes-tree + +(defun slime-tree-print-with-references (tree) + ;; for SBCL-style references + (slime-tree-default-printer tree) + (let ((note (plist-get (slime-tree.plist tree) 'note))) + (when note + (let ((references (slime-note.references note))) + (when references + (terpri (current-buffer)) + (slime-insert-references references)))))) + +;;;;; Hook into SLDB + +(defun sldb-maybe-insert-references (extra) + (slime-dcase extra + ((:references references) (slime-insert-references references) t) + (t nil))) + +(provide 'slime-references) diff --git a/elpa/slime-20200319.1939/contrib/slime-references.elc b/elpa/slime-20200319.1939/contrib/slime-references.elc new file mode 100644 index 00000000..2e3016fa Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-references.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-repl.el b/elpa/slime-20200319.1939/contrib/slime-repl.el new file mode 100644 index 00000000..5a3cba73 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-repl.el @@ -0,0 +1,1805 @@ +;;; slime-repl.el --- +;; +;; Original Author: Helmut Eller +;; Contributors: too many to mention +;; License: GNU GPL (same license as Emacs) +;; +;;; Description: +;; + +;; +;;; Installation: +;; +;; Call slime-setup and include 'slime-repl as argument: +;; +;; (slime-setup '(slime-repl [others conribs ...])) +;; +(require 'slime) +(require 'slime-parse) +(require 'cl-lib) +(eval-when-compile (require 'cl)) ; slime-def-connection-var, which + ; expands to defsetf not in cl-lib + +(define-slime-contrib slime-repl + "Read-Eval-Print Loop written in Emacs Lisp. + +This contrib implements a Lisp Listener along with some niceties like +a persistent history and various \"shortcut\" commands. Nothing here +depends on comint.el; I/O is multiplexed over SLIME's socket. + +This used to be the default REPL for SLIME, but it was hard to +maintain." + (:authors "too many to mention") + (:license "GPL") + (:on-load + (slime-repl-add-hooks) + (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package)) + (:on-unload (slime-repl-remove-hooks)) + (:swank-dependencies swank-repl)) + +;;;;; slime-repl + +(defgroup slime-repl nil + "The Read-Eval-Print Loop (*slime-repl* buffer)." + :prefix "slime-repl-" + :group 'slime) + +(defcustom slime-repl-shortcut-dispatch-char ?\, + "Character used to distinguish repl commands from lisp forms." + :type '(character) + :group 'slime-repl) + +(defcustom slime-repl-only-save-lisp-buffers t + "When T we only attempt to save lisp-mode file buffers. When + NIL slime will attempt to save all buffers (as per + save-some-buffers). This applies to all ASDF related repl + shortcuts." + :type '(boolean) + :group 'slime-repl) + +(defcustom slime-repl-auto-right-margin nil + "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the +current repl's (as per slime-output-buffer) window." + :type '(boolean) + :group 'slime-repl) + +(defface slime-repl-prompt-face + '((t (:inherit font-lock-keyword-face))) + "Face for the prompt in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-output-face + '((t (:inherit font-lock-string-face))) + "Face for Lisp output in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-input-face + '((t (:bold t))) + "Face for previous input in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-result-face + '((t ())) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +(defcustom slime-repl-history-file "~/.slime-history.eld" + "File to save the persistent REPL history to." + :type 'string + :group 'slime-repl) + +(defcustom slime-repl-history-size 200 + "*Maximum number of lines for persistent REPL history." + :type 'integer + :group 'slime-repl) + +(defcustom slime-repl-history-file-coding-system + (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix) + (t slime-net-coding-system)) + "*The coding system for the history file." + :type 'symbol + :group 'slime-repl) + + +;; dummy defvar for compiler +(defvar slime-repl-read-mode) + +(defun slime-reading-p () + "True if Lisp is currently reading input from the REPL." + (with-current-buffer (slime-output-buffer) + slime-repl-read-mode)) + + +;;;; Stream output + +(slime-def-connection-var slime-connection-output-buffer nil + "The buffer for the REPL. May be nil or a dead buffer.") + +(make-variable-buffer-local + (defvar slime-output-start nil + "Marker for the start of the output for the evaluation.")) + +(make-variable-buffer-local + (defvar slime-output-end nil + "Marker for end of output. New output is inserted at this mark.")) + +;; dummy definitions for the compiler +(defvar slime-repl-package-stack) +(defvar slime-repl-directory-stack) +(defvar slime-repl-input-start-mark) +(defvar slime-repl-prompt-start-mark) + +(defvar slime-repl-history-use-mark nil + "A non-nil value means that history will be replaced from the mark. + +Instead of replacing form input-start, look up history and replace input +from the mark. Calling 'slime-repl-previous-input', + 'slime-repl-previous-matching-input' or their -next counterparts with a prefix + argument sets this variable for the duration of one history lookup.") + +(defun slime-repl-history-yank-start () + "The position which 'slime-repl-previous-input' will replace from. + +When 'slime-repl-history-use-mark' is non-nil, and (mark) is after the current +input start, return it. Otherwise, return 'slime-repl-input-start-mark'." + (if (and slime-repl-history-use-mark (mark)) + (max (mark) slime-repl-input-start-mark) + slime-repl-input-start-mark)) + +(defun slime-output-buffer (&optional noprompt) + "Return the output buffer, create it if necessary." + (let ((buffer (slime-connection-output-buffer))) + (or (if (buffer-live-p buffer) buffer) + (setf (slime-connection-output-buffer) + (let ((connection (slime-connection))) + (with-current-buffer (slime-repl-buffer t connection) + (unless (eq major-mode 'slime-repl-mode) + (slime-repl-mode)) + (setq slime-buffer-connection connection) + (setq slime-buffer-package (slime-lisp-package connection)) + (slime-reset-repl-markers) + (unless noprompt + (slime-repl-insert-prompt)) + (current-buffer))))))) + +(defvar slime-repl-banner-function 'slime-repl-insert-banner) + +(defun slime-repl-update-banner () + (funcall slime-repl-banner-function) + (slime-move-point (point-max)) + (slime-mark-output-start) + (slime-mark-input-start) + (slime-repl-insert-prompt)) + +(defun slime-repl-insert-banner () + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " slime-version))) + (insert welcome)))) + +(defun slime-init-output-buffer (connection) + (with-current-buffer (slime-output-buffer t) + (setq slime-buffer-connection connection + slime-repl-directory-stack '() + slime-repl-package-stack '()) + (slime-repl-update-banner))) + +(defun slime-display-output-buffer () + "Display the output buffer and scroll to bottom." + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (unless (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t)) + (slime-repl-show-maximum-output))) + +(defun slime-output-filter (process string) + (with-current-buffer (process-buffer process) + (when (and (plusp (length string)) + (eq (process-status slime-buffer-connection) 'open)) + (slime-write-string string)))) + +(defvar slime-open-stream-hooks) + +(defun slime-open-stream-to-lisp (port coding-system) + (let ((stream (open-network-stream "*lisp-output-stream*" + (slime-with-connection-buffer () + (current-buffer)) + (car (process-contact (slime-connection))) + port)) + (emacs-coding-system (car (cl-find coding-system + slime-net-valid-coding-systems + :key #'cl-third)))) + (slime-set-query-on-exit-flag stream) + (set-process-filter stream 'slime-output-filter) + (set-process-coding-system stream emacs-coding-system emacs-coding-system) + (let ((secret (slime-secret))) + (when secret + (slime-net-send secret stream))) + (run-hook-with-args 'slime-open-stream-hooks stream) + stream)) + +(defun slime-io-speed-test (&optional profile) + "A simple minded benchmark for stream performance. +If a prefix argument is given, instrument the slime package for +profiling before running the benchmark." + (interactive "P") + (eval-and-compile + (require 'elp)) + (elp-reset-all) + (elp-restore-all) + (load "slime.el") + ;;(byte-compile-file "slime-net.el" t) + ;;(setq slime-log-events nil) + (setq slime-enable-evaluate-in-emacs t) + ;;(setq slime-repl-enable-presentations nil) + (when profile + (elp-instrument-package "slime-")) + (kill-buffer (slime-output-buffer)) + (switch-to-buffer (slime-output-buffer)) + (delete-other-windows) + (sit-for 0) + (slime-repl-send-string "(swank:io-speed-test 4000 1)") + (let ((proc (slime-inferior-process))) + (when proc + (display-buffer (process-buffer proc) t) + (goto-char (point-max))))) + +(defvar slime-write-string-function 'slime-repl-write-string) + +(defun slime-write-string (string &optional target) + "Insert STRING in the REPL buffer or some other TARGET. +If TARGET is nil, insert STRING as regular process +output. If TARGET is :repl-result, insert STRING as the result of the +evaluation. Other values of TARGET map to an Emacs marker via the +hashtable `slime-output-target-to-marker'; output is inserted at this marker." + (funcall slime-write-string-function string target)) + +(defun slime-repl-write-string (string &optional target) + (case target + ((nil) (slime-repl-emit string)) + (:repl-result (slime-repl-emit-result string t)) + (t (slime-repl-emit-to-target string target)))) + +(defvar slime-repl-popup-on-output nil + "Display the output buffer when some output is written. +This is set to nil after displaying the buffer.") + +(defmacro slime-save-marker (marker &rest body) + (declare (debug (sexp &rest form))) + (let ((pos (cl-gensym "pos"))) + `(let ((,pos (marker-position ,marker))) + (prog1 (progn . ,body) + (set-marker ,marker ,pos))))) + +(put 'slime-save-marker 'lisp-indent-function 1) + +(defun slime-repl-emit (string) + ;; insert the string STRING in the output buffer + (with-current-buffer (slime-output-buffer) + (save-excursion + (goto-char slime-output-end) + (slime-save-marker slime-output-start + (slime-propertize-region '(face slime-repl-output-face + slime-repl-output t + rear-nonsticky (face)) + (let ((inhibit-read-only t)) + (insert-before-markers string) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert-before-markers "\n") + (set-marker slime-output-end (1- (point)))))))) + (when slime-repl-popup-on-output + (setq slime-repl-popup-on-output nil) + (display-buffer (current-buffer))) + (slime-repl-show-maximum-output))) + +(defun slime-repl-emit-result (string &optional bol) + ;; insert STRING and mark it as evaluation result + (with-current-buffer (slime-output-buffer) + (save-excursion + (goto-char slime-repl-input-start-mark) + (slime-save-marker slime-output-start + (goto-char slime-repl-input-start-mark) + (when (and bol (not (bolp))) (insert-before-markers-and-inherit "\n")) + (slime-save-marker slime-output-end + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert-before-markers string))) + (set-marker slime-output-end (point)))) + (slime-repl-show-maximum-output))) + +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defun slime-repl-emit-to-target (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-repl-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +(defun slime-repl-output-target-marker (target) + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (slime-output-target-marker target)))) + + +(defun slime-switch-to-output-buffer () + "Select the output buffer, when possible in an existing window. + +Hint: You can use `display-buffer-reuse-frames' and +`special-display-buffer-names' to customize the frame in which +the buffer should appear." + (interactive) + (pop-to-buffer (slime-output-buffer)) + (goto-char (point-max))) + + +;;;; REPL +;; +;; The REPL uses some markers to separate input from output. The +;; usual configuration is as follows: +;; +;; ... output ... ... result ... prompt> ... input ... +;; ^ ^ ^ ^ ^ +;; output-start output-end prompt-start input-start point-max +;; +;; input-start is a right inserting marker, because +;; we want it to stay behind when the user inserts text. +;; +;; We maintain the following invariant: +;; +;; output-start <= output-end <= input-start. +;; +;; This invariant is important, because we must be prepared for +;; asynchronous output and asynchronous reads. ("Asynchronous" means, +;; triggered by Lisp and not by Emacs.) +;; +;; All output is inserted at the output-end marker. Some care must be +;; taken when output-end and input-start are at the same position: if +;; we insert at that point, we must move the right markers. We should +;; also not leave (window-)point in the middle of the new output. The +;; idiom we use is a combination to slime-save-marker, +;; insert-before-markers, and manually updating window-point +;; afterwards. +;; +;; A "synchronous" evaluation request proceeds as follows: the user +;; inserts some text between input-start and point-max and then hits +;; return. We send that region to Lisp, move the output and input +;; makers to the line after the input and wait. When we receive the +;; result, we insert it together with a prompt between the output-end +;; and input-start mark. See `slime-repl-insert-prompt'. +;; +;; It is possible that some output for such an evaluation request +;; arrives after the result. This output is inserted before the +;; result (and before the prompt). +;; +;; If we are in "reading" state, e.g., during a call to Y-OR-N-P, +;; there is no prompt between output-end and input-start. +;; + +;; FIXME: slime-lisp-package should be local in a REPL buffer +(slime-def-connection-var slime-lisp-package + "COMMON-LISP-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package-prompt-string + "CL-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-make-variables-buffer-local + (defvar slime-repl-package-stack nil + "The stack of packages visited in this repl.") + + (defvar slime-repl-directory-stack nil + "The stack of default directories associated with this repl.") + + (defvar slime-repl-prompt-start-mark) + (defvar slime-repl-input-start-mark) + (defvar slime-repl-old-input-counter 0 + "Counter used to generate unique `slime-repl-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.")) + +(defun slime-reset-repl-markers () + (dolist (markname '(slime-output-start + slime-output-end + slime-repl-prompt-start-mark + slime-repl-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point)))) + +;;;;; REPL mode setup + +(defvar slime-repl-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(slime-define-keys slime-prefix-map + ("\C-z" 'slime-switch-to-output-buffer) + ("\M-p" 'slime-repl-set-package)) + +(slime-define-keys slime-mode-map + ("\C-c~" 'slime-sync-package-and-default-directory) + ("\C-c\C-y" 'slime-call-defun) + ("\C-c\C-j" 'slime-eval-last-expression-in-repl)) + +(slime-define-keys slime-connection-list-mode-map + ((kbd "RET") 'slime-goto-connection) + ([return] 'slime-goto-connection)) + +(slime-define-keys slime-repl-mode-map + ("\C-m" 'slime-repl-return) + ([return] 'slime-repl-return) + ("\C-j" 'slime-repl-newline-and-indent) + ("\C-\M-m" 'slime-repl-closing-return) + ([(control return)] 'slime-repl-closing-return) + ("\M-p" 'slime-repl-previous-input) + ((kbd "C-") 'slime-repl-backward-input) + ("\M-n" 'slime-repl-next-input) + ((kbd "C-") 'slime-repl-forward-input) + ("\M-r" 'slime-repl-previous-matching-input) + ("\M-s" 'slime-repl-next-matching-input) + ("\C-c\C-c" 'slime-interrupt) + (" " 'slime-space) + ((string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut) + ("\C-c\C-o" 'slime-repl-clear-output) + ("\C-c\M-o" 'slime-repl-clear-buffer) + ("\C-c\C-u" 'slime-repl-kill-input) + ("\C-c\C-n" 'slime-repl-next-prompt) + ("\C-c\C-p" 'slime-repl-previous-prompt) + ("\C-c\C-z" 'slime-nop) + ("\C-cI" 'slime-repl-inspect) + ("\C-x\C-e" 'slime-eval-last-expression)) + +(slime-define-keys slime-inspector-mode-map + ((kbd "M-RET") 'slime-inspector-copy-down-to-repl)) + +(slime-define-keys sldb-mode-map + ("\C-y" 'sldb-insert-frame-call-to-repl) + ((kbd "M-RET") 'sldb-copy-down-to-repl)) + +(def-slime-selector-method ?r + "SLIME Read-Eval-Print-Loop." + (slime-output-buffer)) + +(define-minor-mode slime-repl-map-mode + "Minor mode which makes slime-repl-mode-map available. +\\{slime-repl-mode-map}" + nil + nil + slime-repl-mode-map) + +(defun slime-repl-mode () + "Major mode for interacting with a superior Lisp. +\\{slime-repl-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'slime-repl-mode) + (slime-editing-mode 1) + (slime-repl-map-mode 1) + (lisp-mode-variables t) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (slime-setup-completion) + (set (make-local-variable 'tab-always-indent) 'complete) + (setq font-lock-defaults nil) + (setq mode-name "REPL") + (setq slime-current-thread :repl-thread) + (set (make-local-variable 'scroll-conservatively) 20) + (set (make-local-variable 'scroll-margin) 0) + (when slime-repl-history-file + (slime-repl-safe-load-history) + (add-hook 'kill-buffer-hook + 'slime-repl-safe-save-merged-history + 'append t)) + (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN. + (set (make-local-variable 'beginning-of-defun-function) + 'slime-repl-mode-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'slime-repl-mode-end-of-defun) + (run-mode-hooks 'slime-repl-mode-hook)) + +(defun slime-repl-buffer (&optional create connection) + "Get the REPL buffer for the current connection; optionally create." + (funcall (if create #'get-buffer-create #'get-buffer) + (format "*slime-repl %s*" (slime-connection-name connection)))) + +(defun slime-repl () + (interactive) + (slime-switch-to-output-buffer) + (current-buffer)) + +(defun slime-repl-mode-beginning-of-defun (&optional arg) + (if (and arg (< arg 0)) + (slime-repl-mode-end-of-defun (- arg)) + (dotimes (i (or arg 1)) + (slime-repl-previous-prompt)))) + +(defun slime-repl-mode-end-of-defun (&optional arg) + (if (and arg (< arg 0)) + (slime-repl-mode-beginning-of-defun (- arg)) + (dotimes (i (or arg 1)) + (slime-repl-next-prompt)))) + +(defun slime-repl-send-string (string &optional command-string) + (cond (slime-repl-read-mode + (slime-repl-return-string string)) + (t (slime-repl-eval-string string)))) + +(defun slime-repl-eval-string (string) + (slime-rex () + ((if slime-repl-auto-right-margin + `(swank-repl:listener-eval + ,string + :window-width + ,(with-current-buffer (slime-output-buffer) + (window-width))) + `(swank-repl:listener-eval ,string)) + (slime-lisp-package)) + ((:ok result) + (slime-repl-insert-result result)) + ((:abort condition) + (slime-repl-show-abort condition)))) + +(defun slime-repl-insert-result (result) + (with-current-buffer (slime-output-buffer) + (save-excursion + (when result + (slime-dcase result + ((:values &rest strings) + (cond ((null strings) + (slime-repl-emit-result "; No value\n" t)) + (t + (dolist (s strings) + (slime-repl-emit-result s t))))))) + (slime-repl-insert-prompt)) + (slime-repl-show-maximum-output))) + +(defun slime-repl-show-abort (condition) + (with-current-buffer (slime-output-buffer) + (save-excursion + (slime-save-marker slime-output-start + (slime-save-marker slime-output-end + (goto-char slime-output-end) + (insert-before-markers (format "; Evaluation aborted on %s.\n" + condition)) + (slime-repl-insert-prompt)))) + (slime-repl-show-maximum-output))) + +(defvar slime-repl-suppress-prompt nil + "Supresses Slime REPL prompt when bound to T.") + +(defun slime-repl-insert-prompt () + "Insert the prompt (before markers!). +Set point after the prompt. +Return the position of the prompt beginning. + +If `slime-repl-suppress-prompt' is true, does nothing and returns nil." + (goto-char slime-repl-input-start-mark) + (unless slime-repl-suppress-prompt + (slime-save-marker slime-output-start + (slime-save-marker slime-output-end + (unless (bolp) (insert-before-markers "\n")) + (let ((prompt-start (point)) + (prompt (format "%s> " (slime-lisp-package-prompt-string)))) + (slime-propertize-region + '(face slime-repl-prompt-face + read-only t slime-repl-prompt t + rear-nonsticky t front-sticky (read-only) + inhibit-line-move-field-capture t + field output) + (insert-before-markers prompt)) + (set-marker slime-repl-prompt-start-mark prompt-start) + (setq buffer-undo-list nil) + prompt-start))))) + +(defun slime-repl-show-maximum-output () + "Put the end of the buffer at the bottom of the window." + (when (eobp) + (let ((win (if (eq (window-buffer) (current-buffer)) + (selected-window) + (get-buffer-window (current-buffer) t)))) + (when win + (with-selected-window win + (set-window-point win (point-max)) + (recenter -1)))))) + +(defvar slime-repl-current-input-hooks) + +(defun slime-repl-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer." + (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks + until-point-p) + (buffer-substring-no-properties (slime-repl-history-yank-start) + (if until-point-p + (point) + (point-max))))) + +(defun slime-property-position (text-property &optional object) + "Return the first position of TEXT-PROPERTY, or nil." + (if (get-text-property 0 text-property object) + 0 + (next-single-property-change 0 text-property object))) + +(defun slime-mark-input-start () + (set-marker slime-repl-input-start-mark (point) (current-buffer))) + +(defun slime-mark-output-start () + (set-marker slime-output-start (point)) + (set-marker slime-output-end (point))) + +(defun slime-mark-output-end () + ;; Don't put slime-repl-output-face again; it would remove the + ;; special presentation face, for instance in the SBCL inspector. + (add-text-properties slime-output-start slime-output-end + '(;;face slime-repl-output-face + rear-nonsticky (face)))) + +(defun slime-preserve-zmacs-region () + "In XEmacs, ensure that the zmacs-region stays active after this command." + (when (boundp 'zmacs-region-stays) + (set 'zmacs-region-stays t))) + +(defun slime-repl-in-input-area-p () + (<= slime-repl-input-start-mark (point))) + +(defun slime-repl-at-prompt-start-p () + ;; This will not work on non-current prompts. + (= (point) slime-repl-input-start-mark)) + +(defun slime-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt + ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means + ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to + ;; jump to the start of the previous prompt. + (if (and (not (slime-repl-at-prompt-start-p)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-start-mark) + (beginning-of-defun)) + t) + +;; FIXME: this looks very strange +(defun slime-repl-end-of-defun () + "Move to next of defun." + (interactive) + ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN. + (if (and (not (= (point) (point-max))) + (slime-repl-in-input-area-p)) + (goto-char (point-max)) + (end-of-defun)) + t) + +(defun slime-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (slime-repl-find-prompt t)) + +(defun slime-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (slime-repl-find-prompt)) + +(defun slime-repl-find-prompt (&optional backward) + (let ((origin (point)) + (prop 'slime-repl-prompt)) + (while (progn + (slime-search-property-change prop backward) + (not (or (slime-end-of-proprange-p prop) (bobp) (eobp))))) + (unless (slime-end-of-proprange-p prop) + (goto-char origin)))) + +(defun slime-search-property-change (prop &optional backward) + (cond (backward + (goto-char (or (previous-single-char-property-change (point) prop) + (point-min)))) + (t + (goto-char (or (next-single-char-property-change (point) prop) + (point-max)))))) + +(defun slime-end-of-proprange-p (property) + (and (get-char-property (max 1 (1- (point))) property) + (not (get-char-property (point) property)))) + +(defvar slime-repl-return-hooks) + +(defun slime-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input only if a whole expression has been entered, +i.e. the parenthesis are matched. + +With prefix argument send the input even if the parenthesis are not +balanced." + (interactive "P") + (slime-check-connected) + (cond (end-of-input + (slime-repl-send-input)) + (slime-repl-read-mode ; bad style? + (slime-repl-send-input t)) + ((and (get-text-property (point) 'slime-repl-old-input) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-input end-of-input) + (slime-repl-recenter-if-needed)) + ((run-hook-with-args-until-success 'slime-repl-return-hooks end-of-input)) + ((slime-input-complete-p slime-repl-input-start-mark (point-max)) + (slime-repl-send-input t)) + (t + (slime-repl-newline-and-indent) + (message "[input not complete]")))) + +(defun slime-repl-recenter-if-needed () + "Make sure that (point) is visible." + (unless (pos-visible-in-window-p (point-max)) + (save-excursion + (goto-char (point-max)) + (recenter -1)))) + +(defun slime-repl-send-input (&optional newline) + "Goto to the end of the input and send the current input. +If NEWLINE is true then add a newline at the end of the input." + (unless (slime-repl-in-input-area-p) + (error "No input at point.")) + (goto-char (point-max)) + (let ((end (point))) ; end of input, without the newline + (slime-repl-add-to-input-history + (buffer-substring slime-repl-input-start-mark end)) + (when newline + (insert "\n") + (slime-repl-show-maximum-output)) + (let ((inhibit-modification-hooks t)) + (add-text-properties slime-repl-input-start-mark + (point) + `(slime-repl-old-input + ,(incf slime-repl-old-input-counter)))) + (let ((overlay (make-overlay slime-repl-input-start-mark end))) + ;; These properties are on an overlay so that they won't be taken + ;; by kill/yank. + (overlay-put overlay 'face 'slime-repl-input-face))) + (let ((input (slime-repl-current-input))) + (goto-char (point-max)) + (slime-mark-input-start) + (slime-mark-output-start) + (slime-repl-send-string input))) + +(defun slime-repl-grab-old-input (replace) + "Resend the old REPL input at point. +If replace is non-nil the current input is replaced with the old +input; otherwise the new input is appended. The old input has the +text property `slime-repl-old-input'." + (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char (point-max)) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) (point-max)) + (save-excursion + (insert old-input) + (when (equal (char-before) ?\n) + (delete-char -1))) + (forward-char offset)))) + +(defun slime-repl-closing-return () + "Evaluate the current input string after closing all open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point)) + (while (ignore-errors (save-excursion (backward-up-list 1)) t) + (insert ")"))) + (slime-repl-return)) + +(defun slime-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region slime-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + +(defun slime-repl-delete-current-input () + "Delete all text from the prompt." + (interactive) + (delete-region (slime-repl-history-yank-start) (point-max))) + +(defun slime-eval-last-expression-in-repl (prefix) + "Evaluates last expression in the Slime REPL. + +Switches REPL to current package of the source buffer for the duration. If +used with a prefix argument (C-u), doesn't switch back afterwards." + (interactive "P") + (let ((expr (slime-last-expression)) + (buffer-name (buffer-name (current-buffer))) + (new-package (slime-current-package)) + (old-package (slime-lisp-package)) + (slime-repl-suppress-prompt t) + (yank-back nil)) + (with-current-buffer (slime-output-buffer) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)) + (goto-char (point-max)) + ;; Kill pending input in the REPL + (when (< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point)) + (setq yank-back t)) + (unwind-protect + (progn + (insert-before-markers (format "\n;;; from %s\n" buffer-name)) + (when new-package + (slime-repl-set-package new-package)) + (let ((slime-repl-suppress-prompt nil)) + (slime-repl-insert-prompt)) + (insert expr) + (slime-repl-return)) + (unless (or prefix (equal (slime-lisp-package) old-package)) + ;; Switch back. + (slime-repl-set-package old-package) + (let ((slime-repl-suppress-prompt nil)) + (slime-repl-insert-prompt)))) + ;; Put pending input back. + (when yank-back + (yank))))) + +(defun slime-repl-kill-input () + "Kill all text from the prompt to point." + (interactive) + (cond ((< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point))) + ((= (point) (marker-position slime-repl-input-start-mark)) + (slime-repl-delete-current-input)))) + +(defun slime-repl-replace-input (string) + (slime-repl-delete-current-input) + (insert-and-inherit string)) + +(defun slime-repl-input-line-beginning-position () + (save-excursion + (goto-char slime-repl-input-start-mark) + (let ((inhibit-field-text-motion t)) + (line-beginning-position)))) + +(defun slime-clear-repl-variables () + (interactive) + (slime-eval-async `(swank-repl:clear-repl-variables))) + +(defvar slime-repl-clear-buffer-hook) + +(add-hook 'slime-repl-clear-buffer-hook 'slime-clear-repl-variables) + +(defun slime-repl-clear-buffer () + "Delete the output generated by the Lisp process." + (interactive) + (let ((inhibit-read-only t)) + (delete-region (point-min) slime-repl-prompt-start-mark) + (delete-region slime-output-start slime-output-end) + (when (< (point) slime-repl-input-start-mark) + (goto-char slime-repl-input-start-mark)) + (recenter t)) + (run-hooks 'slime-repl-clear-buffer-hook)) + +(defun slime-repl-clear-output () + "Delete the output inserted since the last input." + (interactive) + (let ((start (save-excursion + (when (>= (point) slime-repl-input-start-mark) + (goto-char slime-repl-input-start-mark)) + (slime-repl-previous-prompt) + (ignore-errors (forward-sexp)) + (forward-line) + (point))) + (end (1- (slime-repl-input-line-beginning-position)))) + (when (< start end) + (let ((inhibit-read-only t)) + (delete-region start end) + (save-excursion + (goto-char start) + (insert ";;; output flushed")))))) + +(defun slime-repl-set-package (package) + "Set the package of the REPL buffer to PACKAGE." + (interactive (list (let* ((p (slime-current-package)) + (p (and p (slime-pretty-package-name p))) + (p (and (not (equal p (slime-lisp-package))) p))) + (slime-read-package-name "Package: " p)))) + (with-current-buffer (slime-output-buffer) + (let ((previouse-point (- (point) slime-repl-input-start-mark)) + (previous-prompt (slime-lisp-package-prompt-string))) + (destructuring-bind (name prompt-string) + (slime-repl-shortcut-eval `(swank:set-package ,package)) + (setf (slime-lisp-package) name) + (setf slime-buffer-package name) + (unless (equal previous-prompt prompt-string) + (setf (slime-lisp-package-prompt-string) prompt-string) + (slime-repl-insert-prompt)) + (when (plusp previouse-point) + (goto-char (+ previouse-point slime-repl-input-start-mark))))))) + + +;;;;; History + +(defcustom slime-repl-wrap-history nil + "*T to wrap history around when the end is reached." + :type 'boolean + :group 'slime-repl) + +(make-variable-buffer-local + (defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.")) + +(defun slime-repl-add-to-input-history (string) + "Add STRING to the input history. +Empty strings and duplicates are ignored." + (setq string (slime-trim-whitespace string)) + (unless (equal string "") + (setq slime-repl-input-history + (remove string slime-repl-input-history)) + (unless (equal string (car slime-repl-input-history)) + (push string slime-repl-input-history)))) + +;; These two vars contain the state of the last history search. We +;; only use them if `last-command' was 'slime-repl-history-replace, +;; otherwise we reinitialize them. + +(defvar slime-repl-input-history-position -1 + "Newer items have smaller indices.") + +(defvar slime-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun slime-repl-history-replace (direction &optional regexp) + "Replace the current input with the next line in DIRECTION. +DIRECTION is 'forward' or 'backward' (in the history list). +If REGEXP is non-nil, only lines matching REGEXP are considered." + (setq slime-repl-history-pattern regexp) + (let* ((min-pos -1) + (max-pos (length slime-repl-input-history)) + (pos0 (cond ((slime-repl-history-search-in-progress-p) + slime-repl-input-history-position) + (t min-pos))) + (pos (slime-repl-position-in-history pos0 direction (or regexp "") + (slime-repl-current-input))) + (msg nil)) + (cond ((and (< min-pos pos) (< pos max-pos)) + (slime-repl-replace-input (nth pos slime-repl-input-history)) + (setq msg (format "History item: %d" pos))) + ((not slime-repl-wrap-history) + (setq msg (cond ((= pos min-pos) "End of history") + ((= pos max-pos) "Beginning of history")))) + (slime-repl-wrap-history + (setq pos (if (= pos min-pos) max-pos min-pos)) + (setq msg "Wrapped history"))) + (when (or (<= pos min-pos) (<= max-pos pos)) + (when regexp + (setq msg (concat msg "; no matching item")))) + ;;(message "%s [%d %d %s]" msg start-pos pos regexp) + (message "%s%s" msg (cond ((not regexp) "") + (t (format "; current regexp: %s" regexp)))) + (setq slime-repl-input-history-position pos) + (setq this-command 'slime-repl-history-replace))) + +(defun slime-repl-history-search-in-progress-p () + (eq last-command 'slime-repl-history-replace)) + +(defun slime-repl-terminate-history-search () + (setq last-command this-command)) + +(defun slime-repl-position-in-history (start-pos direction regexp + &optional exclude-string) + "Return the position of the history item matching REGEXP. +Return -1 resp. the length of the history if no item matches. +If EXCLUDE-STRING is specified then it's excluded from the search." + ;; Loop through the history list looking for a matching line + (let* ((step (ecase direction + (forward -1) + (backward 1))) + (history slime-repl-input-history) + (len (length history))) + (loop for pos = (+ start-pos step) then (+ pos step) + if (< pos 0) return -1 + if (<= len pos) return len + for history-item = (nth pos history) + if (and (string-match regexp history-item) + (not (equal history-item exclude-string))) + return pos))) + +(defun slime-repl-previous-input () + "Cycle backwards through input history. +If the `last-command' was a history navigation command use the +same search pattern for this command. +Otherwise use the current input as search pattern. + +With a prefix-arg, do replacement from the mark." + (interactive) + (let ((slime-repl-history-use-mark (or slime-repl-history-use-mark + current-prefix-arg))) + (slime-repl-history-replace 'backward (slime-repl-history-pattern t)))) + +(defun slime-repl-next-input () + "Cycle forwards through input history. +See `slime-repl-previous-input'. + +With a prefix-arg, do replacement from the mark." + (interactive) + (let ((slime-repl-history-use-mark (or slime-repl-history-use-mark + current-prefix-arg))) + (slime-repl-history-replace 'forward (slime-repl-history-pattern t)))) + +(defun slime-repl-forward-input () + "Cycle forwards through input history." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern))) + +(defun slime-repl-backward-input () + "Cycle backwards through input history." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern))) + +(defun slime-repl-previous-matching-input (regexp) + "Insert the previous matching input. + +With a prefix-arg, do the insertion at the mark." + (interactive (list (slime-read-from-minibuffer + "Previous element matching (regexp): "))) + (slime-repl-terminate-history-search) + (let ((slime-repl-history-use-mark (or slime-repl-history-use-mark + current-prefix-arg))) + (slime-repl-history-replace 'backward regexp))) + +(defun slime-repl-next-matching-input (regexp) + "Insert the next matching input. + +With a prefix-arg, do the insertion at the mark." + (interactive (list (slime-read-from-minibuffer + "Next element matching (regexp): "))) + (slime-repl-terminate-history-search) + (let ((slime-repl-history-use-mark (or slime-repl-history-use-mark + current-prefix-arg))) + (slime-repl-history-replace 'forward regexp))) + +(defun slime-repl-history-pattern (&optional use-current-input) + "Return the regexp for the navigation commands." + (cond ((slime-repl-history-search-in-progress-p) + slime-repl-history-pattern) + (use-current-input + (goto-char (max (slime-repl-history-yank-start) (point))) + (let ((str (slime-repl-current-input t))) + (cond ((string-match "^[ \t\n]*$" str) nil) + (t (concat "^" (regexp-quote str)))))) + (t nil))) + +(defun slime-repl-delete-from-input-history (string) + "Delete STRING from the repl input history. + +When string is not provided then clear the current repl input and +use it as an input. This is useful to get rid of unwanted repl +history entries while navigating the repl history." + (interactive (list (slime-repl-current-input))) + (let ((merged-history + (slime-repl-merge-histories (slime-repl-read-history nil t) + slime-repl-input-history))) + (setq slime-repl-input-history + (cl-delete string merged-history :test #'string=)) + (slime-repl-save-history)) + (slime-repl-delete-current-input)) + +;;;;; Persistent History + +(defun slime-repl-merge-histories (old-hist new-hist) + "Merge entries from OLD-HIST and NEW-HIST." + ;; Newer items in each list are at the beginning. + (let* ((ht (make-hash-table :test #'equal)) + (test (lambda (entry) + (or (gethash entry ht) + (progn (setf (gethash entry ht) t) + nil))))) + (append (cl-remove-if test new-hist) + (cl-remove-if test old-hist)))) + +(defun slime-repl-load-history (&optional filename) + "Set the current SLIME REPL history. +It can be read either from FILENAME or `slime-repl-history-file' or +from a user defined filename." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (setq slime-repl-input-history (slime-repl-read-history file t)))) + +(defun slime-repl-read-history (&optional filename noerrer) + "Read and return the history from FILENAME. +The default value for FILENAME is `slime-repl-history-file'. +If NOERROR is true return and the file doesn't exits return nil." + (let ((file (or filename slime-repl-history-file))) + (cond ((not (file-readable-p file)) '()) + (t (with-temp-buffer + (insert-file-contents file) + (read (current-buffer))))))) + +(defun slime-repl-read-history-filename () + (read-file-name "Use SLIME REPL history from file: " + slime-repl-history-file)) + +(defun slime-repl-save-merged-history (&optional filename) + "Read the history file, merge the current REPL history and save it. +This tries to be smart in merging the history from the file and the +current history in that it tries to detect the unique entries using +`slime-repl-merge-histories'." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (with-temp-message "saving history..." + (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t) + slime-repl-input-history))) + (slime-repl-save-history file hist))))) + +(defun slime-repl-save-history (&optional filename history) + "Simply save the current SLIME REPL history to a file. +When SLIME is setup to always load the old history and one uses only +one instance of slime all the time, there is no need to merge the +files and this function is sufficient. + +When the list is longer than `slime-repl-history-size' it will be +truncated. That part is untested, though!" + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file)) + (hist (or history slime-repl-input-history))) + (unless (file-writable-p file) + (error (format "History file not writable: %s" file))) + (let ((hist (cl-subseq hist 0 (min (length hist) slime-repl-history-size)))) + ;;(message "saving %s to %s\n" hist file) + (with-temp-file file + (let ((cs slime-repl-history-file-coding-system) + (print-length nil) (print-level nil)) + (setq buffer-file-coding-system cs) + (insert (format ";; -*- coding: %s -*-\n" cs)) + (insert ";; History for SLIME REPL. Automatically written.\n" + ";; Edit only if you know what you're doing\n") + (prin1 (mapcar #'substring-no-properties hist) (current-buffer))))))) + +(defun slime-repl-save-all-histories () + "Save the history in each repl buffer." + (dolist (b (buffer-list)) + (with-current-buffer b + (when (eq major-mode 'slime-repl-mode) + (slime-repl-safe-save-merged-history))))) + +(defun slime-repl-safe-save-merged-history () + (slime-repl-call-with-handler + #'slime-repl-save-merged-history + "%S while saving the history. Continue? ")) + +(defun slime-repl-safe-load-history () + (slime-repl-call-with-handler + #'slime-repl-load-history + "%S while loading the history. Continue? ")) + +(defun slime-repl-call-with-handler (fun query) + "Call FUN in the context of an error handler. +The handler will use qeuery to ask the use if the error should be ingored." + (condition-case err + (funcall fun) + (error + (if (y-or-n-p (format query (error-message-string err))) + nil + (signal (car err) (cdr err)))))) + + +;;;;; REPL Read Mode + +(defvar slime-repl-read-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'slime-repl-return) + (define-key map [return] 'slime-repl-return) + (define-key map (kbd "TAB") 'self-insert-command) + (define-key map "\C-c\C-b" 'slime-repl-read-break) + (define-key map "\C-c\C-c" 'slime-repl-read-break) + (define-key map [remap slime-indent-and-complete-symbol] 'ignore) + (define-key map [remap slime-handle-repl-shortcut] 'self-insert-command) + map)) + +(define-minor-mode slime-repl-read-mode + "Mode to read input from Emacs +\\{slime-repl-read-mode-map}" + nil + "[read]") + +(make-variable-buffer-local + (defvar slime-read-string-threads nil)) + +(make-variable-buffer-local + (defvar slime-read-string-tags nil)) + +(defun slime-repl-read-string (thread tag) + (slime-switch-to-output-buffer) + (push thread slime-read-string-threads) + (push tag slime-read-string-tags) + (goto-char (point-max)) + (slime-mark-output-end) + (slime-mark-input-start) + (slime-repl-read-mode 1)) + +(defun slime-repl-return-string (string) + (slime-dispatch-event `(:emacs-return-string + ,(pop slime-read-string-threads) + ,(pop slime-read-string-tags) + ,string)) + (slime-repl-read-mode -1)) + +(defun slime-repl-read-break () + (interactive) + (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads)))) + +(defun slime-repl-abort-read (thread tag) + (with-current-buffer (slime-output-buffer) + (pop slime-read-string-threads) + (pop slime-read-string-tags) + (slime-repl-read-mode -1) + (message "Read aborted"))) + + +;;;;; REPL handlers + +(cl-defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.)) + symbol names handler one-liner) + +(defvar slime-repl-shortcut-table nil + "A list of slime-repl-shortcuts") + +(defvar slime-repl-shortcut-history '() + "History list of shortcut command names.") + +(defvar slime-within-repl-shortcut-handler-p nil + "Bound to T if we're in a REPL shortcut handler invoked from the REPL.") + +(defun slime-handle-repl-shortcut () + (interactive) + (if (> (point) slime-repl-input-start-mark) + (insert (string slime-repl-shortcut-dispatch-char)) + (let ((shortcut (slime-lookup-shortcut + (completing-read "Command: " + (slime-bogus-completion-alist + (slime-list-all-repl-shortcuts)) + nil t nil + 'slime-repl-shortcut-history)))) + (with-struct (slime-repl-shortcut. handler) shortcut + (let ((slime-within-repl-shortcut-handler-p t)) + (call-interactively handler)))))) + +(defun slime-list-all-repl-shortcuts () + (loop for shortcut in slime-repl-shortcut-table + append (slime-repl-shortcut.names shortcut))) + +(defun slime-lookup-shortcut (name) + (cl-find-if (lambda (s) (member name (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + +(defmacro defslime-repl-shortcut (elisp-name names &rest options) + "Define a new repl shortcut. ELISP-NAME is a symbol specifying +the name of the interactive function to create, or NIL if no +function should be created. + +NAMES is a list of \(full-name . aliases\). + +OPTIONS is an plist specifying the handler doing the actual work +of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)." + `(progn + ,(when elisp-name + `(defun ,elisp-name () + (interactive) + (call-interactively ,(second (assoc :handler options))))) + (let ((new-shortcut (make-slime-repl-shortcut + :symbol ',elisp-name + :names (list ,@names) + ,@(apply #'append options)))) + (setq slime-repl-shortcut-table + (cl-remove-if (lambda (s) + (member ',(car names) (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + (push new-shortcut slime-repl-shortcut-table) + ',elisp-name))) + +(defun slime-repl-shortcut-eval (sexp &optional package) + "This function should be used by REPL shortcut handlers instead +of `slime-eval' to evaluate their final expansion. (This +expansion will be added to the REPL's history.)" + (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? + (slime-repl-add-to-input-history (prin1-to-string sexp))) + (slime-eval sexp package)) + +(defun slime-repl-shortcut-eval-async (sexp &optional cont package) + "This function should be used by REPL shortcut handlers instead +of `slime-eval-async' to evaluate their final expansion. (This +expansion will be added to the REPL's history.)" + (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? + (slime-repl-add-to-input-history (prin1-to-string sexp))) + (slime-eval-async sexp cont package)) + +(defun slime-list-repl-short-cuts () + (interactive) + (slime-with-popup-buffer ((slime-buffer-name :repl-help)) + (let ((table (cl-sort (cl-copy-list slime-repl-shortcut-table) #'string< + :key (lambda (x) + (car (slime-repl-shortcut.names x)))))) + (save-excursion + (dolist (shortcut table) + (let ((names (slime-repl-shortcut.names shortcut))) + (insert (pop names)) ;; first print the "full" name + (when names + ;; we also have aliases + (insert " (aka ") + (while (cdr names) + (insert (pop names) ", ")) + (insert (car names) ")")) + (when (slime-repl-shortcut.one-liner shortcut) + (insert "\n " (slime-repl-shortcut.one-liner shortcut))) + (insert "\n"))))))) + +(defun slime-save-some-lisp-buffers () + (if slime-repl-only-save-lisp-buffers + (save-some-buffers nil (lambda () + (and (memq major-mode slime-lisp-modes) + (not (null buffer-file-name))))) + (save-some-buffers))) + +(defun slime-kill-all-buffers () + "Kill all the SLIME-related buffers." + (dolist (buf (buffer-list)) + (when (or (string= (buffer-name buf) slime-event-buffer-name) + (string-match "^\\*inferior-lisp*" (buffer-name buf)) + (string-match "^\\*slime-repl .*\\*$" (buffer-name buf)) + (string-match "^\\*sldb .*\\*$" (buffer-name buf)) + (string-match "^\\*SLIME.*\\*$" (buffer-name buf))) + (kill-buffer buf)))) + +(defslime-repl-shortcut slime-repl-shortcut-help ("help") + (:handler 'slime-list-repl-short-cuts) + (:one-liner "Display the help.")) + +(defslime-repl-shortcut nil ("change-directory" "!d" "cd") + (:handler 'slime-set-default-directory) + (:one-liner "Change the current directory.")) + +(defslime-repl-shortcut nil ("pwd") + (:handler (lambda () + (interactive) + (let ((dir (slime-eval `(swank:default-directory)))) + (message "Directory %s" dir)))) + (:one-liner "Show the current directory.")) + +(defslime-repl-shortcut slime-repl-push-directory + ("push-directory" "+d" "pushd") + (:handler (lambda (directory) + (interactive + (list (read-directory-name + "Push directory: " + (slime-eval '(swank:default-directory)) + nil nil ""))) + (push (slime-eval '(swank:default-directory)) + slime-repl-directory-stack) + (slime-set-default-directory directory))) + (:one-liner "Save the current directory and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-directory + ("pop-directory" "-d" "popd") + (:handler (lambda () + (interactive) + (if (null slime-repl-directory-stack) + (message "Directory stack is empty.") + (slime-set-default-directory + (pop slime-repl-directory-stack))))) + (:one-liner "Restore the last saved directory.")) + +(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in") + (:handler 'slime-repl-set-package) + (:one-liner "Change the current package.")) + +(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p") + (:handler (lambda (package) + (interactive (list (slime-read-package-name "Package: "))) + (push (slime-lisp-package) slime-repl-package-stack) + (slime-repl-set-package package))) + (:one-liner "Save the current package and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p") + (:handler (lambda () + (interactive) + (if (null slime-repl-package-stack) + (message "Package stack is empty.") + (slime-repl-set-package + (pop slime-repl-package-stack))))) + (:one-liner "Restore the last saved package.")) + +(defslime-repl-shortcut slime-repl-resend ("resend-form") + (:handler (lambda () + (interactive) + (insert (car slime-repl-input-history)) + (insert "\n") + (slime-repl-send-input))) + (:one-liner "Resend the last form.")) + +(defslime-repl-shortcut slime-repl-disconnect ("disconnect") + (:handler 'slime-disconnect) + (:one-liner "Disconnect the current connection.")) + +(defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all") + (:handler 'slime-disconnect-all) + (:one-liner "Disconnect all connections.")) + +(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara") + (:handler (lambda () + (interactive) + (when (slime-connected-p) + (slime-quit-lisp)) + (slime-kill-all-buffers))) + (:one-liner "Quit all Lisps and close all SLIME buffers.")) + +(defslime-repl-shortcut slime-repl-quit ("quit") + (:handler (lambda () + (interactive) + ;; `slime-quit-lisp' determines the connection to quit + ;; on behalf of the REPL's `slime-buffer-connection'. + (let ((repl-buffer (slime-output-buffer))) + (slime-quit-lisp) + (kill-buffer repl-buffer)))) + (:one-liner "Quit the current Lisp.")) + +(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!") + (:handler (lambda (name value) + (interactive (list (slime-read-symbol-name "Name (symbol): " t) + (slime-read-from-minibuffer "Value: " "*"))) + (insert "(cl:defparameter " name " " value + " \"REPL generated global variable.\")") + (slime-repl-send-input t))) + (:one-liner "Define a new global, special, variable.")) + +(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl") + (:handler (lambda (filename) + (interactive (list (expand-file-name + (read-file-name "File: " nil nil nil nil)))) + (slime-save-some-lisp-buffers) + (slime-repl-shortcut-eval-async + `(swank:compile-file-if-needed + ,(slime-to-lisp-filename filename) t) + #'slime-compilation-finished))) + (:one-liner "Compile (if neccessary) and load a lisp file.")) + +(defslime-repl-shortcut nil ("restart-inferior-lisp") + (:handler 'slime-restart-inferior-lisp) + (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) + +(defun slime-redirect-inferior-output (&optional noerror) + "Redirect output of the inferior-process to the REPL buffer." + (interactive) + (let ((proc (slime-inferior-process))) + (cond (proc + (let ((filter (slime-rcurry #'slime-inferior-output-filter + (slime-current-connection)))) + (set-process-filter proc filter))) + (noerror) + (t (error "No inferior lisp process"))))) + +(defun slime-inferior-output-filter (proc string conn) + (cond ((eq (process-status conn) 'closed) + (message "Connection closed. Removing inferior output filter.") + (message "Lost output: %S" string) + (set-process-filter proc nil)) + (t + (slime-output-filter conn string)))) + +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create (slime-buffer-name :trace)))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank-repl:redirect-trace-output ,target)))) + ;; Note: We would like the entries in + ;; slime-output-target-to-marker to disappear when the buffers are + ;; killed. We cannot just make the hash-table ":weakness 'value" + ;; -- there is no reference from the buffers to the markers in the + ;; buffer, so entries would disappear even though the buffers are + ;; alive. Best solution might be to make buffer-local variables + ;; that keep the markers. --mkoeppe + (pop-to-buffer buffer))) + +(defun slime-call-defun () + "Insert a call to the toplevel form defined around point into the REPL." + (interactive) + (cl-labels ((insert-call + (name &key (function t) + defclass) + (let* ((setf (and function + (consp name) + (= (length name) 2) + (eql (car name) 'setf))) + (symbol (if setf + (cadr name) + name)) + (qualified-symbol-name + (slime-qualify-cl-symbol-name symbol)) + (symbol-name (slime-cl-symbol-name qualified-symbol-name)) + (symbol-package (slime-cl-symbol-package + qualified-symbol-name)) + (call (if (cl-equalp (slime-lisp-package) symbol-package) + symbol-name + qualified-symbol-name))) + (slime-switch-to-output-buffer) + (goto-char slime-repl-input-start-mark) + (insert (if function + "(" + " ")) + (when setf + (insert "setf (")) + (if defclass + (insert "make-instance '")) + (insert call) + (cond (setf + (insert " ") + (save-excursion (insert ") )"))) + (function + (insert " ") + (save-excursion (insert ")")))) + (unless function + (goto-char slime-repl-input-start-mark))))) + (let ((toplevel (slime-parse-toplevel-form))) + (if (symbolp toplevel) + (error "Not in a function definition") + (slime-dcase toplevel + (((:defun :defgeneric :defmacro :define-compiler-macro) symbol) + (insert-call symbol)) + ((:defmethod symbol &rest args) + (declare (ignore args)) + (insert-call symbol)) + (((:defparameter :defvar :defconstant) symbol) + (insert-call symbol :function nil)) + (((:defclass) symbol) + (insert-call symbol :defclass t)) + (t + (error "Not in a function definition"))))))) + +(defun slime-repl-copy-down-to-repl (slimefun &rest args) + (slime-eval-async `(swank-repl:listener-save-value ',slimefun ,@args) + #'(lambda (_ignored) + (with-current-buffer (slime-repl) + (slime-eval-async '(swank-repl:listener-get-value) + #'(lambda (_ignored) + (slime-repl-insert-prompt))))))) + +(defun slime-inspector-copy-down-to-repl (number) + "Evaluate the inspector slot at point via the REPL (to set `*')." + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-repl-copy-down-to-repl 'swank:inspector-nth-part number)) + +(defun sldb-copy-down-to-repl (frame-id var-id) + "Evaluate the frame var at point via the REPL (to set `*')." + (interactive (list (sldb-frame-number-at-point) (sldb-var-number-at-point))) + (slime-repl-copy-down-to-repl 'swank/backend:frame-var-value frame-id var-id)) + +(defun sldb-insert-frame-call-to-repl () + "Insert a call to a frame at point." + (interactive) + (let ((call (slime-eval `(swank/backend::frame-call + ,(sldb-frame-number-at-point))))) + (slime-switch-to-output-buffer) + (if (>= (point) slime-repl-prompt-start-mark) + (insert call) + (save-excursion + (goto-char (point-max)) + (insert call)))) + (slime-repl)) + +(defun slime-set-default-directory (directory) + "Make DIRECTORY become Lisp's current directory." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (let ((dir (expand-file-name directory))) + (message "default-directory: %s" + (slime-from-lisp-filename + (slime-repl-shortcut-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))))) + (with-current-buffer (slime-output-buffer) + (setq default-directory dir)))) + +(defun slime-sync-package-and-default-directory () + "Set Lisp's package and directory to the values in current buffer." + (interactive) + (let* ((package (slime-current-package)) + (exists-p (or (null package) + (slime-eval `(cl:packagep + (swank::guess-package ,package))))) + (directory default-directory)) + (when (and package exists-p) + (slime-repl-set-package package)) + (slime-set-default-directory directory) + ;; Sync *inferior-lisp* dir + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq default-directory directory)))) + (message "package: %s%s directory: %s" + (with-current-buffer (slime-output-buffer) + (slime-lisp-package)) + (if exists-p "" (format " (package %s doesn't exist)" package)) + directory))) + +(defun slime-goto-connection () + "Switch to the REPL buffer for the connection at point." + (interactive) + (let ((slime-dispatching-connection (slime-connection-at-point))) + (switch-to-buffer (slime-output-buffer)))) + +(defun slime-repl-inside-string-or-comment-p () + (save-restriction + (when (and (boundp 'slime-repl-input-start-mark) + slime-repl-input-start-mark + (>= (point) slime-repl-input-start-mark)) + (narrow-to-region slime-repl-input-start-mark (point))) + (slime-inside-string-or-comment-p))) + +(defvar slime-repl-easy-menu + (let ((C '(slime-connected-p))) + `("REPL" + [ "Send Input" slime-repl-return ,C ] + [ "Close and Send Input " slime-repl-closing-return ,C ] + [ "Interrupt Lisp process" slime-interrupt ,C ] + "--" + [ "Previous Input" slime-repl-previous-input t ] + [ "Next Input" slime-repl-next-input t ] + [ "Goto Previous Prompt " slime-repl-previous-prompt t ] + [ "Goto Next Prompt " slime-repl-next-prompt t ] + [ "Clear Last Output" slime-repl-clear-output t ] + [ "Clear Buffer " slime-repl-clear-buffer t ] + [ "Kill Current Input" slime-repl-kill-input t ]))) + +(defun slime-repl-add-easy-menu () + (easy-menu-define menubar-slime-repl slime-repl-mode-map + "REPL" slime-repl-easy-menu) + (easy-menu-define menubar-slime slime-repl-mode-map + "SLIME" slime-easy-menu) + (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map)) + +(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu) + +(defun slime-hide-inferior-lisp-buffer () + "Display the REPL buffer instead of the *inferior-lisp* buffer." + (let* ((buffer (if (slime-process) + (process-buffer (slime-process)))) + (window (if buffer (get-buffer-window buffer t))) + (repl-buffer (slime-output-buffer t)) + (repl-window (get-buffer-window repl-buffer))) + (when buffer + (bury-buffer buffer)) + (cond (repl-window + (when window + (delete-window window))) + (window + (set-window-buffer window repl-buffer)) + (t + (pop-to-buffer repl-buffer) + (goto-char (point-max)))))) + +(defun slime-repl-choose-coding-system () + (let ((candidates (slime-connection-coding-systems))) + (or (cl-find (symbol-name (car default-process-coding-system)) + candidates + :test (lambda (s1 s2) + (if (fboundp 'coding-system-equal) + (coding-system-equal (intern s1) (intern s2))))) + (car candidates) + (error "Can't find suitable coding-system")))) + +(defun slime-repl-connected-hook-function () + (destructuring-bind (package prompt) + (let ((slime-current-thread t) + (cs (slime-repl-choose-coding-system))) + (slime-eval `(swank-repl:create-repl nil :coding-system ,cs))) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt)) + (slime-hide-inferior-lisp-buffer) + (slime-init-output-buffer (slime-connection))) + +(defun slime-repl-event-hook-function (event) + (slime-dcase event + ((:write-string output &optional target) + (slime-write-string output target) + t) + ((:read-string thread tag) + (assert thread) + (slime-repl-read-string thread tag) + t) + ((:read-aborted thread tag) + (slime-repl-abort-read thread tag) + t) + ((:open-dedicated-output-stream port coding-system) + (slime-open-stream-to-lisp port coding-system) + t) + ((:new-package package prompt-string) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt-string) + (let ((buffer (slime-connection-output-buffer))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq slime-buffer-package package)))) + t) + (t nil))) + +(defun slime-change-repl-to-default-connection () + "Change current REPL to the REPL of the default connection. +If the current buffer is not a REPL, don't do anything." + (when (equal major-mode 'slime-repl-mode) + (let ((slime-buffer-connection slime-default-connection)) + (pop-to-buffer-same-window (slime-connection-output-buffer))))) + +(defun slime-repl-find-buffer-package () + (or (slime-search-buffer-package) + (slime-lisp-package))) + +(defun slime-repl-add-hooks () + (add-hook 'slime-event-hooks 'slime-repl-event-hook-function) + (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function) + (add-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) + +(defun slime-repl-remove-hooks () + (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function) + (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function) + (remove-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) + +(defun slime-repl-sexp-at-point () + "Returns the current sexp at point (or NIL if none is found) +while ignoring the repl prompt text." + (if (<= slime-repl-input-start-mark (point)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point-max)) + (slime-sexp-at-point)) + (slime-sexp-at-point))) + +(defun slime-repl-inspect (string) + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-repl-sexp-at-point)))) + (slime-inspect string)) + +(require 'bytecomp) + +;; (mapc (lambda (sym) +;; (cond ((fboundp sym) +;; (unless (byte-code-function-p (symbol-function sym)) +;; (byte-compile sym))) +;; (t (error "%S is not fbound" sym)))) +;; '(slime-repl-event-hook-function +;; slime-write-string +;; slime-repl-write-string +;; slime-repl-emit +;; slime-repl-show-maximum-output)) + +(provide 'slime-repl) diff --git a/elpa/slime-20200319.1939/contrib/slime-repl.elc b/elpa/slime-20200319.1939/contrib/slime-repl.elc new file mode 100644 index 00000000..6fd63da5 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-repl.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.el b/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.el new file mode 100644 index 00000000..ab1c524d --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.el @@ -0,0 +1,34 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-sbcl-exts + "Misc extensions for SBCL" + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-references) + (:swank-dependencies swank-sbcl-exts)) + +(defun slime-sbcl-bug-at-point () + (save-excursion + (save-match-data + (unless (looking-at "#[0-9]\\{6\\}") + (search-backward-regexp "#\\<" (line-beginning-position) t)) + (when (looking-at "#[0-9]\\{6\\}") + (buffer-substring-no-properties (match-beginning 0) (match-end 0)))))) + +(defun slime-read-sbcl-bug (prompt &optional query) + "Either read a sbcl bug or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (let ((bug (slime-sbcl-bug-at-point))) + (cond ((or current-prefix-arg query (not bug)) + (slime-read-from-minibuffer prompt bug)) + (t bug)))) + +(defun slime-visit-sbcl-bug (bug) + "Visit the Launchpad site that describes `bug' (#nnnnnn)." + (interactive (list (slime-read-sbcl-bug "Bug number (#nnnnnn): "))) + (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" + (substring bug 1)))) + +(provide 'slime-sbcl-exts) diff --git a/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.elc b/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.elc new file mode 100644 index 00000000..477a7b1b Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-sbcl-exts.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-scheme.el b/elpa/slime-20200319.1939/contrib/slime-scheme.el new file mode 100644 index 00000000..9b7abd69 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-scheme.el @@ -0,0 +1,40 @@ +;;; slime-scheme.el --- Support Scheme programs running under Common Lisp +;; +;; Authors: Matthias Koeppe +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-scheme))) +;; +(eval-and-compile + (require 'slime)) + +(defun slime-scheme-mode-hook () + (slime-mode 1)) + +(defun slime-scheme-indentation-update (symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'scheme-indent-function) + (get symbol 'slime-scheme-indent)) + (put symbol 'slime-scheme-indent indent) + (put symbol 'scheme-indent-function indent))) + + +;;; Initialization + +(defun slime-scheme-init () + (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook) + (add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) + (add-to-list 'slime-lisp-modes 'scheme-mode)) + +(defun slime-scheme-unload () + (remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook) + (remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) + (setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes))) + +(provide 'slime-scheme) diff --git a/elpa/slime-20200319.1939/contrib/slime-scheme.elc b/elpa/slime-20200319.1939/contrib/slime-scheme.elc new file mode 100644 index 00000000..e254ea42 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-scheme.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-scratch.el b/elpa/slime-20200319.1939/contrib/slime-scratch.el new file mode 100644 index 00000000..113fae0a --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-scratch.el @@ -0,0 +1,48 @@ +;;; slime-scratch.el + +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-scratch + "Imitate Emacs' *scratch* buffer" + (:authors "Helmut Eller ") + (:license "GPL") + (:on-load + (def-slime-selector-method ?s "*slime-scratch* buffer." + (slime-scratch-buffer)))) + + +;;; Code + +(defvar slime-scratch-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(defun slime-scratch () + (interactive) + (slime-switch-to-scratch-buffer)) + +(defun slime-switch-to-scratch-buffer () + (set-buffer (slime-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defvar slime-scratch-file nil) + +(defun slime-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer (slime-buffer-name :scratch)) + (with-current-buffer (if slime-scratch-file + (find-file slime-scratch-file) + (get-buffer-create (slime-buffer-name :scratch))) + (rename-buffer (slime-buffer-name :scratch)) + (lisp-mode) + (use-local-map slime-scratch-mode-map) + (slime-mode t) + (current-buffer)))) + +(slime-define-keys slime-scratch-mode-map + ("\C-j" 'slime-eval-print-last-expression)) + +(provide 'slime-scratch) diff --git a/elpa/slime-20200319.1939/contrib/slime-scratch.elc b/elpa/slime-20200319.1939/contrib/slime-scratch.elc new file mode 100644 index 00000000..f7e9fcab Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-scratch.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-snapshot.el b/elpa/slime-20200319.1939/contrib/slime-snapshot.el new file mode 100644 index 00000000..1643ecca --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-snapshot.el @@ -0,0 +1,34 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-snapshot + "Save&restore memory images without disconnecting" + (:authors "Helmut Eller ") + (:license "GPL v3") + (:swank-dependencies swank-snapshot)) + +(defun slime-snapshot (filename &optional background) + "Save a memory image to the file FILENAME." + (interactive (list (read-file-name "Image file: ") + current-prefix-arg)) + (let ((file (expand-file-name filename))) + (when (and (file-exists-p file) + (not (yes-or-no-p (format "File exists %s. Overwrite it? " + filename)))) + (signal 'quit nil)) + (slime-eval-with-transcript + `(,(if background + 'swank-snapshot:background-save-snapshot + 'swank-snapshot:save-snapshot) + ,file)))) + +(defun slime-restore (filename) + "Restore a memory image stored in file FILENAME." + (interactive (list (read-file-name "Image file: "))) + ;; bypass event dispatcher because we don't expect a reply. FIXME. + (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot + ,(expand-file-name filename)) + nil t nil) + (slime-connection))) + +(provide 'slime-snapshot) diff --git a/elpa/slime-20200319.1939/contrib/slime-snapshot.elc b/elpa/slime-20200319.1939/contrib/slime-snapshot.elc new file mode 100644 index 00000000..f94e656b Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-snapshot.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-sprof.el b/elpa/slime-20200319.1939/contrib/slime-sprof.el new file mode 100644 index 00000000..8233e7b2 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-sprof.el @@ -0,0 +1,224 @@ +(require 'slime) +(require 'cl-lib) +(eval-when-compile (require 'cl)) ; lexical-let* + +(define-slime-contrib slime-sprof + "Integration with SBCL's sb-sprof." + (:authors "Juho Snellman" + "Stas Boukarev") + (:license "MIT") + (:swank-dependencies swank-sprof) + (:on-load + (let ((C '(and (slime-connected-p) + (equal (slime-lisp-implementation-type) "SBCL")))) + (setf (cdr (last (assoc "Profiling" slime-easy-menu))) + `("--" + [ "Start sb-sprof" slime-sprof-start ,C ] + [ "Stop sb-sprof" slime-sprof-stop ,C ] + [ "Report sb-sprof" slime-sprof-report ,C ]))))) + +(defvar slime-sprof-exclude-swank nil + "*Display swank functions in the report.") + +(define-derived-mode slime-sprof-browser-mode fundamental-mode + "slprof" + "Mode for browsing profiler data\ +\\\ +\\{slime-sprof-browser-mode-map}" + :syntax-table lisp-mode-syntax-table + (setq buffer-read-only t)) + +(set-keymap-parent slime-sprof-browser-mode-map slime-parent-map) + +(slime-define-keys slime-sprof-browser-mode-map + ("h" 'describe-mode) + ("d" 'slime-sprof-browser-disassemble-function) + ("g" 'slime-sprof-browser-go-to) + ("v" 'slime-sprof-browser-view-source) + ("s" 'slime-sprof-toggle-swank-exclusion) + ((kbd "RET") 'slime-sprof-browser-toggle)) + +;; Start / stop profiling + +(cl-defun slime-sprof-start (&optional (mode :cpu)) + (interactive) + (slime-eval `(swank:swank-sprof-start :mode ,mode))) + +(defun slime-sprof-start-alloc () + (interactive) + (slime-sprof-start :alloc)) + +(defun slime-sprof-start-time () + (interactive) + (slime-sprof-start :time)) + +(defun slime-sprof-stop () + (interactive) + (slime-eval `(swank:swank-sprof-stop))) + +;; Reporting + +(defun slime-sprof-format (graph) + (with-current-buffer (slime-buffer-name :sprof) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (format "%4s %-54s %6s %6s %6s\n" + "Rank" + "Name" + "Self%" + "Cumul%" + "Total%")) + (dolist (data graph) + (slime-sprof-browser-insert-line data 54)))) + (forward-line 2)) + +(cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank)) + (slime-eval-async `(swank:swank-sprof-get-call-graph + :exclude-swank ,exclude-swank) + 'slime-sprof-format)) + +(defalias 'slime-sprof-browser 'slime-sprof-report) + +(defun slime-sprof-report () + (interactive) + (slime-with-popup-buffer ((slime-buffer-name :sprof) + :connection t + :select t + :mode 'slime-sprof-browser-mode) + (slime-sprof-update))) + +(defun slime-sprof-toggle-swank-exclusion () + (interactive) + (setq slime-sprof-exclude-swank + (not slime-sprof-exclude-swank)) + (slime-sprof-update)) + +(defun slime-sprof-browser-insert-line (data name-length) + (cl-destructuring-bind (index name self cumul total) + data + (if index + (insert (format "%-4d " index)) + (insert " ")) + (slime-insert-propertized + (slime-sprof-browser-name-properties) + (format (format "%%-%ds " name-length) + (slime-sprof-abbreviate-name name name-length))) + (insert (format "%6.2f " self)) + (when cumul + (insert (format "%6.2f " cumul)) + (when total + (insert (format "%6.2f" total)))) + (when index + (slime-sprof-browser-add-line-text-properties + `(profile-index ,index expanded nil))) + (insert "\n"))) + +(defun slime-sprof-abbreviate-name (name max-length) + (cl-subseq name 0 (min (length name) max-length))) + +;; Expanding / collapsing + +(defun slime-sprof-browser-toggle () + (interactive) + (let ((index (get-text-property (point) 'profile-index))) + (when index + (save-excursion + (if (slime-sprof-browser-line-expanded-p) + (slime-sprof-browser-collapse) + (slime-sprof-browser-expand)))))) + +(defun slime-sprof-browser-collapse () + (let ((inhibit-read-only t)) + (slime-sprof-browser-add-line-text-properties '(expanded nil)) + (forward-line) + (cl-loop until (or (eobp) + (get-text-property (point) 'profile-index)) + do + (delete-region (point-at-bol) (point-at-eol)) + (unless (eobp) + (delete-char 1))))) + +(defun slime-sprof-browser-expand () + (lexical-let* ((buffer (current-buffer)) + (point (point)) + (index (get-text-property point 'profile-index))) + (slime-eval-async `(swank:swank-sprof-expand-node ,index) + (lambda (data) + (with-current-buffer buffer + (save-excursion + (destructuring-bind (&key callers calls) + data + (slime-sprof-browser-add-expansion callers + "Callers" + 0) + (slime-sprof-browser-add-expansion calls + "Calls" + 0)))))))) + +(defun slime-sprof-browser-add-expansion (data type nesting) + (when data + (let ((inhibit-read-only t)) + (slime-sprof-browser-add-line-text-properties '(expanded t)) + (end-of-line) + (insert (format "\n %s" type)) + (dolist (node data) + (cl-destructuring-bind (index name cumul) node + (insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) "")) + (slime-insert-propertized + (slime-sprof-browser-name-properties) + (let ((len (- 59 (* 2 nesting)))) + (format (format "%%-%ds " len) + (slime-sprof-abbreviate-name name len)))) + (slime-sprof-browser-add-line-text-properties + `(profile-sub-index ,index)) + (insert (format "%6.2f" cumul))))))) + +(defun slime-sprof-browser-line-expanded-p () + (get-text-property (point) 'expanded)) + +(defun slime-sprof-browser-add-line-text-properties (properties) + (add-text-properties (point-at-bol) + (point-at-eol) + properties)) + +(defun slime-sprof-browser-name-properties () + '(face sldb-restart-number-face)) + +;; "Go to function" + +(defun slime-sprof-browser-go-to () + (interactive) + (let ((sub-index (get-text-property (point) 'profile-sub-index))) + (when sub-index + (let ((pos (text-property-any + (point-min) (point-max) 'profile-index sub-index))) + (when pos (goto-char pos)))))) + +;; Disassembly + +(defun slime-sprof-browser-disassemble-function () + (interactive) + (let ((index (or (get-text-property (point) 'profile-index) + (get-text-property (point) 'profile-sub-index)))) + (when index + (slime-eval-describe `(swank:swank-sprof-disassemble + ,index))))) + +;; View source + +(defun slime-sprof-browser-view-source () + (interactive) + (let ((index (or (get-text-property (point) 'profile-index) + (get-text-property (point) 'profile-sub-index)))) + (when index + (slime-eval-async + `(swank:swank-sprof-source-location ,index) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location)))))))) + +(provide 'slime-sprof) diff --git a/elpa/slime-20200319.1939/contrib/slime-sprof.elc b/elpa/slime-20200319.1939/contrib/slime-sprof.elc new file mode 100644 index 00000000..0f2dbe3a Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-sprof.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-trace-dialog.el b/elpa/slime-20200319.1939/contrib/slime-trace-dialog.el new file mode 100644 index 00000000..fd25c7b8 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-trace-dialog.el @@ -0,0 +1,837 @@ +;;; -*- coding: utf-8; lexical-binding: t -*- +;;; +;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries +;;; +;;; TODO: implement better wrap interface for sbcl method, labels and such +;;; TODO: backtrace printing is very slow +;;; +(require 'slime) +(require 'slime-parse) +(require 'slime-repl) +(require 'cl-lib) + +(define-slime-contrib slime-trace-dialog + "Provide an interfactive trace dialog buffer for managing and +inspecting details of traced functions. Invoke this dialog with C-c T." + (:authors "João Távora ") + (:license "GPL") + (:swank-dependencies swank-trace-dialog) + (:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable) + (add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)) + (:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable) + (remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))) + + +;;;; Variables +;;; +(defvar slime-trace-dialog-flash t + "Non-nil means flash the updated region of the SLIME Trace Dialog. ") + +(defvar slime-trace-dialog--specs-overlay nil) + +(defvar slime-trace-dialog--progress-overlay nil) + +(defvar slime-trace-dialog--tree-overlay nil) + +(defvar slime-trace-dialog--collapse-chars (cons "-" "+")) + + +;;;; Local trace entry model +(defvar slime-trace-dialog--traces nil) + +(cl-defstruct (slime-trace-dialog--trace + (:constructor slime-trace-dialog--make-trace)) + id + parent + spec + args + retlist + depth + beg + end + collapse-button-marker + summary-beg + children-end + collapsed-p) + +(defun slime-trace-dialog--find-trace (id) + (gethash id slime-trace-dialog--traces)) + + +;;;; Modes and mode maps +;;; +(defvar slime-trace-dialog-mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-operate-on-point . nil) + (slime-inspector-operate-on-click . nil) + (slime-inspector-reinspect + . slime-trace-dialog-fetch-status) + (slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-inspector-mode-map) + (cl-loop for (old . new) in remaps + do (substitute-key-definition old new map)) + (set-keymap-parent map slime-parent-map) + (define-key map (kbd "G") 'slime-trace-dialog-fetch-traces) + (define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces) + (define-key map (kbd "g") 'slime-trace-dialog-fetch-status) + (define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl) + (define-key map (kbd "q") 'quit-window) + map)) + +(define-derived-mode slime-trace-dialog-mode fundamental-mode + "SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog" + (set-syntax-table lisp-mode-syntax-table) + (read-only-mode 1) + (add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook) + 'slime-trace-dialog-fetch-status)) + +(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode + "SLIME Trace Detail" + "Mode for viewing a particular trace from SLIME's Trace Dialog") + +(setq slime-trace-dialog--detail-mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-trace-dialog-mode-map) + (cl-loop for (old . new) in remaps + do (substitute-key-definition old new map)) + map)) + +(defvar slime-trace-dialog-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c T") 'slime-trace-dialog) + (define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace) + map)) + +(define-minor-mode slime-trace-dialog-minor-mode + "Add keybindings for accessing SLIME's Trace Dialog.") + +(defun slime-trace-dialog-enable () + (slime-trace-dialog-minor-mode 1)) + +(easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map + slime-trace-dialog-mode-map) + "A menu for accessing some features of SLIME's Trace Dialog" + (let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode)) + (dialog-live `(and ,in-dialog + (memq slime-buffer-connection slime-net-processes))) + (connected '(slime-connected-p))) + `("Trace" + ["Toggle trace" slime-trace-dialog-toggle-trace ,connected] + ["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected] + ["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))] + "--" + [ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live] + [ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live] + [ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live] + [ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog] + [ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog]))) + +(define-minor-mode slime-trace-dialog-hide-details-mode + "Hide details in `slime-trace-dialog-mode'" + nil " Brief" + :group 'slime-trace-dialog + (unless (derived-mode-p 'slime-trace-dialog-mode) + (error "Not a SLIME Trace Dialog buffer")) + (slime-trace-dialog--set-hide-details-mode)) + +(define-minor-mode slime-trace-dialog-autofollow-mode + "Automatically open buffers with trace details from `slime-trace-dialog-mode'" + nil " Autofollow" + :group 'slime-trace-dialog + (unless (derived-mode-p 'slime-trace-dialog-mode) + (error "Not a SLIME Trace Dialog buffer"))) + + +;;;; Helper functions +;;; +(defun slime-trace-dialog--call-refreshing (buffer + overlay + dont-erase + recover-point-p + fn) + (with-current-buffer buffer + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (saved (point))) + (save-restriction + (when overlay + (narrow-to-region (overlay-start overlay) + (overlay-end overlay))) + (unwind-protect + (if dont-erase + (goto-char (point-max)) + (delete-region (point-min) (point-max))) + (funcall fn) + (when recover-point-p + (goto-char saved))) + (when slime-trace-dialog-flash + (slime-flash-region (point-min) (point-max))))) + buffer)) + +(cl-defmacro slime-trace-dialog--refresh ((&key + overlay + dont-erase + recover-point-p + buffer) + &rest body) + (declare (indent 1) + (debug (sexp &rest form))) + `(slime-trace-dialog--call-refreshing ,(or buffer + `(current-buffer)) + ,overlay + ,dont-erase + ,recover-point-p + #'(lambda () ,@body))) + +(defmacro slime-trace-dialog--insert-and-overlay (string overlay) + `(save-restriction + (let ((inhibit-read-only t)) + (narrow-to-region (point) (point)) + (insert ,string "\n") + (set (make-local-variable ',overlay) + (let ((overlay (make-overlay (point-min) + (point-max) + (current-buffer) + nil + t))) + (move-overlay overlay (overlay-start overlay) + (1- (overlay-end overlay))) + ;; (overlay-put overlay 'face '(:background "darkslategrey")) + overlay))))) + +(defun slime-trace-dialog--buffer-name () + (format "*traces for %s*" + (slime-connection-name slime-default-connection))) + +(defun slime-trace-dialog--live-dialog (&optional buffer-or-name) + (let ((buffer-or-name (or buffer-or-name + (slime-trace-dialog--buffer-name)))) + (and (buffer-live-p (get-buffer buffer-or-name)) + (with-current-buffer buffer-or-name + (memq slime-buffer-connection slime-net-processes)) + buffer-or-name))) + +(defun slime-trace-dialog--ensure-buffer () + (let ((name (slime-trace-dialog--buffer-name))) + (or (slime-trace-dialog--live-dialog name) + (with-current-buffer (get-buffer-create name) + (let ((inhibit-read-only t)) + (erase-buffer)) + (slime-trace-dialog-mode) + (save-excursion + (buffer-disable-undo) + (slime-trace-dialog--insert-and-overlay + "[waiting for the traced specs to be available]" + slime-trace-dialog--specs-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for some info on trace download progress ]" + slime-trace-dialog--progress-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for the actual traces to be available]" + slime-trace-dialog--tree-overlay) + (current-buffer)) + (setq slime-buffer-connection slime-default-connection) + (current-buffer))))) + +(defun slime-trace-dialog--make-autofollow-fn (id) + (let ((requested nil)) + #'(lambda (_before after) + (let ((inhibit-point-motion-hooks t) + (id-after (get-text-property after 'slime-trace-dialog--id))) + (when (and (= after (point)) + slime-trace-dialog-autofollow-mode + id-after + (= id-after id) + (not requested)) + (setq requested t) + (slime-eval-async `(swank-trace-dialog:report-trace-detail + ,id-after) + #'(lambda (detail) + (setq requested nil) + (when detail + (let ((inhibit-point-motion-hooks t)) + (slime-trace-dialog--open-detail detail + 'no-pop)))))))))) + +(defun slime-trace-dialog--set-collapsed (collapsed-p trace button) + (save-excursion + (setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p) + (slime-trace-dialog--go-replace-char-at + button + (if collapsed-p + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars))) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if collapsed-p 1 -1)) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-end trace) + (slime-trace-dialog--trace-children-end trace) + (if collapsed-p 1 -1)))) + +(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta) + (cl-loop with inhibit-read-only = t + for pos = start-pos then next + for next = (next-single-property-change + pos + 'slime-trace-dialog--hidden-level + nil + end-pos) + for hidden-level = (+ (or (get-text-property + pos + 'slime-trace-dialog--hidden-level) + 0) + delta) + do (add-text-properties pos next + (list 'slime-trace-dialog--hidden-level + hidden-level + 'invisible + (cl-plusp hidden-level))) + while (< next end-pos))) + +(defun slime-trace-dialog--set-hide-details-mode () + (cl-loop for trace being the hash-values of slime-trace-dialog--traces + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if slime-trace-dialog-hide-details-mode 1 -1)))) + +(defun slime-trace-dialog--format-part (part-id part-text trace-id type) + (slime-trace-dialog--button + (format "%s" part-text) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) + #'slime-open-inspector)) + 'mouse-face 'highlight + 'slime-trace-dialog--part-id part-id + 'slime-trace-dialog--type type + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format-trace-entry (id external) + (slime-trace-dialog--button + (format "%s" external) + #'(lambda (_button) + (slime-eval-async + `(swank::inspect-object (swank-trace-dialog::find-trace ,id)) + #'slime-open-inspector)) + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format (fmt-string &rest args) + (let* ((string (apply #'format fmt-string args)) + (indent (make-string (max 2 + (- 50 (length string))) ? ))) + (format "%s%s" string indent))) + +(defun slime-trace-dialog--button (title lambda &rest props) + (let ((string (format "%s" title))) + (apply #'make-text-button string nil + 'action #'(lambda (button) + (funcall lambda button)) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face + props) + string)) + +(defun slime-trace-dialog--call-maintaining-properties (pos fn) + (save-excursion + (goto-char pos) + (let* ((saved-props (text-properties-at pos)) + (saved-point (point)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (funcall fn) + (add-text-properties saved-point (point) saved-props) + (if (markerp pos) (set-marker pos saved-point))))) + +(cl-defmacro slime-trace-dialog--maintaining-properties (pos + &body body) + (declare (indent 1)) + `(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) + +(defun slime-trace-dialog--go-replace-char-at (pos char) + (slime-trace-dialog--maintaining-properties pos + (delete-char 1) + (insert char))) + + +;;;; Handlers for the *trace-dialog* and *trace-detail* buffers +;;; +(defun slime-trace-dialog--open-specs (traced-specs) + (cl-labels ((make-report-spec-fn + (&optional form) + #'(lambda (_button) + (slime-eval-async + `(cl:progn + ,form + (swank-trace-dialog:report-specs)) + #'(lambda (results) + (slime-trace-dialog--open-specs results)))))) + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--specs-overlay + :recover-point-p t) + (insert + (slime-trace-dialog--format "Traced specs (%s)" (length traced-specs)) + (slime-trace-dialog--button "[refresh]" + (make-report-spec-fn)) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[untrace all]" + (make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all))) + "\n\n") + (cl-loop for spec in traced-specs + do (insert + " " + (slime-trace-dialog--button + "[untrace]" + (make-report-spec-fn + `(swank-trace-dialog:dialog-untrace ',spec))) + (format " %s" spec) + "\n"))))) + +(defvar slime-trace-dialog--fetch-key nil) + +(defvar slime-trace-dialog--stop-fetching nil) + +(defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p) + ;; `remaining-p' indicates `total' is the number of remaining traces. + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--progress-overlay + :recover-point-p t) + (let* ((done (hash-table-count slime-trace-dialog--traces)) + (total (if remaining-p (+ done total) total))) + (insert + (slime-trace-dialog--format "Trace collection status (%d/%s)" + done + (or total "0")) + (slime-trace-dialog--button "[refresh]" + #'(lambda (_button) + (slime-trace-dialog-fetch-progress)))) + + (when (and total (cl-plusp (- total done))) + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch next batch]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces nil))) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch all]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces t))))) + (when total + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[clear]" + #'(lambda (_button) + (slime-trace-dialog-clear-fetched-traces))))) + (when show-stop-p + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[stop]" + #'(lambda (_button) + (setq slime-trace-dialog--stop-fetching t))))) + (insert "\n\n")))) + +(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop) + (slime-with-popup-buffer ("*trace-detail*" :select (not no-pop) + :mode 'slime-trace-dialog--detail-mode) + (cl-destructuring-bind (id _parent-id _spec args retlist backtrace external) + trace-tuple + (let ((headline (slime-trace-dialog--format-trace-entry id external))) + (setq headline (format "%s\n%s\n" + headline + (make-string (length headline) ?-))) + (insert headline)) + (cl-loop for (type objects label) + in `((:arg ,args "Called with args:") + (:retval ,retlist "Returned values:")) + do (insert (format "\n%s\n" label)) + (insert (cl-loop for object in objects + for i from 0 + concat (format " %s: %s\n" i + (slime-trace-dialog--format-part + (cl-first object) + (cl-second object) + id + type))))) + (when backtrace + (insert "\nBacktrace:\n" + (cl-loop for (i spec) in backtrace + concat (format " %s: %s\n" i spec))))))) + + +;;;; Rendering traces +;;; +(defun slime-trace-dialog--draw-tree-lines (start offset direction) + (save-excursion + (let ((inhibit-point-motion-hooks t)) + (goto-char start) + (cl-loop with replace-set = (if (eq direction 'down) + '(? ) + '(? ?`)) + for line-beginning = (line-beginning-position + (if (eq direction 'down) + 2 0)) + for pos = (+ line-beginning offset) + while (and (< (point-min) line-beginning) + (< line-beginning (point-max)) + (memq (char-after pos) replace-set)) + do + (slime-trace-dialog--go-replace-char-at pos "|") + (goto-char pos))))) + +(defun slime-trace-dialog--make-indent (depth suffix) + (concat (make-string (* 3 (max 0 (1- depth))) ? ) + (if (cl-plusp depth) suffix))) + +(defun slime-trace-dialog--make-collapse-button (trace) + (slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace) + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars)) + #'(lambda (button) + (slime-trace-dialog--set-collapsed + (not (slime-trace-dialog--trace-collapsed-p + trace)) + trace + button)))) + + +(defun slime-trace-dialog--insert-trace (trace) + (let* ((id (slime-trace-dialog--trace-id trace)) + (parent (slime-trace-dialog--trace-parent trace)) + (has-children-p (slime-trace-dialog--trace-children-end trace)) + (indent-spec (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + "`--")) + (indent-summary (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + " ")) + (autofollow-fn (slime-trace-dialog--make-autofollow-fn id)) + (id-string (slime-trace-dialog--button + (format "%4s" id) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:report-trace-detail + ,id) + #'slime-trace-dialog--open-detail)))) + (spec (slime-trace-dialog--trace-spec trace)) + (summary (cl-loop for (type objects marker) in + `((:arg ,(slime-trace-dialog--trace-args trace) + " > ") + (:retval ,(slime-trace-dialog--trace-retlist trace) + " < ")) + concat (cl-loop for object in objects + concat " " + concat indent-summary + concat marker + concat (slime-trace-dialog--format-part + (cl-first object) + (cl-second object) + id + type) + concat "\n")))) + (puthash id trace slime-trace-dialog--traces) + ;; insert and propertize the text + ;; + (setf (slime-trace-dialog--trace-beg trace) (point-marker)) + (insert id-string " ") + (insert indent-spec) + (if has-children-p + (insert (slime-trace-dialog--make-collapse-button trace)) + (setf (slime-trace-dialog--trace-collapse-button-marker trace) + (point-marker)) + (insert "-")) + (insert (format " %s\n" spec)) + (setf (slime-trace-dialog--trace-summary-beg trace) (point-marker)) + (insert summary) + (setf (slime-trace-dialog--trace-end trace) (point-marker)) + (set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t) + + (add-text-properties (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (list 'slime-trace-dialog--id id + 'point-entered autofollow-fn + 'point-left autofollow-fn)) + ;; respect brief mode and collapsed state + ;; + (cl-loop for condition in (list slime-trace-dialog-hide-details-mode + (slime-trace-dialog--trace-collapsed-p trace)) + when condition + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg + trace) + (slime-trace-dialog--trace-end trace) + 1)) + (cl-loop for tr = trace then parent + for parent = (slime-trace-dialog--trace-parent tr) + while parent + when (slime-trace-dialog--trace-collapsed-p parent) + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (+ 1 + (or (get-text-property (slime-trace-dialog--trace-beg parent) + 'slime-trace-dialog--hidden-level) + 0))) + (cl-return)) + ;; maybe add the collapse-button to the parent in case it didn't + ;; have one already + ;; + (when (and parent + (slime-trace-dialog--trace-collapse-button-marker parent)) + (slime-trace-dialog--maintaining-properties + (slime-trace-dialog--trace-collapse-button-marker parent) + (delete-char 1) + (insert (slime-trace-dialog--make-collapse-button parent)) + (setf (slime-trace-dialog--trace-collapse-button-marker parent) + nil))) + ;; draw the tree lines + ;; + (when parent + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 2 (length indent-spec)) + 'up)) + (when has-children-p + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 5 (length indent-spec)) + 'down)) + ;; set the "children-end" slot + ;; + (unless (slime-trace-dialog--trace-children-end trace) + (cl-loop for parent = trace + then (slime-trace-dialog--trace-parent parent) + while parent + do + (setf (slime-trace-dialog--trace-children-end parent) + (slime-trace-dialog--trace-end trace)))))) + +(defun slime-trace-dialog--render-trace (trace) + ;; Render the trace entry in the appropriate place. + ;; + ;; A trace becomes a few lines of slightly propertized text in the + ;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by + ;; point markers that we use here. + ;; + ;; The new trace might be replacing an existing one, or otherwise + ;; must be placed under its existing parent which might or might not + ;; be the last entry inserted. + ;; + (let ((existing (slime-trace-dialog--find-trace + (slime-trace-dialog--trace-id trace))) + (parent (slime-trace-dialog--trace-parent trace))) + (cond (existing + ;; Other traces might already reference `existing' and with + ;; need to maintain that eqness. Best way to do that is + ;; destructively modify `existing' with the new retlist... + ;; + (setf (slime-trace-dialog--trace-retlist existing) + (slime-trace-dialog--trace-retlist trace)) + ;; Now, before deleting and re-inserting `existing' at an + ;; arbitrary point in the tree, note that it's + ;; "children-end" marker is already non-nil, and informs us + ;; about its parenthood status. We want to 1. leave it + ;; alone if it's already a parent, or 2. set it to nil if + ;; it's a leaf, thus forcing the needed update of the + ;; parents' "children-end" marker. + ;; + (when (= (slime-trace-dialog--trace-children-end existing) + (slime-trace-dialog--trace-end existing)) + (setf (slime-trace-dialog--trace-children-end existing) nil)) + (delete-region (slime-trace-dialog--trace-beg existing) + (slime-trace-dialog--trace-end existing)) + (goto-char (slime-trace-dialog--trace-end existing)) + ;; Remember to set `trace' to be `existing' + ;; + (setq trace existing)) + (parent + (goto-char (1+ (slime-trace-dialog--trace-children-end parent)))) + (;; top level trace + t + (goto-char (point-max)))) + (goto-char (line-beginning-position)) + (slime-trace-dialog--insert-trace trace))) + +(defun slime-trace-dialog--update-tree (tuples) + (save-excursion + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--tree-overlay + :dont-erase t) + (cl-loop for tuple in tuples + for parent = (slime-trace-dialog--find-trace (cl-second tuple)) + for trace = (slime-trace-dialog--make-trace + :id (cl-first tuple) + :parent parent + :spec (cl-third tuple) + :args (cl-fourth tuple) + :retlist (cl-fifth tuple) + :depth (if parent + (1+ (slime-trace-dialog--trace-depth + parent)) + 0)) + do (slime-trace-dialog--render-trace trace))))) + +(defun slime-trace-dialog--clear-local-tree () + (set (make-local-variable 'slime-trace-dialog--fetch-key) + (cl-gensym "slime-trace-dialog-fetch-key-")) + (set (make-local-variable 'slime-trace-dialog--traces) + (make-hash-table)) + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--tree-overlay)) + (slime-trace-dialog--update-progress nil)) + +(defun slime-trace-dialog--on-new-results (results &optional recurse) + (cl-destructuring-bind (tuples remaining reply-key) + results + (cond ((and slime-trace-dialog--fetch-key + (string= (symbol-name slime-trace-dialog--fetch-key) + (symbol-name reply-key))) + (slime-trace-dialog--update-tree tuples) + (slime-trace-dialog--update-progress + remaining + (and recurse + (cl-plusp remaining)) + t) + (when (and recurse + (not (prog1 slime-trace-dialog--stop-fetching + (setq slime-trace-dialog--stop-fetching nil))) + (cl-plusp remaining)) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',reply-key) + #'(lambda (results) (slime-trace-dialog--on-new-results + results + recurse)))))))) + + +;;;; Interactive functions +;;; +(defun slime-trace-dialog-fetch-specs () + "Refresh just list of traced specs." + (interactive) + (slime-eval-async `(swank-trace-dialog:report-specs) + #'slime-trace-dialog--open-specs)) + +(defun slime-trace-dialog-fetch-progress () + (interactive) + (slime-eval-async + '(swank-trace-dialog:report-total) + #'(lambda (total) + (slime-trace-dialog--update-progress + total)))) + +(defun slime-trace-dialog-fetch-status () + "Refresh just the status part of the SLIME Trace Dialog" + (interactive) + (slime-trace-dialog-fetch-specs) + (slime-trace-dialog-fetch-progress)) + +(defun slime-trace-dialog-clear-fetched-traces (&optional interactive) + "Clear local and remote traces collected so far" + (interactive "p") + (when (or (not interactive) + (y-or-n-p "Clear all collected and fetched traces?")) + (slime-eval-async + '(swank-trace-dialog:clear-trace-tree) + #'(lambda (_ignored) + (slime-trace-dialog--clear-local-tree))))) + +(defun slime-trace-dialog-fetch-traces (&optional recurse) + (interactive "P") + (setq slime-trace-dialog--stop-fetching nil) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',slime-trace-dialog--fetch-key) + #'(lambda (results) (slime-trace-dialog--on-new-results results + recurse)))) + +(defun slime-trace-dialog-next-button (&optional goback) + (interactive) + (let ((finder (if goback + #'previous-single-property-change + #'next-single-property-change))) + (cl-loop for pos = (funcall finder (point) 'action) + while pos + do (goto-char pos) + until (get-text-property pos 'action)))) + +(defun slime-trace-dialog-prev-button () + (interactive) + (slime-trace-dialog-next-button 'goback)) + +(defvar slime-trace-dialog-after-toggle-hook nil + "Hooks run after toggling a dialog-trace") + +(defun slime-trace-dialog-toggle-trace (&optional using-context-p) + "Toggle the dialog-trace of the spec at point. + +When USING-CONTEXT-P, attempt to decipher lambdas. methods and +other complicated function specs." + (interactive "P") + ;; Notice the use of "spec strings" here as opposed to the + ;; proper cons specs we use on the swank side. + ;; + ;; Notice the conditional use of `slime-trace-query' found in + ;; swank-fancy-trace.el + ;; + (let* ((spec-string (if using-context-p + (slime-extract-context) + (slime-symbol-at-point))) + (spec-string (if (fboundp 'slime-trace-query) + (slime-trace-query spec-string) + spec-string))) + (message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace + (swank::from-string ,spec-string)))) + (run-hooks 'slime-trace-dialog-after-toggle-hook))) + +(defun slime-trace-dialog--update-existing-dialog () + (let ((existing (slime-trace-dialog--live-dialog))) + (when existing + (with-current-buffer existing + (slime-trace-dialog-fetch-status))))) + +(add-hook 'slime-trace-dialog-after-toggle-hook + 'slime-trace-dialog--update-existing-dialog) + +(defun slime-trace-dialog-toggle-complex-trace () + "Toggle the dialog-trace of the complex spec at point. + +See `slime-trace-dialog-toggle-trace'." + (interactive) + (slime-trace-dialog-toggle-trace t)) + +(defun slime-trace-dialog (&optional clear-and-fetch) + "Show trace dialog and refresh trace collection status. + +With optional CLEAR-AND-FETCH prefix arg, clear the current tree +and fetch a first batch of traces." + (interactive "P") + (with-current-buffer + (pop-to-buffer (slime-trace-dialog--ensure-buffer)) + (slime-trace-dialog-fetch-status) + (when (or clear-and-fetch + (null slime-trace-dialog--fetch-key)) + (slime-trace-dialog--clear-local-tree)) + (when clear-and-fetch + (slime-trace-dialog-fetch-traces nil)))) + +(defun slime-trace-dialog-copy-down-to-repl (id part-id type) + "Eval the Trace Dialog entry under point in the REPL (to set *)" + (interactive (cl-loop for prop in '(slime-trace-dialog--id + slime-trace-dialog--part-id + slime-trace-dialog--type) + collect (get-text-property (point) prop))) + (unless (and id part-id type) (error "No trace part at point %s" (point))) + (slime-repl-send-string + (format "%s" `(nth-value 0 + (swank-trace-dialog::find-trace-part + ,id ,part-id ,type)))) + (slime-repl)) + +(provide 'slime-trace-dialog) diff --git a/elpa/slime-20200319.1939/contrib/slime-trace-dialog.elc b/elpa/slime-20200319.1939/contrib/slime-trace-dialog.elc new file mode 100644 index 00000000..ec449ef0 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-trace-dialog.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-tramp.el b/elpa/slime-20200319.1939/contrib/slime-tramp.el new file mode 100644 index 00000000..1e3f14cb --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-tramp.el @@ -0,0 +1,121 @@ +(require 'slime) +(require 'tramp) +(eval-when-compile (require 'cl)) ; lexical-let + +(define-slime-contrib slime-tramp + "Filename translations for tramp" + (:authors "Marco Baringer ") + (:license "GPL") + (:on-load + (setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename) + (setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename))) + +(defcustom slime-filename-translations nil + "Assoc list of hostnames and filename translation functions. +Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). + +HOSTNAME-REGEXP is a regexp which is applied to the connection's +slime-machine-instance. If HOSTNAME-REGEXP maches then the +corresponding TO-LISP and FROM-LISP functions will be used to +translate emacs filenames and lisp filenames. + +TO-LISP will be passed the filename of an emacs buffer and must +return a string which the underlying lisp understandas as a +pathname. FROM-LISP will be passed a pathname as returned by the +underlying lisp and must return something that emacs will +understand as a filename (this string will be passed to +find-file). + +This list will be traversed in order, so multiple matching +regexps are possible. + +Example: + +Assuming you run emacs locally and connect to slime running on +the machine 'soren' and you can connect with the username +'animaliter': + + (push (list \"^soren$\" + (lambda (emacs-filename) + (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) + (lambda (lisp-filename) + (concat \"/ssh:animaliter@soren:\" lisp-filename))) + slime-filename-translations) + +See also `slime-create-filename-translator'." + :type '(repeat (list :tag "Host description" + (regexp :tag "Hostname regexp") + (function :tag "To lisp function") + (function :tag "From lisp function"))) + :group 'slime-lisp) + +(defun slime-find-filename-translators (hostname) + (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname)) + slime-filename-translations))) + (t (list #'identity #'identity)))) + +(defun slime-make-tramp-file-name (username remote-host lisp-filename) + "Tramp compatability function. + +Handles the signature of `tramp-make-tramp-file-name' changing +over time." + (cond + ((>= emacs-major-version 26) + ;; Emacs 26 requires the method to be provided and the signature of + ;; `tramp-make-tramp-file-name' has changed. + (tramp-make-tramp-file-name (tramp-find-method nil username remote-host) + username + nil + remote-host + nil + lisp-filename)) + ((boundp 'tramp-multi-methods) + (tramp-make-tramp-file-name nil nil + username + remote-host + lisp-filename)) + (t + (tramp-make-tramp-file-name nil + username + remote-host + lisp-filename)))) + +(cl-defun slime-create-filename-translator (&key machine-instance + remote-host + username) + "Creates a three element list suitable for push'ing onto +slime-filename-translations which uses Tramp to load files on +hostname using username. MACHINE-INSTANCE is a required +parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME +defaults to (user-login-name). + +MACHINE-INSTANCE is the value returned by slime-machine-instance, +which is just the value returned by cl:machine-instance on the +remote lisp. REMOTE-HOST is the fully qualified domain name (or +just the IP) of the remote machine. USERNAME is the username we +should login with. +The functions created here expect your tramp-default-method or + tramp-default-method-alist to be setup correctly." + (lexical-let ((remote-host (or remote-host machine-instance)) + (username (or username (user-login-name)))) + (list (concat "^" machine-instance "$") + (lambda (emacs-filename) + (tramp-file-name-localname + (tramp-dissect-file-name emacs-filename))) + `(lambda (lisp-filename) + (slime-make-tramp-file-name + ,username + ,remote-host + lisp-filename))))) + +(defun slime-tramp-to-lisp-filename (filename) + (funcall (if (slime-connected-p) + (first (slime-find-filename-translators (slime-machine-instance))) + 'identity) + (expand-file-name filename))) + +(defun slime-tramp-from-lisp-filename (filename) + (funcall (second (slime-find-filename-translators (slime-machine-instance))) + filename)) + +(provide 'slime-tramp) diff --git a/elpa/slime-20200319.1939/contrib/slime-tramp.elc b/elpa/slime-20200319.1939/contrib/slime-tramp.elc new file mode 100644 index 00000000..0140decf Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-tramp.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-typeout-frame.el b/elpa/slime-20200319.1939/contrib/slime-typeout-frame.el new file mode 100644 index 00000000..7979b195 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-typeout-frame.el @@ -0,0 +1,92 @@ +(require 'slime) +(require 'slime-autodoc) +(require 'cl-lib) + +(defvar slime-typeout-frame-unbind-stack ()) + +(define-slime-contrib slime-typeout-frame + "Display messages in a dedicated frame." + (:authors "Luke Gorrie ") + (:license "GPL") + (:on-load + (unless (slime-typeout-tty-only-p) + (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (add-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) + (cl-loop for (var value) in + '((slime-message-function slime-typeout-message) + (slime-background-message-function slime-typeout-message)) + do (slime-typeout-frame-init-var var value)))) + (:on-unload + (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (remove-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) + (cl-loop for (var value) in slime-typeout-frame-unbind-stack + do (cond ((eq var 'slime-unbound) (makunbound var)) + (t (set var value)))) + (setq slime-typeout-frame-unbind-stack nil))) + +(defun slime-typeout-frame-init-var (var value) + (push (list var (if (boundp var) (symbol-value var) 'slime-unbound)) + slime-typeout-frame-unbind-stack) + (set var value)) + +(defun slime-typeout-tty-only-p () + (cond ((featurep 'xemacs) + (null (remove 'tty (mapcar #'device-type (console-device-list))))) + (t (not (window-system))))) + + +;;;; Typeout frame + +;; When a "typeout frame" exists it is used to display certain +;; messages instead of the echo area or pop-up windows. + +(defvar slime-typeout-window nil + "The current typeout window.") + +(defvar slime-typeout-frame-properties + '((height . 10) (minibuffer . nil)) + "The typeout frame properties (passed to `make-frame').") + +(defun slime-typeout-buffer () + (with-current-buffer (get-buffer-create (slime-buffer-name :typeout)) + (setq buffer-read-only t) + (current-buffer))) + +(defun slime-typeout-active-p () + (and slime-typeout-window + (window-live-p slime-typeout-window))) + +(defun slime-typeout-message-aux (format-string &rest format-args) + (slime-ensure-typeout-frame) + (with-current-buffer (slime-typeout-buffer) + (let ((inhibit-read-only t) + (msg (apply #'format format-string format-args))) + (unless (string= msg "") + (erase-buffer) + (insert msg))))) + +(defun slime-typeout-message (format-string &rest format-args) + (apply #'slime-typeout-message-aux format-string format-args)) + +(defun slime-make-typeout-frame () + "Create a frame for displaying messages (e.g. arglists)." + (interactive) + (let ((frame (make-frame slime-typeout-frame-properties))) + (save-selected-window + (select-window (frame-selected-window frame)) + (switch-to-buffer (slime-typeout-buffer)) + (setq slime-typeout-window (selected-window))))) + +(defun slime-ensure-typeout-frame () + "Create the typeout frame unless it already exists." + (interactive) + (if (slime-typeout-active-p) + (save-selected-window + (select-window slime-typeout-window) + (switch-to-buffer (slime-typeout-buffer))) + (slime-make-typeout-frame))) + +(defun slime-typeout-wrap-autodoc () + (setq eldoc-message-function 'slime-typeout-message-aux)) + +(provide 'slime-typeout-frame) diff --git a/elpa/slime-20200319.1939/contrib/slime-typeout-frame.elc b/elpa/slime-20200319.1939/contrib/slime-typeout-frame.elc new file mode 100644 index 00000000..1f943b53 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-typeout-frame.elc differ diff --git a/elpa/slime-20200319.1939/contrib/slime-xref-browser.el b/elpa/slime-20200319.1939/contrib/slime-xref-browser.el new file mode 100644 index 00000000..45a7ad83 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/slime-xref-browser.el @@ -0,0 +1,99 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-xref-browser + "Xref browsing with tree-widget" + (:authors "Rui Patrocnio ") + (:license "GPL")) + + +;;;; classes browser + +(defun slime-expand-class-node (widget) + (or (widget-get widget :args) + (let ((name (widget-get widget :tag))) + (cl-loop for kid in (slime-eval `(swank:mop :subclasses ,name)) + collect `(tree-widget :tag ,kid + :expander slime-expand-class-node + :has-children t))))) + +(defun slime-browse-classes (name) + "Read the name of a class and show its subclasses." + (interactive (list (slime-read-symbol-name "Class Name: "))) + (slime-call-with-browser-setup + (slime-buffer-name :browser) (slime-current-package) "Class Browser" + (lambda () + (widget-create 'tree-widget :tag name + :expander 'slime-expand-class-node + :has-echildren t)))) + +(defvar slime-browser-map nil + "Keymap for tree widget browsers") + +(require 'tree-widget) +(unless slime-browser-map + (setq slime-browser-map (make-sparse-keymap)) + (set-keymap-parent slime-browser-map widget-keymap) + (define-key slime-browser-map "q" 'bury-buffer)) + +(defun slime-call-with-browser-setup (buffer package title fn) + (switch-to-buffer buffer) + (kill-all-local-variables) + (setq slime-buffer-package package) + (let ((inhibit-read-only t)) (erase-buffer)) + (widget-insert title "\n\n") + (save-excursion + (funcall fn)) + (lisp-mode-variables t) + (slime-mode t) + (use-local-map slime-browser-map) + (widget-setup)) + + +;;;; Xref browser + +(defun slime-fetch-browsable-xrefs (type name) + "Return a list ((LABEL DSPEC)). +LABEL is just a string for display purposes. +DSPEC can be used to expand the node." + (let ((xrefs '())) + (cl-loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do + (cl-loop for (dspec . _location) in specs do + (let ((exp (ignore-errors (read (downcase dspec))))) + (cond ((and (consp exp) (eq 'flet (car exp))) + ;; we can't expand FLET references so they're useless + ) + ((and (consp exp) (eq 'method (car exp))) + ;; this isn't quite right, but good enough for now + (push (list dspec (string (cl-second exp))) xrefs)) + (t + (push (list dspec dspec) xrefs)))))) + xrefs)) + +(defun slime-expand-xrefs (widget) + (or (widget-get widget :args) + (let* ((type (widget-get widget :xref-type)) + (dspec (widget-get widget :xref-dspec)) + (xrefs (slime-fetch-browsable-xrefs type dspec))) + (cl-loop for (label dspec) in xrefs + collect `(tree-widget :tag ,label + :xref-type ,type + :xref-dspec ,dspec + :expander slime-expand-xrefs + :has-children t))))) + +(defun slime-browse-xrefs (name type) + "Show the xref graph of a function in a tree widget." + (interactive + (list (slime-read-from-minibuffer "Name: " + (slime-symbol-at-point)) + (read (completing-read "Type: " (slime-bogus-completion-alist + '(":callers" ":callees" ":calls")) + nil t ":")))) + (slime-call-with-browser-setup + (slime-buffer-name :xref) (slime-current-package) "Xref Browser" + (lambda () + (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name + :expander 'slime-expand-xrefs :has-echildren t)))) + +(provide 'slime-xref-browser) diff --git a/elpa/slime-20200319.1939/contrib/slime-xref-browser.elc b/elpa/slime-20200319.1939/contrib/slime-xref-browser.elc new file mode 100644 index 00000000..7337a5d4 Binary files /dev/null and b/elpa/slime-20200319.1939/contrib/slime-xref-browser.elc differ diff --git a/elpa/slime-20200319.1939/contrib/swank-arglists.lisp b/elpa/slime-20200319.1939/contrib/swank-arglists.lisp new file mode 100644 index 00000000..d70993a5 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-arglists.lisp @@ -0,0 +1,1618 @@ +;;; swank-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +;;;; Utilities + +(defun compose (&rest functions) + "Compose FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (reduce #'funcall functions :initial-value x :from-end t))) + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(declaim (inline memq)) +(defun memq (item list) + (member item list :test #'eq)) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (member symbol '(declare declaim)))) + +(defun function-exists-p (form) + (and (valid-function-name-p form) + (fboundp form) + t)) + +(defmacro multiple-value-or (&rest forms) + (if (null forms) + nil + (let ((first (first forms)) + (rest (rest forms))) + `(let* ((values (multiple-value-list ,first)) + (primary-value (first values))) + (if primary-value + (values-list values) + (multiple-value-or ,@rest)))))) + +(defun arglist-available-p (arglist) + (not (eql arglist :not-available))) + +(defmacro with-available-arglist ((var &rest more-vars) form &body body) + `(multiple-value-bind (,var ,@more-vars) ,form + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + + +;;;; Arglist Definition + +(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) + provided-args ; list of the provided actual arguments + required-args ; list of the required arguments + optional-args ; list of the optional arguments + key-p ; whether &key appeared + keyword-args ; list of the keywords + rest ; name of the &rest or &body argument (if any) + body-p ; whether the rest argument is a &body + allow-other-keys-p ; whether &allow-other-keys appeared + aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +;; This is a wrapper object around anything that came from Slime and +;; could not reliably be read. +(defstruct (arglist-dummy + (:conc-name #:arglist-dummy.) + (:constructor make-arglist-dummy (string-representation))) + string-representation) + +(defun empty-arg-p (dummy) + (and (arglist-dummy-p dummy) + (zerop (length (arglist-dummy.string-representation dummy))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +lambda-list-keywords+ + '(&provided &required &optional &rest &key &any))) + +(defmacro do-decoded-arglist (decoded-arglist &body clauses) + (assert (loop for clause in clauses + thereis (member (car clause) +lambda-list-keywords+))) + (flet ((parse-clauses (clauses) + (let* ((size (length +lambda-list-keywords+)) + (initial (make-hash-table :test #'eq :size size)) + (main (make-hash-table :test #'eq :size size)) + (final (make-hash-table :test #'eq :size size))) + (loop for clause in clauses + for lambda-list-keyword = (first clause) + for clause-parameter = (second clause) + do + (case clause-parameter + (:initially + (setf (gethash lambda-list-keyword initial) clause)) + (:finally + (setf (gethash lambda-list-keyword final) clause)) + (t + (setf (gethash lambda-list-keyword main) clause))) + finally + (return (values initial main final))))) + (generate-main-clause (clause arglist) + (dcase clause + ((&provided (&optional arg) . body) + (let ((gensym (gensym "PROVIDED-ARG+"))) + `(dolist (,gensym (arglist.provided-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&required (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.required-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&optional (&optional arg init) . body) + (let ((optarg (gensym "OPTIONAL-ARG+"))) + `(dolist (,optarg (arglist.optional-args ,arglist)) + (declare (ignorable ,optarg)) + (let (,@(when arg + `((,arg (optional-arg.arg-name ,optarg)))) + ,@(when init + `((,init (optional-arg.default-arg ,optarg))))) + ,@body)))) + ((&key (&optional keyword arg init) . body) + (let ((keyarg (gensym "KEY-ARG+"))) + `(dolist (,keyarg (arglist.keyword-args ,arglist)) + (declare (ignorable ,keyarg)) + (let (,@(when keyword + `((,keyword (keyword-arg.keyword ,keyarg)))) + ,@(when arg + `((,arg (keyword-arg.arg-name ,keyarg)))) + ,@(when init + `((,init (keyword-arg.default-arg ,keyarg))))) + ,@body)))) + ((&rest (&optional arg body-p) . body) + `(when (arglist.rest ,arglist) + (let (,@(when arg `((,arg (arglist.rest ,arglist)))) + ,@(when body-p `((,body-p (arglist.body-p ,arglist))))) + ,@body))) + ((&any (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.any-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body))))))) + (let ((arglist (gensym "DECODED-ARGLIST+"))) + (multiple-value-bind (initially-clauses main-clauses finally-clauses) + (parse-clauses clauses) + `(let ((,arglist ,decoded-arglist)) + (block do-decoded-arglist + ,@(loop for keyword in '(&provided &required + &optional &rest &key &any) + append (cddr (gethash keyword initially-clauses)) + collect (let ((clause (gethash keyword main-clauses))) + (when clause + (generate-main-clause clause arglist))) + append (cddr (gethash keyword finally-clauses))))))))) + +;;;; Arglist Printing + +(defun undummy (x) + (if (typep x 'arglist-dummy) + (arglist-dummy.string-representation x) + (prin1-to-string x))) + +(defun print-decoded-arglist (arglist &key operator provided-args highlight) + (let ((first-space-after-operator (and operator t))) + (macrolet ((space () + ;; Kludge: When OPERATOR is not given, we don't want to + ;; print a space for the first argument. + `(if (not operator) + (setq operator t) + (progn (write-char #\space) + (if first-space-after-operator + (setq first-space-after-operator nil) + (pprint-newline :fill))))) + (with-highlighting ((&key index) &body body) + `(if (eql ,index (car highlight)) + (progn (princ "===> ") ,@body (princ " <===")) + (progn ,@body))) + (print-arglist-recursively (argl &key index) + `(if (eql ,index (car highlight)) + (print-decoded-arglist ,argl :highlight (cdr highlight)) + (print-decoded-arglist ,argl)))) + (let ((index 0)) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (when operator + (print-arg operator) + (pprint-indent :current 1)) ; 1 due to possibly added space + (do-decoded-arglist (remove-given-args arglist provided-args) + (&provided (arg) + (space) + (print-arg arg :literal-strings t) + (incf index)) + (&required (arg) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (print-arg arg))) + (incf index)) + (&optional :initially + (when (arglist.optional-args arglist) + (space) + (princ '&optional))) + (&optional (arg init-value) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (if (null init-value) + (print-arg arg) + (format t "~:@<~A ~A~@:>" + (undummy arg) (undummy init-value))))) + (incf index)) + (&key :initially + (when (arglist.key-p arglist) + (space) + (princ '&key))) + (&key (keyword arg init) + (space) + (if (arglist-p arg) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (prin1 keyword) (space) + (print-arglist-recursively arg :index keyword)) + (with-highlighting (:index keyword) + (cond ((and init (keywordp keyword)) + (format t "~:@<~A ~A~@:>" keyword (undummy init))) + (init + (format t "~:@<(~A ..) ~A~@:>" + (undummy keyword) (undummy init))) + ((not (keywordp keyword)) + (format t "~:@<(~S ..)~@:>" keyword)) + (t + (princ keyword)))))) + (&key :finally + (when (arglist.allow-other-keys-p arglist) + (space) + (princ '&allow-other-keys))) + (&any :initially + (when (arglist.any-p arglist) + (space) + (princ '&any))) + (&any (arg) + (space) + (print-arg arg)) + (&rest (args bodyp) + (space) + (princ (if bodyp '&body '&rest)) + (space) + (if (arglist-p args) + (print-arglist-recursively args :index index) + (with-highlighting (:index index) + (print-arg args)))) + ;; FIXME: add &UNKNOWN-JUNK? + )))))) + +(defun print-arg (arg &key literal-strings) + (let ((arg (if (arglist-dummy-p arg) + (arglist-dummy.string-representation arg) + arg))) + (if (or + (and literal-strings + (stringp arg)) + (keywordp arg)) + (prin1 arg) + (princ arg)))) + +(defun print-decoded-arglist-as-template (decoded-arglist &key + (prefix "(") (suffix ")")) + (let ((first-p t)) + (flet ((space () + (unless first-p + (write-char #\space)) + (setq first-p nil)) + (print-arg-or-pattern (arg) + (etypecase arg + (symbol (if (keywordp arg) (prin1 arg) (princ arg))) + (string (princ arg)) + (list (princ arg)) + (arglist-dummy (princ + (arglist-dummy.string-representation arg))) + (arglist (print-decoded-arglist-as-template arg))) + (pprint-newline :fill))) + (pprint-logical-block (nil nil :prefix prefix :suffix suffix) + (do-decoded-arglist decoded-arglist + (&provided ()) ; do nothing; provided args are in the buffer already. + (&required (arg) + (space) (print-arg-or-pattern arg)) + (&optional (arg) + (space) (princ "[") (print-arg-or-pattern arg) (princ "]")) + (&key (keyword arg) + (space) + (prin1 (if (keywordp keyword) keyword `',keyword)) + (space) + (print-arg-or-pattern arg) + (pprint-newline :linear)) + (&any (arg) + (space) (print-arg-or-pattern arg)) + (&rest (args) + (when (or (not (arglist.keyword-args decoded-arglist)) + (arglist.allow-other-keys-p decoded-arglist)) + (space) + (format t "~A..." args)))))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) + +(defvar *arglist-show-packages* t) + +(defmacro with-arglist-io-syntax (&body body) + (let ((package (gensym))) + `(let ((,package *package*)) + (with-standard-io-syntax + (let ((*package* (if *arglist-show-packages* + *package* + ,package))) + (with-bindings *arglist-pprint-bindings* + ,@body)))))) + +(defun decoded-arglist-to-string (decoded-arglist + &key operator highlight + print-right-margin) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (let ((*print-right-margin* print-right-margin)) + (print-decoded-arglist decoded-arglist + :operator operator + :highlight highlight))))) + +(defun decoded-arglist-to-template-string (decoded-arglist + &key (prefix "(") (suffix ")")) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix)))) + +;;;; Arglist Decoding / Encoding + +(defun decode-required-arg (arg) + "ARG can be a symbol or a destructuring pattern." + (etypecase arg + (symbol arg) + (arglist-dummy arg) + (list (decode-arglist arg)))) + +(defun encode-required-arg (arg) + (etypecase arg + (symbol arg) + (arglist (encode-arglist arg)))) + +(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor %make-keyword-arg)) + keyword + arg-name + default-arg) + +(defun canonicalize-default-arg (form) + (if (equalp ''nil form) + nil + form)) + +(defun make-keyword-arg (keyword arg-name default-arg) + (%make-keyword-arg :keyword keyword + :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (flet ((intern-as-keyword (arg) + (intern (etypecase arg + (symbol (symbol-name arg)) + (arglist-dummy (arglist-dummy.string-representation arg))) + keyword-package))) + (cond ((or (symbolp arg) (arglist-dummy-p arg)) + (make-keyword-arg (intern-as-keyword arg) arg nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar arg) + (decode-required-arg (cadar arg)) + (cadr arg))) + ((consp arg) + (make-keyword-arg (intern-as-keyword (car arg)) + (car arg) (cadr arg))) + (t + (error "Bad keyword item of formal argument list"))))) + +(defun encode-keyword-arg (arg) + (cond + ((arglist-p (keyword-arg.arg-name arg)) + ;; Destructuring pattern + (let ((keyword/name (list (keyword-arg.keyword arg) + (encode-required-arg + (keyword-arg.arg-name arg))))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))) + ((eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg))) + (t + (let ((keyword/name (list (keyword-arg.keyword arg) + (keyword-arg.arg-name arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))) + +(progn + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +;;; FIXME suppliedp? +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor %make-optional-arg)) + arg-name + default-arg) + +(defun make-optional-arg (arg-name default-arg) + (%make-optional-arg :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (arglist-dummy (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (or (optional-arg.default-arg optional-arg) + (arglist-p (optional-arg.arg-name optional-arg))) + (list (encode-required-arg + (optional-arg.arg-name optional-arg)) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (if (eq arglist :not-available) + :not-available + (loop + with mode = nil + with result = (make-arglist) + for arg = (if (consp arglist) + (pop arglist) + (progn + (prog1 arglist + (setf mode '&rest + arglist nil)))) + do (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((memq arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((memq arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&any))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((memq arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result)))))) + until (null arglist) + finally (nreversef (arglist.required-args result)) + finally (nreversef (arglist.optional-args result)) + finally (nreversef (arglist.keyword-args result)) + finally (nreversef (arglist.aux-args result)) + finally (nreversef (arglist.any-args result)) + finally (nreversef (arglist.known-junk result)) + finally (nreversef (arglist.unknown-junk result)) + finally (assert (or (and (not (arglist.key-p result)) + (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) + (arglist.any-p result)))) + finally (return result)))) + +(defun encode-arglist (decoded-arglist) + (append (mapcar #'encode-required-arg + (arglist.required-args decoded-arglist)) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg + (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg + (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))) + (when (arglist.aux-args decoded-arglist) + `(&aux ,(arglist.aux-args decoded-arglist))) + (arglist.known-junk decoded-arglist) + (arglist.unknown-junk decoded-arglist))) + +;;;; Arglist Enrichment + +(defun arglist-keywords (lambda-list) + "Return the list of keywords in ARGLIST. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist lambda-list))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (swank-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (swank-mop:generic-function-methods generic-function))) + +(defun applicable-methods-keywords (generic-function arguments) + "Collect all keywords in the methods of GENERIC-FUNCTION that are +applicable for argument of CLASSES. As a secondary value, return +whether &allow-other-keys appears somewhere." + (methods-keywords + (multiple-value-bind (amuc okp) + (swank-mop:compute-applicable-methods-using-classes + generic-function (mapcar #'class-of arguments)) + (if okp + amuc + (compute-applicable-methods generic-function arguments))))) + +(defgeneric extra-keywords (operator args) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. +As a secondary value, return whether other keys are allowed. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +;;; We make sure that symbol-from-KEYWORD-using keywords come before +;;; symbol-from-arbitrary-package-using keywords. And we sort the +;;; latter according to how their home-packages relate to *PACKAGE*. +;;; +;;; Rationale is to show those key parameters first which make most +;;; sense in the current context. And in particular: to put +;;; implementation-internal stuff last. +;;; +;;; This matters tremendeously on Allegro in combination with +;;; AllegroCache as that does some evil tinkering with initargs, +;;; obfuscating the arglist of MAKE-INSTANCE. +;;; + +(defmethod extra-keywords :around (op args) + (declare (ignorable op args)) + (multiple-value-bind (keywords aok enrichments) (call-next-method) + (values (sort-extra-keywords keywords) aok enrichments))) + +(defun make-package-comparator (reference-packages) + "Returns a two-argument test function which compares packages +according to their used-by relation with REFERENCE-PACKAGES. Packages +will be sorted first which appear first in the PACKAGE-USE-LIST of the +reference packages." + (let ((package-use-table (make-hash-table :test 'eq))) + ;; Walk the package dependency graph breadth-fist, and fill + ;; PACKAGE-USE-TABLE accordingly. + (loop with queue = (copy-list reference-packages) + with bfn = 0 ; Breadth-First Number + for p = (pop queue) + unless (gethash p package-use-table) + do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn))) + and do (setf queue (nconc queue (copy-list (package-use-list p)))) + while queue) + #'(lambda (p1 p2) + (let ((bfn1 (gethash p1 package-use-table)) + (bfn2 (gethash p2 package-use-table))) + (cond ((and bfn1 bfn2) (<= bfn1 bfn2)) + (bfn1 bfn1) + (bfn2 nil) ; p2 is used, p1 not + (t (string<= (package-name p1) (package-name p2)))))))) + +(defun sort-extra-keywords (kwds) + (stable-sort kwds (make-package-comparator (list keyword-package *package*)) + :key (compose #'symbol-package #'keyword-arg.keyword))) + +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (with-available-arglist (arglist) (arglist-from-form (ensure-list operator)) + (values (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist)))) + +(defmethod extra-keywords (operator args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (generic-function-keywords symbol-function) + nil))) + +(defun class-from-class-name-form (class-name-form) + (when (and (listp class-name-form) + (= (length class-name-form) 2) + (eq (car class-name-form) 'quote)) + (let* ((class-name (cadr class-name-form)) + (class (find-class class-name nil))) + (when (and class + (not (swank-mop:class-finalized-p class))) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (ignore-errors (swank-mop:finalize-inheritance class))) + class))) + +(defun extra-keywords/slots (class) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + (swank-mop:slot-definition-name slot) + (and (swank-mop:slot-definition-initfunction slot) + (swank-mop:slot-definition-initform slot)))) + (swank-mop:slot-definition-initargs slot))))) + (values slot-init-keywords allow-other-keys-p)))) + +(defun extra-keywords/make-instance (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (multiple-value-bind (allocate-instance-keywords ai-aokp) + (applicable-methods-keywords + #'allocate-instance (list class)) + (multiple-value-bind (initialize-instance-keywords ii-aokp) + (ignore-errors + (applicable-methods-keywords + #'initialize-instance + (list (swank-mop:class-prototype class)))) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + (values (append slot-init-keywords + allocate-instance-keywords + initialize-instance-keywords + shared-initialize-keywords) + (or class-aokp ai-aokp ii-aokp si-aokp) + (list class-name-form)))))))))) + +(defun extra-keywords/change-class (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (declare (ignore class-aokp)) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + ;; FIXME: much as it would be nice to include the + ;; applicable keywords from + ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see + ;; how to do it: so we punt, always declaring + ;; &ALLOW-OTHER-KEYS. + (declare (ignore si-aokp)) + (values (append slot-init-keywords shared-initialize-keywords) + t + (list class-name-form)))))))) + +(defmethod extra-keywords ((operator (eql 'make-instance)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'make-condition)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'error)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'signal)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'warn)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'cerror)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/make-instance operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator (eql 'change-class)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/change-class operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords + allow-other-keys-p) + "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P." + (when keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) + allow-other-keys-p))) + +(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + "Determine extra keywords from the function call FORM, and modify +DECODED-ARGLIST to include them. As a secondary return value, return +the initial sublist of ARGS that was needed to determine the extra +keywords. As a tertiary return value, return whether any enrichment +was done." + (multiple-value-bind (extra-keywords extra-aok determining-args) + (extra-keywords (car form) (cdr form)) + ;; enrich the list of keywords with the extra keywords + (enrich-decoded-arglist-with-keywords decoded-arglist + extra-keywords extra-aok) + (values decoded-arglist + determining-args + (or extra-keywords extra-aok)))) + +(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms) + (:documentation + "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and +ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords. +If the arglist is not available, return :NOT-AVAILABLE.")) + +(defmethod compute-enriched-decoded-arglist (operator-form argument-forms) + (with-available-arglist (decoded-arglist) + (decode-arglist (arglist operator-form)) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (cons operator-form + argument-forms)))) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'with-open-file)) argument-forms) + (declare (ignore argument-forms)) + (multiple-value-bind (decoded-arglist determining-args) + (call-next-method) + (let ((first-arg (first (arglist.required-args decoded-arglist))) + (open-arglist (compute-enriched-decoded-arglist 'open nil))) + (when (and (arglist-p first-arg) (arglist-p open-arglist)) + (enrich-decoded-arglist-with-keywords + first-arg + (arglist.keyword-args open-arglist) + nil))) + (values decoded-arglist determining-args t))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (length= function-name-form 2) + (memq (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values + (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'multiple-value-call)) argument-forms) + (compute-enriched-decoded-arglist 'apply argument-forms)) + +(defun delete-given-args (decoded-arglist args) + "Delete given ARGS from DECODED-ARGLIST." + (macrolet ((pop-or-return (list) + `(if (null ,list) + (return-from do-decoded-arglist) + (pop ,list)))) + (do-decoded-arglist decoded-arglist + (&provided () + (assert (eq (pop-or-return args) + (pop (arglist.provided-args decoded-arglist))))) + (&required () + (pop-or-return args) + (pop (arglist.required-args decoded-arglist))) + (&optional () + (pop-or-return args) + (pop (arglist.optional-args decoded-arglist))) + (&key (keyword) + ;; N.b. we consider a keyword to be given only when the keyword + ;; _and_ a value has been given for it. + (loop for (key value) on args by #'cddr + when (and (eq keyword key) value) + do (setf (arglist.keyword-args decoded-arglist) + (remove keyword (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword)))))) + decoded-arglist) + +(defun remove-given-args (decoded-arglist args) + ;; FIXME: We actually needa deep copy here. + (delete-given-args (copy-arglist decoded-arglist) args)) + +;;;; Arglist Retrieval + +(defun arglist-from-form (form) + (if (null form) + :not-available + (arglist-dispatch (car form) (cdr form)))) + +(export 'arglist-dispatch) +(defgeneric arglist-dispatch (operator arguments) + ;; Default method + (:method (operator arguments) + (unless (and (symbolp operator) (valid-operator-symbol-p operator)) + (return-from arglist-dispatch :not-available)) + (when (equalp (package-name (symbol-package operator)) "closer-mop") + (let ((standard-symbol (or (find-symbol (symbol-name operator) :cl) + (find-symbol (symbol-name operator) :swank-mop)))) + (when standard-symbol + (return-from arglist-dispatch + (arglist-dispatch standard-symbol arguments))))) + + (multiple-value-bind (decoded-arglist determining-args) + (compute-enriched-decoded-arglist operator arguments) + (with-available-arglist (arglist) decoded-arglist + ;; replace some formal args by determining actual args + (setf arglist (delete-given-args arglist determining-args)) + (setf (arglist.provided-args arglist) determining-args) + arglist)))) + +(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments) + (match (cons operator arguments) + (('defmethod (#'function-exists-p gf-name) . rest) + (let ((gf (fdefinition gf-name))) + (when (typep gf 'generic-function) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (let ((qualifiers (loop for x in rest + until (or (listp x) (empty-arg-p x)) + collect x))) + (return-from arglist-dispatch + (make-arglist :provided-args (cons gf-name qualifiers) + :required-args (list arglist) + :rest "body" :body-p t))))))) + (_)) ; Fall through + (call-next-method)) + +(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments) + (match (cons operator arguments) + (('define-compiler-macro (#'function-exists-p gf-name) . _) + (let ((gf (fdefinition gf-name))) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (return-from arglist-dispatch + (make-arglist :provided-args (list gf-name) + :required-args (list arglist) + :rest "body" :body-p t))))) + (_)) ; Fall through + (call-next-method)) + + +(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments) + (declare (ignore arguments)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist + :required-args (list (make-arglist :any-p t :any-args eval-when-args)) + :rest '#:body :body-p t))) + + +(defmethod arglist-dispatch ((operator (eql 'declare)) arguments) + (let* ((declaration (cons operator (last arguments))) + (typedecl-arglist (arglist-for-type-declaration declaration))) + (if (arglist-available-p typedecl-arglist) + typedecl-arglist + (match declaration + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (('declare (decl-identifier . decl-args)) + (decoded-arglist-for-declaration decl-identifier decl-args)) + (_ (make-arglist :rest '#:declaration-specifiers)))))) + +(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments) + (arglist-dispatch 'declare arguments)) + + +(defun arglist-for-type-declaration (declaration) + (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :provided-args (list identifier) + :required-args (list typespec-arglist) + :rest rest-var-name)))))) + (match declaration + (('declare ('type (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'type typespec '#:variables)) + (('declare ('ftype (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'ftype typespec '#:function-names)) + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (_ :not-available)))) + +(defun decoded-arglist-for-declaration (decl-identifier decl-args) + (declare (ignore decl-args)) + (with-available-arglist (arglist) + (decode-arglist (declaration-arglist decl-identifier)) + (setf (arglist.provided-args arglist) (list decl-identifier)) + (make-arglist :required-args (list arglist)))) + +(defun decoded-arglist-for-type-specifier (type-specifier) + (etypecase type-specifier + (arglist-dummy :not-available) + (cons (decoded-arglist-for-type-specifier (car type-specifier))) + (symbol + (with-available-arglist (arglist) + (decode-arglist (type-specifier-arglist type-specifier)) + (setf (arglist.provided-args arglist) (list type-specifier)) + arglist)))) + +;;; Slimefuns + +;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at +;;; user's point in Emacs. A RAW-FORM looks like +;;; +;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%)) +;;; +;;; The expression before the cursor marker is the expression where +;;; user's cursor points at. An explicit marker is necessary to +;;; disambiguate between +;;; +;;; ("IF" ("PRED") +;;; ("F" "X" "Y" %CURSOR-MARKER%)) +;;; +;;; and +;;; ("IF" ("PRED") +;;; ("F" "X" "Y") %CURSOR-MARKER%) + +;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes +;;; user's point, the following should be sent ("FOO" ("BAR" "" +;;; %CURSOR-MARKER%)). Only the forms up to point should be +;;; considered. + +(defslimefun autodoc (raw-form &key print-right-margin) + "Return a list of two elements. +First, a string representing the arglist for the deepest subform in +RAW-FORM that does have an arglist. The highlighted parameter is +wrapped in ===> X <===. + +Second, a boolean value telling whether the returned string can be cached." + (handler-bind ((serious-condition + #'(lambda (c) + (unless (debug-on-swank-error) + (let ((*print-right-margin* print-right-margin)) + (return-from autodoc + (format nil "Arglist Error: \"~A\"" c))))))) + (with-buffer-syntax () + (multiple-value-bind (form arglist obj-at-cursor form-path) + (find-subform-with-arglist (parse-raw-form raw-form)) + (cond ((boundp-and-interesting obj-at-cursor) + (list (print-variable-to-string obj-at-cursor) nil)) + (t + (list + (with-available-arglist (arglist) arglist + (decoded-arglist-to-string + arglist + :print-right-margin print-right-margin + :operator (car form) + :highlight (form-path-to-arglist-path form-path + form + arglist))) + t))))))) + +(defun boundp-and-interesting (symbol) + (and symbol + (symbolp symbol) + (boundp symbol) + (not (memq symbol '(cl:t cl:nil))) + (not (keywordp symbol)))) + +(defun print-variable-to-string (symbol) + "Return a short description of VARIABLE-NAME, or NIL." + (let ((*print-pretty* t) (*print-level* 4) + (*print-length* 10) (*print-lines* 1) + (*print-readably* nil) + (value (symbol-value symbol))) + (call/truncated-output-to-string + 75 (lambda (s) + (without-printing-errors (:object value :stream s) + (format s "~A ~A~S" symbol *echo-area-prefix* value)))))) + + +(defslimefun complete-form (raw-form) + "Read FORM-STRING in the current buffer package, then complete it + by adding a template for the missing arguments." + ;; We do not catch errors here because COMPLETE-FORM is an + ;; interactive command, not automatically run in the background like + ;; ARGLIST-FOR-ECHO-AREA. + (with-buffer-syntax () + (multiple-value-bind (arglist provided-args) + (find-immediately-containing-arglist (parse-raw-form raw-form)) + (with-available-arglist (arglist) arglist + (decoded-arglist-to-template-string + (delete-given-args arglist + (remove-if #'empty-arg-p provided-args + :from-end t :count 1)) + :prefix "" :suffix ""))))) + +(defslimefun completions-for-keyword (keyword-string raw-form) + "Return a list of possible completions for KEYWORD-STRING relative +to the context provided by RAW-FORM." + (with-buffer-syntax () + (let ((arglist (find-immediately-containing-arglist + (parse-raw-form raw-form)))) + (when (arglist-available-p arglist) + ;; It would be possible to complete keywords only if we are in + ;; a keyword position, but it is not clear if we want that. + (let* ((keywords + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-args arglist)))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list + keyword-name keywords (make-compound-prefix-matcher #\-))) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set))))))) + +(defparameter +cursor-marker+ '%cursor-marker%) + +(defun find-subform-with-arglist (form) + "Returns four values: + + The appropriate subform of `form' which is closest to the + +CURSOR-MARKER+ and whose operator is valid and has an + arglist. The +CURSOR-MARKER+ is removed from that subform. + + Second value is the arglist. Local function and macro definitions + appearing in `form' into account. + + Third value is the object in front of +CURSOR-MARKER+. + + Fourth value is a form path to that object." + (labels + ((yield-success (form local-ops) + (multiple-value-bind (form obj-at-cursor form-path) + (extract-cursor-marker form) + (values form + (let ((entry (assoc (car form) local-ops :test #'op=))) + (if entry + (decode-arglist (cdr entry)) + (arglist-from-form form))) + obj-at-cursor + form-path))) + (yield-failure () + (values nil :not-available)) + (operator-p (operator local-ops) + (or (and (symbolp operator) (valid-operator-symbol-p operator)) + (assoc operator local-ops :test #'op=))) + (op= (op1 op2) + (cond ((and (symbolp op1) (symbolp op2)) + (eq op1 op2)) + ((and (arglist-dummy-p op1) (arglist-dummy-p op2)) + (string= (arglist-dummy.string-representation op1) + (arglist-dummy.string-representation op2))))) + (grovel-form (form local-ops) + "Descend FORM top-down, always taking the rightest branch, + until +CURSOR-MARKER+." + (assert (listp form)) + (destructuring-bind (operator . args) form + ;; N.b. the user's cursor is at the rightmost, deepest + ;; subform right before +CURSOR-MARKER+. + (let ((last-subform (car (last form))) + (new-ops)) + (cond + ((eq last-subform +cursor-marker+) + (if (operator-p operator local-ops) + (yield-success form local-ops) + (yield-failure))) + ((not (operator-p operator local-ops)) + (grovel-form last-subform local-ops)) + ;; Make sure to pick up the arglists of local + ;; function/macro definitions. + ((setq new-ops (extract-local-op-arglists operator args)) + (multiple-value-or (grovel-form last-subform + (nconc new-ops local-ops)) + (yield-success form local-ops))) + ;; Some typespecs clash with function names, so we make + ;; sure to bail out early. + ((member operator '(cl:declare cl:declaim)) + (yield-success form local-ops)) + ;; Mostly uninteresting, hence skip. + ((memq operator '(cl:quote cl:function)) + (yield-failure)) + (t + (multiple-value-or (grovel-form last-subform local-ops) + (yield-success form local-ops)))))))) + (if (null form) + (yield-failure) + (grovel-form form '())))) + +(defun extract-cursor-marker (form) + "Returns three values: normalized `form' without +CURSOR-MARKER+, +the object in front of +CURSOR-MARKER+, and a form path to that +object." + (labels ((grovel (form last path) + (let ((result-form)) + (loop for (car . cdr) on form do + (cond ((eql car +cursor-marker+) + (decf (first path)) + (return-from grovel + (values (nreconc result-form cdr) + last + (nreverse path)))) + ((consp car) + (multiple-value-bind (new-car new-last new-path) + (grovel car last (cons 0 path)) + (when new-path ; CAR contained cursor-marker? + (return-from grovel + (values (nreconc + (cons new-car result-form) cdr) + new-last + new-path)))))) + (push car result-form) + (setq last car) + (incf (first path)) + finally + (return-from grovel + (values (nreverse result-form) nil nil)))))) + (grovel form nil (list 0)))) + +(defgeneric extract-local-op-arglists (operator args) + (:documentation + "If the form `(OPERATOR ,@ARGS) is a local operator binding form, + return a list of pairs (OP . ARGLIST) for each locally bound op.") + (:method (operator args) + (declare (ignore operator args)) + nil) + ;; FLET + (:method ((operator (eql 'cl:flet)) args) + (let ((defs (first args)) + (body (rest args))) + (cond ((null body) nil) ; `(flet ((foo (x) |' + ((atom defs) nil) ; `(flet ,foo (|' + (t (%collect-op/argl-alist defs))))) + ;; LABELS + (:method ((operator (eql 'cl:labels)) args) + ;; Notice that we only have information to "look backward" and + ;; show arglists of previously occuring local functions. + (destructuring-bind (defs . body) args + (unless (or (atom defs) (null body)) ; `(labels ,foo (|' + (let ((current-def (car (last defs)))) + (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|' + ((not (null body)) + (extract-local-op-arglists 'cl:flet args)) + (t + (let ((def.body (cddr current-def))) + (when def.body + (%collect-op/argl-alist defs))))))))) + ;; MACROLET + (:method ((operator (eql 'cl:macrolet)) args) + (extract-local-op-arglists 'cl:labels args))) + +(defun %collect-op/argl-alist (defs) + (setq defs (remove-if-not #'(lambda (x) + ;; Well-formed FLET/LABELS def? + (and (consp x) (second x))) + defs)) + (loop for (name arglist . nil) in defs + collect (cons name arglist))) + +(defun find-immediately-containing-arglist (form) + "Returns the arglist of the subform _immediately_ containing ++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may +be in a nested arglist \(e.g. `(WITH-OPEN-FILE ('\), and the +arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be +returned in that case." + (flet ((try (form-path form arglist) + (let* ((arglist-path (form-path-to-arglist-path form-path + form + arglist)) + (argl (apply #'arglist-ref + arglist + arglist-path)) + (args (apply #'provided-arguments-ref + (cdr form) + arglist + arglist-path))) + (when (and (arglist-p argl) (listp args)) + (values argl args))))) + (multiple-value-bind (form arglist obj form-path) + (find-subform-with-arglist form) + (declare (ignore obj)) + (with-available-arglist (arglist) arglist + ;; First try the form the cursor is in (in case of a normal + ;; form), then try the surrounding form (in case of a nested + ;; macro form). + (multiple-value-or (try form-path form arglist) + (try (butlast form-path) form arglist) + :not-available))))) + +(defun form-path-to-arglist-path (form-path form arglist) + "Convert a form path to an arglist path consisting of arglist +indices." + (labels ((convert (path args arglist) + (if (null path) + nil + (let* ((idx (car path)) + (idx* (arglist-index idx args arglist)) + (arglist* (and idx* (arglist-ref arglist idx*))) + (args* (and idx* (provided-arguments-ref args + arglist + idx*)))) + ;; The FORM-PATH may be more detailed than ARGLIST; + ;; consider (defun foo (x y) ...), a form path may + ;; point into the function's lambda-list, but the + ;; arglist of DEFUN won't contain as much information. + ;; So we only recurse if possible. + (cond ((null idx*) + nil) + ((arglist-p arglist*) + (cons idx* (convert (cdr path) args* arglist*))) + (t + (list idx*))))))) + (convert + ;; FORM contains irrelevant operator. Adjust FORM-PATH. + (cond ((null form-path) nil) + ((equal form-path '(0)) nil) + (t + (destructuring-bind (car . cdr) form-path + (cons (1- car) cdr)))) + (cdr form) + arglist))) + +(defun arglist-index (provided-argument-index provided-arguments arglist) + "Return the arglist index into `arglist' for the parameter belonging +to the argument (NTH `provided-argument-index' `provided-arguments')." + (let ((positional-args# (positional-args-number arglist)) + (arg-index provided-argument-index)) + (with-struct (arglist. key-p rest) arglist + (cond + ((< arg-index positional-args#) ; required + optional + arg-index) + ((and (not key-p) (not rest)) ; more provided than allowed + nil) + ((not key-p) ; rest + body + (assert (arglist.rest arglist)) + positional-args#) + (t ; key + ;; Find last provided &key parameter + (let* ((argument (nth arg-index provided-arguments)) + (provided-keys (subseq provided-arguments positional-args#))) + (loop for (key value) on provided-keys by #'cddr + when (eq value argument) + return (match key + (('quote symbol) symbol) + (_ key))))))))) + +(defun arglist-ref (arglist &rest indices) + "Returns the parameter in ARGLIST along the INDICIES path. Numbers +represent positional parameters (required, optional), keywords +represent key parameters." + (flet ((ref-positional-arg (arglist index) + (check-type index (integer 0 *)) + (with-struct (arglist. provided-args required-args + optional-args rest) + arglist + (loop for args in (list provided-args required-args + (mapcar #'optional-arg.arg-name + optional-args)) + for args# = (length args) + if (< index args#) + return (nth index args) + else + do (decf index args#) + finally (return (or rest nil))))) + (ref-keyword-arg (arglist keyword) + ;; keyword argument may be any symbol, + ;; not only from the KEYWORD package. + (let ((keyword (match keyword + (('quote symbol) symbol) + (_ keyword)))) + (do-decoded-arglist arglist + (&key (kw arg) (when (eq kw keyword) + (return-from ref-keyword-arg arg))))) + nil)) + (dolist (index indices) + (assert (arglist-p arglist)) + (setq arglist (if (numberp index) + (ref-positional-arg arglist index) + (ref-keyword-arg arglist index)))) + arglist)) + +(defun provided-arguments-ref (provided-args arglist &rest indices) + "Returns the argument in PROVIDED-ARGUMENT along the INDICES path +relative to ARGLIST." + (check-type arglist arglist) + (flet ((ref (provided-args arglist index) + (if (numberp index) + (nth index provided-args) + (let ((provided-keys (subseq provided-args + (positional-args-number arglist)))) + (loop for (key value) on provided-keys + when (eq key index) + return value))))) + (dolist (idx indices) + (setq provided-args (ref provided-args arglist idx)) + (setq arglist (arglist-ref arglist idx))) + provided-args)) + +(defun positional-args-number (arglist) + (+ (length (arglist.provided-args arglist)) + (length (arglist.required-args arglist)) + (length (arglist.optional-args arglist)))) + +(defun parse-raw-form (raw-form) + "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by +symbols if already interned. For strings not already interned, use +ARGLIST-DUMMY." + (unless (null raw-form) + (loop for element in raw-form + collect (etypecase element + (string (read-conversatively element)) + (list (parse-raw-form element)) + (symbol (prog1 element + ;; Comes after list, so ELEMENT can't be NIL. + (assert (eq element +cursor-marker+)))))))) + +(defun read-conversatively (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), an object of type +ARGLIST-DUMMY is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (length (length string)) + (type (cond ((zerop length) nil) + ((eql (aref string 0) #\') + :quoted-symbol) + ((search "#'" string :end2 (min length 2)) + :sharpquoted-symbol) + ((char= (char string 0) (char string (1- length)) + #\") + :string) + (t + :symbol)))) + (multiple-value-bind (symbol found?) + (case type + (:symbol (parse-symbol string)) + (:quoted-symbol (parse-symbol (subseq string 1))) + (:sharpquoted-symbol (parse-symbol (subseq string 2))) + (:string (values string t)) + (t (values string nil))) + (if found? + (ecase type + (:symbol symbol) + (:quoted-symbol `(quote ,symbol)) + (:sharpquoted-symbol `(function ,symbol)) + (:string (if (> length 1) + (subseq string 1 (1- length)) + string))) + (make-arglist-dummy string))))) + +(defun test-print-arglist () + (flet ((test (arglist &rest strings) + (let* ((*package* (find-package :swank)) + (actual (decoded-arglist-to-string + (decode-arglist arglist) + :print-right-margin 1000))) + (unless (loop for string in strings + thereis (string= actual string)) + (warn "Test failed: ~S => ~S~% Expected: ~A" + arglist actual + (if (cdr strings) + (format nil "One of: ~{~S~^, ~}" strings) + (format nil "~S" (first strings)))))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) + "(&key (function #'+))" "(&key (function (function +)))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function ..)))") + (test + '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))"))) + +(defun test-arglist-ref () + (macrolet ((soft-assert (form) + `(unless ,form + (warn "Assertion failed: ~S~%" ',form)))) + (let ((sample (decode-arglist '(x &key ((:k (y z))))))) + (soft-assert (eq (arglist-ref sample 0) 'x)) + (soft-assert (eq (arglist-ref sample :k 0) 'y)) + (soft-assert (eq (arglist-ref sample :k 1) 'z)) + + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0) + 'a)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) + 'b)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) + 'c))))) + +(test-print-arglist) +(test-arglist-ref) + +(provide :swank-arglists) diff --git a/elpa/slime-20200319.1939/contrib/swank-asdf.lisp b/elpa/slime-20200319.1939/contrib/swank-asdf.lisp new file mode 100644 index 00000000..175402d3 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-asdf.lisp @@ -0,0 +1,533 @@ +;;; swank-asdf.lisp -- ASDF support +;; +;; Authors: Daniel Barlow +;; Marco Baringer +;; Edi Weitz +;; Francois-Rene Rideau +;; and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) +;;; The best way to load ASDF is from an init file of an +;;; implementation. If ASDF is not loaded at the time swank-asdf is +;;; loaded, it will be tried first with (require "asdf"), if that +;;; doesn't help and *asdf-path* is set, it will be loaded from that +;;; file. +;;; To set *asdf-path* put the following into ~/.swank.lisp: +;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp") + (defvar *asdf-path* nil + "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (ignore-errors (funcall 'require "asdf")))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (handler-bind ((warning #'muffle-warning)) + (when *asdf-path* + (load *asdf-path* :if-does-not-exist nil))))) + +;; If still not found, error out. +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (error "Could not load ASDF. +Please update your implementation or +install a recent release of ASDF and in your ~~/.swank.lisp specify: + (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")"))) + +;;; If ASDF is too old, punt. +;; As of January 2014, Quicklisp has been providing 2.26 for a year +;; (and previously had 2.014.6 for over a year), whereas +;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later) +;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released +;; in years and doesn't provide ASDF at all, but is fully supported by ASDF). +;; If your implementation doesn't provide ASDF, or provides an old one, +;; install an upgrade yourself and configure *asdf-path*. +;; It's just not worth the hassle supporting something +;; that doesn't even have COERCE-PATHNAME. +;; +;; NB: this version check is duplicated in swank-loader.lisp so that we don't +;; try to load this contrib when ASDF is too old since that will abort the SLIME +;; connection. +#-asdf3 +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (and #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6")) + (error "Your ASDF is too old. ~ + The oldest version supported by swank-asdf is 2.014.6."))) +;;; Import functionality from ASDF that isn't available in all ASDF versions. +;;; Please do NOT depend on any of the below as reference: +;;; they are sometimes stripped down versions, for compatibility only. +;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF. +;;; +;;; The way I got these is usually by looking at the current definition, +;;; using git blame in one screen to locate which commit last modified it, +;;; and git log in another to determine which release that made it in. +;;; It is OK for some of the below definitions to be or become obsolete, +;;; as long as it will make do with versions older than the tagged version: +;;; if ASDF is more recent, its more recent version will win. +;;; +;;; If your software is hacking ASDF, use its internals. +;;; If you want ASDF utilities in user software, please use ASDF-UTILS. + +(defun asdf-at-least (version) + (asdf:version-satisfies (asdf:asdf-version) version)) + +(defmacro asdefs (version &rest defs) + (flet ((defun* (version name aname rest) + `(progn + (defun ,name ,@rest) + (declaim (notinline ,name)) + (when (asdf-at-least ,version) + (setf (fdefinition ',name) (fdefinition ',aname))))) + (defmethod* (version aname rest) + `(unless (asdf-at-least ,version) + (defmethod ,aname ,@rest))) + (defvar* (name aname rest) + `(progn + (define-symbol-macro ,name ,aname) + (defvar ,aname ,@rest)))) + `(progn + ,@(loop :for (def name . args) :in defs + :for aname = (intern (string name) :asdf) + :collect + (ecase def + ((defun) (defun* version name aname args)) + ((defmethod) (defmethod* version aname args)) + ((defvar) (defvar* name aname args))))))) + +(asdefs "2.15" + (defvar *wild* #-cormanlisp :wild #+cormanlisp "*") + + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect)))) + +(asdefs "2.16" + (defun load-sysdef (name pathname) + (declare (ignore name)) + (let ((package (asdf::make-temporary-package))) + (unwind-protect + (let ((*package* package) + (*default-pathname-defaults* + (asdf::pathname-directory-pathname + (translate-logical-pathname pathname)))) + (asdf::asdf-message + "~&; Loading system definition from ~A into ~A~%" ; + pathname package) + (load pathname)) + (delete-package package)))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys + '#.(or #+allegro + '(:directories-are-files nil + :follow-symbolic-links nil) + #+clozure + '(:follow-links nil) + #+clisp + '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) + '(:follow-links nil :truenamep nil) + #+sbcl + (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl) + '(:resolve-symlinks nil))))))) +(asdefs "2.17" + (defun collect-sub*directories-asd-files + (directory &key + (exclude asdf::*default-source-registry-exclusions*) + collect) + (asdf::collect-sub*directories + directory + (constantly t) + (lambda (x) (not (member (car (last (pathname-directory x))) + exclude :test #'equal))) + (lambda (dir) (collect-asds-in-directory dir collect)))) + + (defun system-source-directory (system-designator) + (asdf::pathname-directory-pathname + (asdf::system-source-file system-designator))) + + (defun filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + (loop for f in entries + when + (if (typep f 'logical-pathname) + f + (let ((u (ignore-errors (funcall merger f)))) + (and u + (equal (ignore-errors (truename u)) + (truename f)) + u))) + collect it) + entries)) + + (defun directory-asd-files (directory) + (directory-files directory asdf::*wild-asd*))) + +(asdefs "2.19" + (defun subdirectories (directory) + (let* ((directory (asdf::ensure-directory-pathname directory)) + #-(or abcl cormanlisp xcl) + (wild (asdf::merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + asdf::*wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro cmu lispworks sbcl scl xcl) + (dirs (loop for x in dirs + for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (asdf::directory-pathname-p x) + #+lispworks (lw:file-directory-p x) + when d collect #+(or abcl allegro xcl) d + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component + (pathname-directory directory)) + ;; because allegro 8.x returns NIL for #p"FOO:" + '(:absolute)))) + (lambda (d) + (let ((dir (normalize-pathname-directory-component + (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory + (append prefix + (make-pathname-component-logical + (last dir)))))))))))) + +(asdefs "2.21" + (defun component-loaded-p (c) + (and (gethash 'load-op (asdf::component-operation-times + (asdf::find-component c nil))) t)) + + (defun normalize-pathname-directory-component (directory) + (cond + #-(or cmu sbcl scl) + ((stringp directory) `(:absolute ,directory) directory) + ((or (null directory) + (and (consp directory) + (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized pathname directory component ~S" directory)))) + + (defun make-pathname-component-logical (x) + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname))))) + +(asdefs "2.22" + (defun directory-files (directory &optional (pattern asdf::*wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) + '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" + pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors + (directory* (asdf::merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + (lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical + (pathname-name f)) + :type (make-pathname-component-logical + (pathname-type f)) + :version (make-pathname-component-logical + (pathname-version f))))))))) + +(asdefs "2.26.149" + (defmethod component-relative-pathname ((system asdf:system)) + (asdf::coerce-pathname + (and (slot-boundp system 'asdf::relative-pathname) + (slot-value system 'asdf::relative-pathname)) + :type :directory + :defaults (system-source-directory system))) + (defun load-asd (pathname &key name &allow-other-keys) + (asdf::load-sysdef (or name (string-downcase (pathname-name pathname))) + pathname))) + + +;;; Taken from ASDF 1.628 +(defmacro while-collecting ((&rest collectors) &body body) + `(asdf::while-collecting ,collectors ,@body)) + +;;; Now for SLIME-specific stuff + +(defun asdf-operation (operation) + (or (asdf::find-symbol* operation :asdf) + (error "Couldn't find ASDF operation ~S" operation))) + +(defun map-system-components (fn system) + (map-component-subcomponents fn (asdf:find-system system))) + +(defun map-component-subcomponents (fn component) + (when component + (funcall fn component) + (when (typep component 'asdf:module) + (dolist (c (asdf:module-components component)) + (map-component-subcomponents fn c))))) + +;;; Maintaining a pathname to component table + +(defvar *pathname-component* (make-hash-table :test 'equal)) + +(defun clear-pathname-component-table () + (clrhash *pathname-component*)) + +(defun register-system-pathnames (system) + (map-system-components 'register-component-pathname system)) + +(defun recompute-pathname-component-table () + (clear-pathname-component-table) + (asdf::map-systems 'register-system-pathnames)) + +(defun pathname-component (x) + (gethash (pathname x) *pathname-component*)) + +(defmethod asdf:component-pathname :around ((component asdf:component)) + (let ((p (call-next-method))) + (when (pathnamep p) + (setf (gethash p *pathname-component*) component)) + p)) + +(defun register-component-pathname (component) + (asdf:component-pathname component)) + +(recompute-pathname-component-table) + +;;; This is a crude hack, see ASDF's LP #481187. +(defslimefun who-depends-on (system) + (flet ((system-dependencies (op system) + (mapcar (lambda (dep) + (asdf::coerce-name (if (consp dep) (second dep) dep))) + (cdr (assoc op (asdf:component-depends-on op system)))))) + (let ((system-name (asdf::coerce-name system)) + (result)) + (asdf::map-systems + (lambda (system) + (when (member system-name + (system-dependencies 'asdf:load-op system) + :test #'string=) + (push (asdf:component-name system) result)))) + result))) + +(defmethod xref-doit ((type (eql :depends-on)) thing) + (when (typep thing '(or string symbol)) + (loop for dependency in (who-depends-on thing) + for asd-file = (asdf:system-definition-pathname dependency) + when asd-file + collect (list dependency + (swank/backend:make-location + `(:file ,(namestring asd-file)) + `(:position 1) + `(:snippet ,(format nil "(defsystem :~A" dependency) + :align t)))))) + +(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (collect-notes + (lambda () + (apply #'operate-on-system system-name operation keywords)))) + +(defun operate-on-system (system-name operation-name &rest keyword-args) + "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. +The KEYWORD-ARGS are passed on to the operation. +Example: +\(operate-on-system \"cl-ppcre\" 'compile-op :force t)" + (handler-case + (with-compilation-hooks () + (apply #'asdf:operate (asdf-operation operation-name) + system-name keyword-args) + t) + ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error) + () nil))) + +(defun unique-string-list (&rest lists) + (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<)) + +(defslimefun list-all-systems-in-central-registry () + "Returns a list of all systems in ASDF's central registry +AND in its source-registry. (legacy name)" + (unique-string-list + (mapcar + #'pathname-name + (while-collecting (c) + (loop for dir in asdf:*central-registry* + for defaults = (eval dir) + when defaults + do (collect-asds-in-directory defaults #'c)) + (asdf:ensure-source-registry) + (if (or #+asdf3 t + #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15")) + (loop :for k :being :the :hash-keys :of asdf::*source-registry* + :do (c k)) + #-asdf3 + (dolist (entry (asdf::flatten-source-registry)) + (destructuring-bind (directory &key recurse exclude) entry + (register-asd-directory + directory + :recurse recurse :exclude exclude :collect #'c)))))))) + +(defslimefun list-all-systems-known-to-asdf () + "Returns a list of all systems ASDF knows already." + (while-collecting (c) + (asdf::map-systems (lambda (system) (c (asdf:component-name system)))))) + +(defslimefun list-asdf-systems () + "Returns the systems in ASDF's central registry and those which ASDF +already knows." + (unique-string-list + (list-all-systems-known-to-asdf) + (list-all-systems-in-central-registry))) + +(defun asdf-component-source-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file (c (asdf:component-pathname x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defun make-operation (x) + #+#.(swank/backend:with-symbol 'make-operation 'asdf) + (asdf:make-operation x) + #-#.(swank/backend:with-symbol 'make-operation 'asdf) + (make-instance x)) + +(defun asdf-component-output-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file + (map () #'c + (asdf:output-files (make-operation 'asdf:compile-op) x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defslimefun asdf-system-files (name) + (let* ((system (asdf:find-system name)) + (files (mapcar #'namestring + (cons + (asdf:system-definition-pathname system) + (asdf-component-source-files system)))) + (main-file (find name files + :test #'equalp :key #'pathname-name :start 1))) + (if main-file + (cons main-file (remove main-file files + :test #'equal :count 1)) + files))) + +(defslimefun asdf-system-loaded-p (name) + (component-loaded-p name)) + +(defslimefun asdf-system-directory (name) + (namestring (translate-logical-pathname (asdf:system-source-directory name)))) + +(defun pathname-system (pathname) + (let ((component (pathname-component pathname))) + (when component + (asdf:component-name (asdf:component-system component))))) + +(defslimefun asdf-determine-system (file buffer-package-name) + (or + (and file + (pathname-system file)) + (and file + (progn + ;; If not found, let's rebuild the table first + (recompute-pathname-component-table) + (pathname-system file))) + ;; If we couldn't find an already defined system, + ;; try finding a system that's named like BUFFER-PACKAGE-NAME. + (loop with package = (guess-buffer-package buffer-package-name) + for name in (package-names package) + for system = (asdf:find-system (asdf::coerce-name name) nil) + when (and system + (or (not file) + (pathname-system file))) + return (asdf:component-name system)))) + +(defslimefun delete-system-fasls (name) + (let ((removed-count + (loop for file in (asdf-component-output-files + (asdf:find-system name)) + when (probe-file file) + count it + and + do (delete-file file)))) + (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count))) + +(defvar *recompile-system* nil) + +(defmethod asdf:operation-done-p :around + ((operation asdf:compile-op) + component) + (unless (eql *recompile-system* + (asdf:component-system component)) + (call-next-method))) + +(defslimefun reload-system (name) + (let ((*recompile-system* (asdf:find-system name))) + (operate-on-system-for-emacs name 'asdf:load-op))) + +;;; Hook for compile-file-for-emacs + +(defun try-compile-file-with-asdf (pathname load-p &rest options) + (declare (ignore options)) + (let ((component (pathname-component pathname))) + (when component + ;;(format t "~&Compiling ASDF component ~S~%" component) + (let ((op (make-operation 'asdf:compile-op))) + (with-compilation-hooks () + (asdf:perform op component)) + (when load-p + (asdf:perform (make-operation 'asdf:load-op) component)) + (values t t nil (first (asdf:output-files op component))))))) + +(defun try-compile-asd-file (pathname load-p &rest options) + (declare (ignore load-p options)) + (when (equalp (pathname-type pathname) "asd") + (load-asd pathname) + (values t t nil pathname))) + +(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*) + +;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*) + +(provide :swank-asdf) diff --git a/elpa/slime-20200319.1939/contrib/swank-buffer-streams.lisp b/elpa/slime-20200319.1939/contrib/swank-buffer-streams.lisp new file mode 100644 index 00000000..4d901e24 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-buffer-streams.lisp @@ -0,0 +1,39 @@ +;;; swank-buffer-streams.lisp --- Streams that output to a buffer +;;; +;;; Authors: Ed Langley +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(defpackage :swank-buffer-streams + (:use :cl) + (:import-from :swank + defslimefun + add-hook + encode-message + send-event + find-thread + dcase + current-socket-io + send-to-emacs + current-thread-id + wait-for-event + + *emacs-connection* + *event-hook*) + (:export make-buffer-output-stream)) + +(in-package :swank-buffer-streams) + +(defun get-temporary-identifier () + (intern (symbol-name (gensym "BUFFER")) + :keyword)) + +(defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier))) + (swank:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier) + (values (swank:make-output-stream-for-target *emacs-connection* target-identifier) + target-identifier)) + +(provide :swank-buffer-streams) diff --git a/elpa/slime-20200319.1939/contrib/swank-c-p-c.lisp b/elpa/slime-20200319.1939/contrib/swank-c-p-c.lisp new file mode 100644 index 00000000..6a766fbd --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-c-p-c.lisp @@ -0,0 +1,298 @@ +;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion +;; +;; Author: Luke Gorrie +;; Edi Weitz +;; Matthias Koeppe +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is the list (COMPLETION-SET COMPLETED-PREFIX), where +COMPLETION-SET is the list of all matching completions, and +COMPLETED-PREFIX is the best (partial) completion of the input +string. + +Simple compound matching is supported on a per-hyphen basis: + + (completions \"m-v-\" \"COMMON-LISP\") + ==> ((\"multiple-value-bind\" \"multiple-value-call\" + \"multiple-value-list\" \"multiple-value-prog1\" + \"multiple-value-setq\" \"multiple-values-limit\") + \"multiple-value\") + +\(For more advanced compound matching, see FUZZY-COMPLETIONS.) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG. +" + (multiple-value-bind (name package-name package internal-p) + (parse-completion-arguments string default-package-name) + (let* ((symbol-set (symbol-completion-set + name package-name package internal-p + (make-compound-prefix-matcher #\-))) + (package-set (package-completion-set + name package-name package internal-p + (make-compound-prefix-matcher '(#\. #\-)))) + (completion-set + (format-completion-set (nconc symbol-set package-set) + internal-p package-name))) + (when completion-set + (list completion-set (longest-compound-prefix completion-set)))))) + + +;;;;; Find completion set + +(defun symbol-completion-set (name package-name package internal-p matchp) + "Return the set of completion-candidates as strings." + (mapcar (completion-output-symbol-converter name) + (and package + (mapcar #'symbol-name + (find-matching-symbols name + package + (and (not internal-p) + package-name) + matchp))))) + +(defun package-completion-set (name package-name package internal-p matchp) + (declare (ignore package internal-p)) + (mapcar (completion-output-package-converter name) + (and (not package-name) + (find-matching-packages name matchp)))) + +(defun find-matching-symbols (string package external test) + "Return a list of symbols in PACKAGE matching STRING. +TEST is called with two strings. If EXTERNAL is true, only external +symbols are returned." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (and (or (not external) + (symbol-external-p symbol package)) + (funcall test string + (funcall converter (symbol-name symbol)))))) + (do-symbols* (symbol package) + (when (symbol-matches-p symbol) + (push symbol completions)))) + completions)) + +(defun find-matching-symbols-in-list (string list test) + "Return a list of symbols in LIST matching STRING. +TEST is called with two strings." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (funcall test string + (funcall converter (symbol-name symbol))))) + (dolist (symbol list) + (when (symbol-matches-p symbol) + (push symbol completions)))) + (remove-duplicates completions))) + +(defun find-matching-packages (name matcher) + "Return a list of package names matching NAME with MATCHER. +MATCHER is a two-argument predicate." + (let ((converter (completion-output-package-converter name))) + (remove-if-not (lambda (x) + (funcall matcher name (funcall converter x))) + (mapcar (lambda (pkgname) + (concatenate 'string pkgname ":")) + (loop for package in (list-all-packages) + nconcing (package-names package)))))) + + +;; PARSE-COMPLETION-ARGUMENTS return table: +;; +;; user behaviour | NAME | PACKAGE-NAME | PACKAGE +;; ----------------+--------+--------------+----------------------------------- +;; asdf [tab] | "asdf" | NIL | # +;; | | | or *BUFFER-PACKAGE* +;; asdf: [tab] | "" | "asdf" | # +;; | | | +;; asdf:foo [tab] | "foo" | "asdf" | # +;; | | | +;; as:fo [tab] | "fo" | "as" | NIL +;; | | | +;; : [tab] | "" | "" | # +;; | | | +;; :foo [tab] | "foo" | "" | # +;; +(defun parse-completion-arguments (string default-package-name) + "Parse STRING as a symbol designator. +Return these values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is + NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; + if PACKAGE is non-NIL but a package cannot be found under that name, + return NIL.) + INTERNAL-P, if the symbol is qualified with `::'." + (multiple-value-bind (name package-name internal-p) + (tokenize-symbol string) + (flet ((default-package () + (or (guess-package default-package-name) *buffer-package*))) + (let ((package (cond + ((not package-name) + (default-package)) + ((equal package-name "") + (guess-package (symbol-name :keyword))) + ((find-locally-nicknamed-package + package-name (default-package))) + (t + (guess-package package-name))))) + (values name package-name package internal-p))))) + +(defun completion-output-case-converter (input &optional with-escaping-p) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (ecase (readtable-case *readtable*) + (:upcase (cond ((or with-escaping-p + (and (plusp (length input)) + (not (some #'lower-case-p input)))) + #'identity) + (t #'string-downcase))) + (:invert (lambda (output) + (multiple-value-bind (lower upper) (determine-case output) + (cond ((and lower upper) output) + (lower (string-upcase output)) + (upper (string-downcase output)) + (t output))))) + (:downcase (cond ((or with-escaping-p + (and (zerop (length input)) + (not (some #'upper-case-p input)))) + #'identity) + (t #'string-upcase))) + (:preserve #'identity))) + +(defun completion-output-package-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (completion-output-case-converter input)) + +(defun completion-output-symbol-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case. Escape symbols when needed." + (let ((case-converter (completion-output-case-converter input)) + (case-converter-with-escaping (completion-output-case-converter input t))) + (lambda (str) + (if (or (multiple-value-bind (lowercase uppercase) + (determine-case str) + ;; In these readtable cases, symbols with letters from + ;; the wrong case need escaping + (case (readtable-case *readtable*) + (:upcase lowercase) + (:downcase uppercase) + (t nil))) + (some (lambda (el) + (or (member el '(#\: #\Space #\Newline #\Tab)) + (multiple-value-bind (macrofun nonterminating) + (get-macro-character el) + (and macrofun + (not nonterminating))))) + str)) + (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") + (funcall case-converter str))))) + + +(defun determine-case (string) + "Return two booleans LOWER and UPPER indicating whether STRING +contains lower or upper case characters." + (values (some #'lower-case-p string) + (some #'upper-case-p string))) + + +;;;;; Compound-prefix matching + +(defun make-compound-prefix-matcher (delimiter &key (test #'char=)) + "Returns a matching function that takes a `prefix' and a +`target' string and which returns T if `prefix' is a +compound-prefix of `target', and otherwise NIL. + +Viewing each of `prefix' and `target' as a series of substrings +delimited by DELIMITER, if each substring of `prefix' is a prefix +of the corresponding substring in `target' then we call `prefix' +a compound-prefix of `target'. + +DELIMITER may be a character, or a list of characters." + (let ((delimiters (etypecase delimiter + (character (list delimiter)) + (cons (assert (every #'characterp delimiter)) + delimiter)))) + (lambda (prefix target) + (declare (type simple-string prefix target)) + (loop with tpos = 0 + for ch across prefix + always (and (< tpos (length target)) + (let ((delimiter (car (member ch delimiters :test test)))) + (if delimiter + (setf tpos (position delimiter target :start tpos)) + (funcall test ch (aref target tpos))))) + do (incf tpos))))) + + +;;;;; Extending the input string by completion + +(defun longest-compound-prefix (completions &optional (delimiter #\-)) + "Return the longest compound _prefix_ for all COMPLETIONS." + (flet ((tokenizer (string) (tokenize-completion string delimiter))) + (untokenize-completion + (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) + if (notevery #'string= token-list (rest token-list)) + ;; Note that we possibly collect the "" here as well, so that + ;; UNTOKENIZE-COMPLETION will append a delimiter for us. + collect (longest-common-prefix token-list) + and do (loop-finish) + else collect (first token-list)) + delimiter))) + +(defun tokenize-completion (string delimiter) + "Return all substrings of STRING delimited by DELIMITER." + (loop with end + for start = 0 then (1+ end) + until (> start (length string)) + do (setq end (or (position delimiter string :start start) (length string))) + collect (subseq string start end))) + +(defun untokenize-completion (tokens &optional (delimiter #\-)) + (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens)) + +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +\(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" + (cond ((null lists) '()) + ((some #'null lists) '()) + (t (cons (mapcar #'car lists) + (transpose-lists (mapcar #'cdr lists)))))) + + +;;;; Completion for character names + +(defslimefun completions-for-character (prefix) + (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) + (completion-set (character-completion-set prefix matcher)) + (completions (sort completion-set #'string<))) + (list completions (longest-compound-prefix completions #\_)))) + +(provide :swank-c-p-c) diff --git a/elpa/slime-20200319.1939/contrib/swank-clipboard.lisp b/elpa/slime-20200319.1939/contrib/swank-clipboard.lisp new file mode 100644 index 00000000..52b10858 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-clipboard.lisp @@ -0,0 +1,71 @@ +;;; swank-clipboard.lisp --- Object clipboard +;; +;; Written by Helmut Eller in 2008. +;; License: Public Domain + +(defpackage :swank-clipboard + (:use :cl) + (:import-from :swank :defslimefun :with-buffer-syntax :dcase) + (:export :add :delete-entry :entries :entry-to-ref :ref)) + +(in-package :swank-clipboard) + +(defstruct clipboard entries (counter 0)) + +(defvar *clipboard* (make-clipboard)) + +(defslimefun add (datum) + (let ((value (dcase datum + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (swank:inspector-nth-part part)) + ((:sldb frame var) + (swank/backend:frame-var-value frame var))))) + (clipboard-add value) + (format nil "Added: ~a" + (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) + +(defslimefun entries () + (loop for (ref . value) in (clipboard-entries *clipboard*) + collect `(,ref . ,(to-line value)))) + +(defslimefun delete-entry (entry) + (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) + (clipboard-delete-entry entry) + msg)) + +(defslimefun entry-to-ref (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (list ref (to-line value 5)))) + +(defun clipboard-add (value) + (setf (clipboard-entries *clipboard*) + (append (clipboard-entries *clipboard*) + (list (cons (incf (clipboard-counter *clipboard*)) + value))))) + +(defun clipboard-ref (ref) + (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) + (cond (tail (cdr (car tail))) + (t (error "Invalid clipboard ref: ~s" ref))))) + +(defun clipboard-entry (entry) + (elt (clipboard-entries *clipboard*) entry)) + +(defun clipboard-delete-entry (index) + (let* ((list (clipboard-entries *clipboard*)) + (tail (nthcdr index list))) + (setf (clipboard-entries *clipboard*) + (append (ldiff list tail) (cdr tail))))) + +(defun entry-to-string (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (format nil "#@~d(~a)" ref (to-line value)))) + +(defun to-line (object &optional (width 75)) + (with-output-to-string (*standard-output*) + (write object :right-margin width :lines 1))) + +(provide :swank-clipboard) diff --git a/elpa/slime-20200319.1939/contrib/swank-fancy-inspector.lisp b/elpa/slime-20200319.1939/contrib/swank-fancy-inspector.lisp new file mode 100644 index 00000000..c2201a81 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-fancy-inspector.lisp @@ -0,0 +1,1006 @@ +;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defmethod emacs-inspect ((symbol symbol)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (append + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol) :newline nil) + ;; unbinding constants might be not a good idea, but + ;; implementations usually provide a restart. + `(" " (:action "[unbind]" + ,(lambda () (makunbound symbol)))) + '((:newline)))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[unbind]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function documentation" symbol 'function) + (when (compiler-macro-function symbol) + (append + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol) :newline nil) + `(" " (:action "[remove]" + ,(lambda () + (setf (compiler-macro-function symbol) nil))) + (:newline)))) + (docstring-ispec "Compiler macro documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + (inspect-type-specifier symbol))))) + +#-sbcl +(defun inspect-type-specifier (symbol) + (declare (ignore symbol))) + +#+sbcl +(defun inspect-type-specifier (symbol) + (let* ((kind (sb-int:info :type :kind symbol)) + (fun (case kind + (:defined + (or (sb-int:info :type :expander symbol) t)) + (:primitive + (or #.(if (swank/sbcl::sbcl-version>= 1 3 1) + '(let ((x (sb-int:info :type :expander symbol))) + (if (consp x) + (car x) + x)) + '(sb-int:info :type :translator symbol)) + t))))) + (when fun + (append + (list + (format nil "It names a ~@[primitive~* ~]type-specifier." + (eq kind :primitive)) + '(:newline)) + (docstring-ispec "Type-specifier documentation" symbol 'type) + (unless (eq t fun) + (let ((arglist (arglist fun))) + (append + `("Type-specifier lambda-list: " + ;; Could use ~:s, but inspector-princ does a bit more, + ;; and not all NILs in the arglist should be printed that way. + ,(if arglist + (inspector-princ arglist) + "()") + (:newline)) + (multiple-value-bind (expansion ok) + (handler-case (sb-ext:typexpand-1 symbol) + (error () (values nil nil))) + (when ok + (list "Type-specifier expansion: " + (princ-to-string expansion))))))))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ":" '(:newline) " " docstring '(:newline)))))) + +(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) + (defmethod emacs-inspect ((f function)) + (inspect-function f))) + +(defun inspect-function (f) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))))) + +(defun method-specializers-for-inspect (method) + "Return a \"pretty\" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (swank-mop:eql-specializer + `(eql ,(swank-mop:eql-specializer-object spec))) + #-sbcl + (t + (swank-mop:class-name spec)) + #+sbcl + (t + ;; SBCL has extended specializers + (let ((gf (sb-mop:method-generic-function method))) + (cond (gf + (sb-pcl:unparse-specializer-using-class gf spec)) + ((typep spec 'class) + (class-name spec)) + (t + spec)))))) + (swank-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a \"pretty\" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod emacs-inspect ((object standard-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object)))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + ((typep s1 'class) + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) + #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defstruct (inspector-checklist (:conc-name checklist.) + (:constructor %make-checklist (buttons))) + (buttons nil :type (or null simple-vector)) + (count 0)) + +(defun make-checklist (n) + (%make-checklist (make-array n :initial-element nil))) + +(defun reinitialize-checklist (checklist) + ;; Along this counter the buttons are created, so we have to + ;; initialize it to 0 everytime the inspector page is redisplayed. + (setf (checklist.count checklist) 0) + checklist) + +(defun make-checklist-button (checklist) + (let ((buttons (checklist.buttons checklist)) + (i (checklist.count checklist))) + (incf (checklist.count checklist)) + `(:action ,(if (svref buttons i) + "[X]" + "[ ]") + ,#'(lambda () + (setf (svref buttons i) (not (svref buttons i)))) + :refreshp t))) + +(defmacro do-checklist ((idx checklist) &body body) + "Iterate over all set buttons in CHECKLIST." + (let ((buttons (gensym "buttons"))) + `(let ((,buttons (checklist.buttons ,checklist))) + (dotimes (,idx (length ,buttons)) + (when (svref ,buttons ,idx) + ,@body))))) + +(defun box (thing) (cons :box thing)) +(defun ref (box) + (assert (eq (car box) :box)) + (cdr box)) +(defun (setf ref) (value box) + (assert (eq (car box) :box)) + (setf (cdr box) value)) + +(defvar *inspector-slots-default-order* :alphabetically + "Accepted values: :alphabetically and :unsorted") + +(defvar *inspector-slots-default-grouping* :all + "Accepted values: :inheritance and :all") + +(defgeneric all-slots-for-inspector (object)) + +(defmethod all-slots-for-inspector ((object standard-object)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (swank-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'swank-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (swank-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) + +(defun list-all-slots-by-inheritance (checklist object class effective-slots + direct-slots longest-slot-name-length) + (flet ((slot-home-class (slot) + (slot-home-class-using-class slot class))) + (let ((current-slots '())) + (append + (loop for slot in effective-slots + for previous-home-class = (slot-home-class slot) then home-class + for home-class = previous-home-class then (slot-home-class slot) + if (eq home-class previous-home-class) + do (push slot current-slots) + else + collect '(:newline) + and collect (format nil "~A:" (class-name previous-home-class)) + and collect '(:newline) + and append (make-slot-listing checklist object class + (nreverse current-slots) + direct-slots + longest-slot-name-length) + and do (setf current-slots (list slot))) + (and current-slots + `((:newline) + ,(format nil "~A:" + (class-name (slot-home-class-using-class + (car current-slots) class))) + (:newline) + ,@(make-slot-listing checklist object class + (nreverse current-slots) direct-slots + longest-slot-name-length))))))) + +(defun make-slot-listing (checklist object class effective-slots direct-slots + longest-slot-name-length) + (flet ((padding-for (slot-name) + (make-string (- longest-slot-name-length (length slot-name)) + :initial-element #\Space))) + (loop + for effective-slot :in effective-slots + for direct-slot = (find (swank-mop:slot-definition-name effective-slot) + direct-slots + :key #'swank-mop:slot-definition-name) + for slot-name = (inspector-princ + (swank-mop:slot-definition-name effective-slot)) + collect (make-checklist-button checklist) + collect " " + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (padding-for slot-name) + collect " = " + collect (slot-value-for-inspector class object effective-slot) + collect '(:newline)))) + +(defgeneric slot-value-for-inspector (class object slot) + (:method (class object slot) + (let ((boundp (swank-mop:slot-boundp-using-class class object slot))) + (if boundp + `(:value ,(swank-mop:slot-value-using-class class object slot)) + "#")))) + +(defun slot-home-class-using-class (slot class) + (let ((slot-name (swank-mop:slot-definition-name slot))) + (loop for class in (reverse (swank-mop:class-precedence-list class)) + thereis (and (member slot-name (swank-mop:class-direct-slots class) + :key #'swank-mop:slot-definition-name + :test #'eq) + class)))) + +(defun stable-sort-by-inheritance (slots class predicate) + (stable-sort slots predicate + :key #'(lambda (s) + (class-name (slot-home-class-using-class s class))))) + +(defun query-and-set-slot (class object slot) + (let* ((slot-name (swank-mop:slot-definition-name slot)) + (value-string (read-from-minibuffer-in-emacs + (format nil "Set slot ~S to (evaluated) : " + slot-name)))) + (when (and value-string (not (string= value-string ""))) + (with-simple-restart (abort "Abort setting slot ~S" slot-name) + (setf (swank-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string))))))) + + +(defmethod emacs-inspect ((gf standard-generic-function)) + (flet ((lv (label value) (label-value-line label value))) + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf)))) + +(defmethod emacs-inspect ((method standard-method)) + `(,@(if (swank-mop:method-generic-function method) + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method))))) + '("Method without a generic function")) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(swank-mop:method-specializers method) + ,(inspector-princ + (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(swank-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method))) + +(defun specializer-direct-methods (class) + (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< + :key + (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) + name + (second name))))))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + `("# " + (:action "[finalize]" + ,(lambda () (swank-mop:finalize-inheritance class))))) + (:newline) + ,@(let ((doc (documentation class t))) + (when doc + `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + "Sub classes: " + ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub + ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#")) + (:newline) + ,@(when (swank-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" + (:newline) + ,@(loop + for method in (specializer-direct-methods class) + collect " " + collect `(:value ,method + ,(inspector-princ + (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (swank-mop:class-finalized-p class) + `(:value ,(swank-mop:class-prototype class)) + '"#") + (:newline) + ,@(all-slots-for-inspector class))) + +(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) + `("Name: " + (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation + slot)) + (:newline))) + "Init args: " + (:value ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#") + (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in EMACS-INSPECT. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container + (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING + + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (see SYMBOL-CLASSIFICATION-STRING)" + (let ((max-length (loop for s in symbols + maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length))) + (values + (concatenate 'string + name + (make-string (+ padding distance) + :initial-element #\Space)) + (symbol-classification-string symbol))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) + :initial-element #\Space) + "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) + :initial-element #\-) + " " + (symbol-classification-string '#:foo)) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq)) + (+default-classification+ :misc)) + (flet ((normalize-classifications (classifications) + (cond ((null classifications) `(,+default-classification+)) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to + ;; :FUNCTION if possible. + ((and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications)) + (t (remove :fboundp classifications))))) + (loop for symbol in symbols do + (loop for classification in + (normalize-classifications (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table + collect k)) + (classifications (sort classifications + ;; Sort alphabetically, except + ;; +DEFAULT-CLASSIFICATION+ which + ;; sort to the end. + (lambda (a b) + (cond ((eql a +default-classification+) + nil) + ((eql b +default-classification+) + t) + (t (string< a b))))))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #\-) + (:newline) + ,@(mapcan (lambda (symbol) + `((:value ,symbol ,(symbol-name symbol)) + (:newline))) + ;; restore alphabetic order. + (nreverse symbols)) + (:newline)))))) + +(defmethod emacs-inspect ((%container %package-symbols-container)) + (with-struct (%container. title description symbols grouping-kind) %container + `(,title (:newline) (:newline) + ,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () + (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols)))) + +(defun display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length)))) + +(defmethod emacs-inspect ((package package)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (inherited-symbols '()) (inherited-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (eq status :inherited) + (push sym inherited-symbols) (incf inherited-symbols-length) + (go :continue)) + (push sym present-symbols) (incf present-symbols-length) + (cond ((eq status :internal) + (push sym internal-symbols) (incf internal-symbols-length)) + (t + (push sym external-symbols) (incf external-symbols-length)))) + :continue) + + (setf package-nicknames (sort (copy-list package-nicknames) + #'string<) + package-use-list (sort (copy-list package-use-list) + #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) + #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) + #'string<)) + ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. + (setf present-symbols (sort present-symbols #'string<) + internal-symbols (sort internal-symbols #'string<) + external-symbols (sort external-symbols #'string<) + inherited-symbols (sort inherited-symbols #'string<)) + `("" ;; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) + ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,(display-link "present" present-symbols present-symbols-length + :title + (format nil "All present symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered present in a package if it's" + (:newline) + "\"accessible in that package directly, rather than" + (:newline) + "being inherited from another package.\"" + (:newline) + "(CLHS glossary entry for `present')" + (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title + (format nil "All external symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered external of a package if it's" + (:newline) + "\"part of the `external interface' to the package and" + (:newline) + "[is] inherited by any other package that uses the" + (:newline) + "package.\" (CLHS glossary entry of `external')" + (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title + (format nil "All internal symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered internal of a package if it's" + (:newline) + "present and not external---that is if the package is" + (:newline) + "the home package of the symbol, or if the symbol has" + (:newline) + "been explicitly imported into the package." + (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," + (:newline) + "which deliberately deviates from the CLHS glossary" + (:newline) + "entry of `internal' because it's assumed to be more" + (:newline) + "useful this way." + (:newline))) + (:newline) + ,(display-link "inherited" inherited-symbols inherited-symbols-length + :title + (format nil "All inherited symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered inherited in a package if it" + (:newline) + "was made accessible via USE-PACKAGE." + (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title + (format nil "All shadowed symbols of package \"~A\"" + package-name) + :description nil)))) + + +(defmethod emacs-inspect ((pathname pathname)) + `(,(if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (:newline) + ,@(label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + ,@ (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname))))) + +(defmethod emacs-inspect ((pathname logical-pathname)) + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " + (:value ,(pathname-host pathname)) + " (" + (:value ,(logical-pathname-translations + (pathname-host pathname))) + " other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname)))))) + +(defmethod emacs-inspect ((n number)) + `("Value: " ,(princ-to-string n))) + +(defun format-iso8601-time (time-value &optional include-timezone-p) + "Formats a universal time TIME-VALUE in ISO 8601 format, with + the time zone included if INCLUDE-TIMEZONE-P is non-NIL" + ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html + ;; Thanks, Nikolai Sandved and Thomas Russ! + (flet ((format-iso8601-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Tricky. Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round (* 60 m))))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time-value) + (declare (ignore dow)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + include-timezone-p (format-iso8601-timezone (if dst + (+ zone 1) + zone)))))) + +(defmethod emacs-inspect ((i integer)) + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t))))) + +(defmethod emacs-inspect ((c complex)) + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c)))) + +(defmethod emacs-inspect ((r ratio)) + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r)))) + +(defmethod emacs-inspect ((f float)) + (cond + ((float-nan-p f) + ;; try NaN first because the next tests may perform operations + ;; that are undefined for NaNs. + (list "Not a Number.")) + ((not (float-infinity-p f)) + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" + (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f))))) + ((> f 0) + (list "Positive infinity.")) + ((< f 0) + (list "Negative infinity.")))) + +(defun make-pathname-ispec (pathname position) + `("Pathname: " + (:value ,pathname) + (:newline) " " + ,@(when position + `((:action "[visit file and show current position]" + ,(lambda () + (ed-in-emacs `(,pathname :position ,position :bytep t))) + :refreshp nil) + (:newline))))) + +(defun make-file-stream-ispec (stream) + ;; SBCL's socket stream are file-stream but are not associated to + ;; any pathname. + (let ((pathname (ignore-errors (pathname stream)))) + (when pathname + (make-pathname-ispec pathname (and (open-stream-p stream) + (file-position stream)))))) + +(defmethod emacs-inspect ((stream file-stream)) + (multiple-value-bind (content) + (call-next-method) + (append (make-file-stream-ispec stream) content))) + +(defmethod emacs-inspect ((condition stream-error)) + (multiple-value-bind (content) + (call-next-method) + (let ((stream (stream-error-stream condition))) + (append (when (typep stream 'file-stream) + (make-file-stream-ispec stream)) + content)))) + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(provide :swank-fancy-inspector) diff --git a/elpa/slime-20200319.1939/contrib/swank-fuzzy.lisp b/elpa/slime-20200319.1939/contrib/swank-fuzzy.lisp new file mode 100644 index 00000000..bfd274fe --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-fuzzy.lisp @@ -0,0 +1,706 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Authors: Brian Downing +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util) + (swank-require :swank-c-p-c)) + +(defvar *fuzzy-duplicate-symbol-filter* :nearest-package + "Specifies how fuzzy-matching handles \"duplicate\" symbols. +Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom +function. See Fuzzy Completion in the manual for details.") + +(export '*fuzzy-duplicate-symbol-filter*) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name + &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is short string describing properties of the symbol (see +SYMBOL-CLASSIFICATION-STRING). + +E.g., completing \"mvb\" in a package that uses COMMON-LISP would +return something like: + + ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) + (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor make-fuzzy-matching + (symbol package-name score package-chunks + symbol-chunks &key (symbol-p t)))) + symbol ; The symbol that has been found to match. + symbol-p ; To deffirentiate between completeing + ; package: and package:nil + package-name ; The name of the package where SYMBOL was found in. + ; (This is not necessarily the same as the home-package + ; of SYMBOL, because the SYMBOL can be internal to + ; lots of packages; also think of package nicknames.) + score ; The higher the better SYMBOL is a match. + package-chunks ; Chunks pertaining to the package identifier of SYMBOL. + symbol-chunks) ; Chunks pertaining to SYMBOL's name. + +(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) + (multiple-value-bind (_ user-package-name __ input-internal-p) + (parse-completion-arguments user-input-string nil) + (declare (ignore _ __)) + (with-struct (fuzzy-matching. score symbol package-name package-chunks + symbol-chunks symbol-p) + fuzzy-matching + (let (symbol-name real-package-name internal-p) + (cond (symbol-p ; symbol fuzzy matching? + (setf symbol-name (symbol-name symbol)) + (setf internal-p input-internal-p) + (setf real-package-name (cond ((keywordp symbol) "") + ((not user-package-name) nil) + (t package-name)))) + (t ; package fuzzy matching? + (setf symbol-name "") + (setf real-package-name package-name) + ;; If no explicit package name was given by the user + ;; (e.g. input was "asdf"), we want to append only + ;; one colon ":" to the package names. + (setf internal-p (if user-package-name input-internal-p nil)))) + (values symbol-name + real-package-name + (if user-package-name internal-p nil) + (completion-output-symbol-converter user-input-string) + (completion-output-package-converter user-input-string)))))) + +(defun fuzzy-format-matching (fuzzy-matching user-input-string) + "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." + (multiple-value-bind (symbol-name package-name internal-p + symbol-converter package-converter) + (%fuzzy-extract-matching-info fuzzy-matching user-input-string) + (setq symbol-name (and symbol-name + (funcall symbol-converter symbol-name))) + (setq package-name (and package-name + (funcall package-converter package-name))) + (let ((result (untokenize-symbol package-name internal-p symbol-name))) + ;; We return the length of the possibly added prefix as second value. + (values result (search symbol-name result))))) + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) + "Converts a result from the fuzzy completion core into something +that emacs is expecting. Converts symbols to strings, fixes case +issues, and adds information (as a string) describing if the symbol is +bound, fbound, a class, a macro, a generic-function, a +special-operator, or a package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks + symbol-p) + fuzzy-matching + (multiple-value-bind (name added-length) + (fuzzy-format-matching fuzzy-matching user-input-string) + (list name + (format nil "~,2f" score) + (append package-chunks + (mapcar (lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) + (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (if symbol-p + (symbol-classification-string symbol) + "-------p"))))) + +(defun fuzzy-completion-set (string default-package-name + &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec + (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (matchings interrupted-p) + (fuzzy-generate-matchings string default-package-name time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length matchings))) + (if (array-has-fill-pointer-p matchings) + (setf (fill-pointer matchings) limit) + (setf matchings (make-array limit :displaced-to matchings)))) + (map-into matchings #'(lambda (m) + (fuzzy-convert-matching-for-emacs m string)) + matchings) + (values matchings interrupted-p))) + + +(defun fuzzy-generate-matchings (string default-package-name + time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-symbol-name parsed-package-name + package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.name (fuzzy-matching.package-name p)) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into + matchings + (lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-name m) p.name) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (equal parsed-symbol-name "") + ;; Make package matchings be sorted before all + ;; the relative symbol matchings while preserving + ;; over all orderness. + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit &optional filter) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p) + :filter (or filter #'identity))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator + :time-limit-in-msec time-limit)) + (maybe-find-local-package (name) + (or (find-locally-nicknamed-package name *buffer-package*) + (find-package name)))) + (let ((time-limit time-limit-in-msec) (symbols) (packages) (results) + (dedup-table (make-hash-table :test #'equal))) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) + (find-packages parsed-symbol-name time-limit)) + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (symbol-packages rest-time-limit) + (find-packages parsed-package-name time-limit-in-msec) + ;; We want to traverse the found packages in the order of + ;; their score, since those with higher score presumably + ;; represent better choices. (This is important because some + ;; packages may never be looked at if time limit exhausts + ;; during traversal.) + (setf symbol-packages + (sort symbol-packages #'fuzzy-matching-greaterp)) + (loop + for package-matching across symbol-packages + for package = (maybe-find-local-package + (fuzzy-matching.package-name + package-matching)) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + ;; The duplication filter removes all those symbols + ;; which are present in more than one package + ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER* + (find-symbols parsed-symbol-name package rest-time-limit + (%make-duplicate-symbols-filter + package-matching symbol-packages dedup-table)) + (setf matchings (fix-up matchings package-matching)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time) + (let ((guessed-sort-duration + (%guess-sort-duration (length symbols)))) + (when (and rest-time-limit + (<= rest-time-limit guessed-sort-duration)) + (decf rest-time-limit guessed-sort-duration) + (loop-finish)))) + finally + (setf time-limit rest-time-limit) + (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" + (setf packages symbol-packages)))))) + ;; Sort by score; thing with equal score, sort alphabetically. + ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all + ;; possible completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'fuzzy-matching-greaterp)) + (values results (and time-limit (<= time-limit 0))))))) + +(defun %guess-sort-duration (length) + ;; These numbers are pretty much arbitrary, except that they're + ;; vaguely correct on my machine with SBCL. Yes, this is an ugly + ;; kludge, but it's better than before (where this didn't exist at + ;; all, which essentially meant, that this was taken to be 0.) + (if (zerop length) + 0 + (let ((comparasions (* 3.8 (* length (log length 2))))) + (* 1000 (* comparasions (expt 10 -7)))))) ; msecs + +(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table) + ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*. + (case *fuzzy-duplicate-symbol-filter* + (:home-package + ;; Return a filter function that takes a symbol, and which returns T + ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents + ;; the home-package of the symbol passed. + (let ((packages (mapcar #'(lambda (m) + (find-package (fuzzy-matching.package-name m))) + (remove current-package-matching + (coerce fuzzy-package-matchings 'list))))) + #'(lambda (symbol) + (not (member (symbol-package symbol) packages))))) + (:nearest-package + ;; Keep only the first occurence of the symbol. + #'(lambda (symbol) + (unless (gethash (symbol-name symbol) dedup-table) + (setf (gethash (symbol-name symbol) dedup-table) t)))) + (:all + ;; No filter + #'identity) + (t + (typecase *fuzzy-duplicate-symbol-filter* + (function + ;; Custom filter + (funcall *fuzzy-duplicate-symbol-filter* + (fuzzy-matching.package-name current-package-matching) + (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings) + dedup-table)) + (t + ;; Bad filter value + (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s" + *fuzzy-duplicate-symbol-filter*) + #'identity))))) + +(defun fuzzy-matching-greaterp (m1 m2) + "Returns T if fuzzy-matching M1 should be sorted before M2. +Basically just the scores of the two matchings are compared, and +the match with higher score wins. For the case that the score is +equal, the one which comes alphabetically first wins." + (declare (type fuzzy-matching m1 m2)) + (let ((score1 (fuzzy-matching.score m1)) + (score2 (fuzzy-matching.score m2))) + (cond ((> score1 score2) t) + ((< score1 score2) nil) ; total order + (t + (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) + (name2 (symbol-name (fuzzy-matching.symbol m2)))) + (string< name1 name2)))))) + +(declaim (ftype (function () (integer 0)) get-real-time-msecs)) +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) + +(defun fuzzy-find-matching-symbols + (string package &key (filter #'identity) external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm, and the +remaining time limit. + +Only those symbols are considered of which FILTER does return T. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (package-name (package-name package)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + ;; propagate NIL back as infinite time limit + (values nil nil)) + ((> count 0) ; ease up on getting internal time like crazy + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string + converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return)) + ((not (and (or (not external-only) + (symbol-external-p symbol package)) + (funcall filter symbol)))) + ((string= "" string) ; "" matches always + (vector-push-extend + (make-fuzzy-matching symbol package-name + 0.0 '() '()) + completions)) + (t + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol package-name score + '() match-result) + completions))))))) + (values completions rest-time-limit))))) + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (flet ((match-package (names) + (loop with max-pkg-name = "" + with max-result = nil + with max-score = 0 + for package-name in names + for converted-name = (funcall converter package-name) + do + (multiple-value-bind (result score) + (compute-highest-scoring-completion name + converted-name) + (when (and result (> score max-score)) + (setf max-pkg-name package-name) + (setf max-result result) + (setf max-score score))) + finally + (when max-result + (vector-push-extend + (make-fuzzy-matching nil max-pkg-name + max-score max-result '() + :symbol-p nil) + completions))))) + (cond ((and time-limit-p (<= time-limit 0)) + (values #() time-limit)) + (t + (loop for (nick) in (package-local-nicknames *buffer-package*) + do + (match-package (list nick))) + (loop for package in (list-all-packages) + do + ;; Find best-matching package-nickname: + (match-package (package-names package)) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start))) + (- time-limit elapsed-time))))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as \"ZZZZZZ\" with a symbol named +\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defvar *all-chunks* '()) +(declaim (type list *all-chunks*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, +RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position +one index ahead, to find other possibly higher scoring +possibilities. If there are less than +*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, +this call will also recurse. + +Once a word has been completely matched, the chunks are pushed +onto the special variable *ALL-CHUNKS* and the function returns." + (declare (optimize speed) + (type fixnum short-index initial-full-index) + (type list current-chunk) + (simple-string short full)) + (flet ((short-cur () + "Returns the next letter from the abbreviation, or NIL + if all have been used." + (if (= short-index (length short)) + nil + (aref short short-index))) + (add-to-chunk (char pos) + "Adds the CHAR at POS in FULL to the current chunk, + marking the start position if it is empty." + (unless current-chunk + (setf current-chunk-pos pos)) + (push char current-chunk)) + (collect-chunk () + "Collects the current chunk to CHUNKS and prepares for + a new chunk." + (when current-chunk + (let ((current-chunk-as-string + (nreverse + (make-array (length current-chunk) + :element-type 'character + :initial-contents current-chunk)))) + (push (list current-chunk-pos current-chunk-as-string) chunks) + (setf current-chunk nil + current-chunk-pos nil))))) + ;; If there's an outstanding chunk coming in collect it. Since + ;; we're recursively called on skipping an input character, the + ;; chunk can't possibly continue on. + (when current-chunk (collect-chunk)) + (do ((pos initial-full-index (1+ pos))) + ((= pos (length full))) + (let ((cur-char (aref full pos))) + (if (and (short-cur) + (char= cur-char (short-cur))) + (progn + (when recurse-p + ;; Try other possibilities, limiting insanely deep + ;; recursion somewhat. + (recursively-compute-most-completions + short full short-index (1+ pos) + chunks current-chunk current-chunk-pos + (not (> (length *all-chunks*) + *fuzzy-recursion-soft-limit*)))) + (incf short-index) + (add-to-chunk cur-char pos)) + (collect-chunk)))) + (collect-chunk) + ;; If we've exhausted the short characters we have a match. + (if (short-cur) + nil + (let ((rev-chunks (reverse chunks))) + (push rev-chunks *all-chunks*) + rev-chunks)))) + + +;;;;; Fuzzy completion scoring + +(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<" + "Letters that are likely to be at the beginning of a symbol. +Letters found after one of these prefixes will be scored as if +they were at the beginning of ths symbol.") +(defvar *fuzzy-completion-symbol-suffixes* "*+->" + "Letters that are likely to be at the end of a symbol. +Letters found before one of these suffixes will be scored as if +they were at the end of the symbol.") +(defvar *fuzzy-completion-word-separators* "-/." + "Letters that separate different words in symbols. Letters +after one of these symbols will be scores more highly than other +letters.") + +(defun score-completion (completion short full) + "Scores the completion chunks COMPLETION as a completion from +the abbreviation SHORT to the full string FULL. COMPLETION is a +list like: + ((0 \"mul\") (9 \"v\") (15 \"b\")) +Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", +would indicate that it completed as such (completed letters +capitalized): + MULtiple-Value-Bind + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #\- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal." + (labels ((at-beginning-p (pos) + (= pos 0)) + (after-prefix-p (pos) + (and (= pos 1) + (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) + (word-separator-p (pos) + (find (aref full pos) *fuzzy-completion-word-separators*)) + (after-word-separator-p (pos) + (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) + (at-end-p (pos) + (= pos (1- (length full)))) + (before-suffix-p (pos) + (and (= pos (- (length full) 2)) + (find (aref full (1- (length full))) + *fuzzy-completion-symbol-suffixes*))) + (score-or-percentage-of-previous (base-score pos chunk-pos) + (if (zerop chunk-pos) + base-score + (max base-score + (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) + (expt 1.2 chunk-pos))))) + (score-char (pos chunk-pos) + (score-or-percentage-of-previous + (cond ((at-beginning-p pos) 10) + ((after-prefix-p pos) 10) + ((word-separator-p pos) 1) + ((after-word-separator-p pos) 8) + ((at-end-p pos) 6) + ((before-suffix-p pos) 6) + (t 1)) + pos chunk-pos)) + (score-chunk (chunk) + (loop for chunk-pos below (length (second chunk)) + for pos from (first chunk) + summing (score-char pos chunk-pos)))) + (let* ((chunk-scores (mapcar #'score-chunk completion)) + (length-score (/ 10.0 (1+ (- (length full) (length short)))))) + (values + (+ (reduce #'+ chunk-scores) length-score) + (list (mapcar #'list chunk-scores completion) length-score))))) + +(defun highlight-completion (completion full) + "Given a chunk definition COMPLETION and the string FULL, +HIGHLIGHT-COMPLETION will create a string that demonstrates where +the completion matched in the string. Matches will be +capitalized, while the rest of the string will be lower-case." + (let ((highlit (nstring-downcase (copy-seq full)))) + (dolist (chunk completion) + (setf highlit (nstring-upcase highlit + :start (first chunk) + :end (+ (first chunk) + (length (second chunk)))))) + highlit)) + +(defun format-fuzzy-completion-set (winners) + "Given a list of completion objects such as on returned by +FUZZY-COMPLETION-SET, format the list into user-readable output +for interactive debugging purpose." + (let ((max-len + (loop for winner in winners maximizing (length (first winner))))) + (loop for (sym score result) in winners do + (format t "~&~VA score ~8,2F ~A" + max-len (highlight-completion result sym) score result)))) + +(provide :swank-fuzzy) diff --git a/elpa/slime-20200319.1939/contrib/swank-goo.goo b/elpa/slime-20200319.1939/contrib/swank-goo.goo new file mode 100644 index 00000000..562401dc --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-goo.goo @@ -0,0 +1,995 @@ +;;;; swank-goo.goo --- Swank server for GOO +;;; +;;; Copyright (C) 2005 Helmut Eller +;;; +;;; This file is licensed under the terms of the GNU General Public +;;; License as distributed with Emacs (press C-h C-c to view it). + +;;;; Installation +;; +;; 1. Add something like this to your .emacs: +;; +;; (setq slime-lisp-implementations +;; '((goo ("g2c") :init goo-slime-init))) +;; +;; (defun goo-slime-init (file _) +;; (format "%S\n%S\n" +;; `(set goo/system:*module-search-path* +;; (cat '(".../slime/contrib/") +;; goo/system:*module-search-path*)) +;; `(swank-goo:start-swank ,file))) +;; +;; 2. Start everything with M-- M-x slime goo +;; + +;;;; Code + +(use goo) +(use goo/boot) +(use goo/x) +(use goo/io/port) +(use goo/io/write) +(use goo/eval) +(use goo/system) +(use goo/conditions) +(use goo/fun) +(use goo/loc) +(use goo/chr) +(use eval/module) +(use eval/ast) +(use eval/g2c) + + +;;;; server setup + +(df create-server (port-number) (setup-server port-number announce-port)) + +(df start-swank (port-file) + (setup-server 0 (fun (s) (write-port-file (%local-port s) port-file)))) + +(df setup-server (port-number announce) + (let ((s (create-socket port-number))) + (fin (seq + (announce s) + (let ((c (accept s))) + ;;(post "connection: %s" c) + (fin (serve-requests c) + (%close (@fd c))))) + (post "closing socket: %s" s) + (%close s)))) + +(df announce-port (socket) + (post "Listening on port: %d\n" (%local-port socket))) + +(df write-port-file (port-number filename) + (with-port (file (open filename)) + (msg file "%d\n" port-number))) + +(dc ()) + +(dc ()) +(dp @socket ( => )) +(dp @in ( => )) +(dp @out ( => )) + +(dv emacs-connection|(t? ) #f) + +(df serve-requests (socket) + (dlet ((emacs-connection (new + @socket socket + @out (new @socket socket) + @in (new @socket socket)))) + (dlet ((out (@out emacs-connection)) + (in (@in emacs-connection))) + (while #t + (simple-restart + "SLIME top-level" + (fun () (process-next-event socket))))))) + +(d. (t= 'nil)) +(d. t #t) +(d. cons pair) + +(dv tag-counter| 0) + +(df process-next-event (port) (dispatch-event (decode-message port) port)) + +(df dispatch-event (event port) + ;; (post "%=\n" event) + (match event + ((:emacs-rex ,form ,package ,_thread-id ,id) + (eval-for-emacs form package port id)) + ((:read-string ,_) + (def tag (incf tag-counter)) + (encode-message `(:read-string ,_ ,tag) port) + (rep loop () + (match (decode-message port) + ((:emacs-return-string ,_ ,rtag ,str) + (assert (= tag rtag) "Unexpected reply tag: %d" rtag) + str) + ((,@evt) + (try-recover + (fun () (dispatch-event evt port)) + (fun () (encode-message `(:read-aborted ,_ ,tag) port))) + (loop))))) + ((:emacs-return-string ,_ ,rtag ,str) + (error "Unexpected event: %=" event)) + ((,@_) (encode-message event port)))) + +(dc ()) +(dp @module ( => )) +(dp @id ( => )) +(dp @port ( => )) +(dp @prev ( => (t? ))) + +;; should be ddv +(dv eval-context|(t? ) #f) + +(df buffer-module () (@module eval-context)) + +(df eval-for-emacs (form| package|(t+ ) port id|) + (try-recover + (fun () + (try debugger-hook + (dlet ((eval-context (new + @module (find-buffer-module package) @id id + @port port @prev eval-context))) + (def result (eval (frob-form-for-eval form) 'swank-goo)) + (force-out out) + (dispatch-event `(:return (:ok ,result) ,id) port)))) + (fun () (dispatch-event `(:return (:abort) ,id) port)))) + +(dm find-buffer-module (name| => ) + (or (elt-or (all-modules) (as-sym name) #f) + (find-buffer-module 'nil))) + +(dm find-buffer-module (name| => ) default-module) + +(dv default-module| (runtime-module 'goo/user)) + +(d. slimefuns (fab 100)) + +(ds defslimefun (,name ,args ,@body) + `(set (elt slimefuns ',name) + (df ,(cat-sym 'swank@ name) ,args ,@body))) + +(df slimefun (name) + (or (elt-or slimefuns name #f) + (error "Undefined slimefun: %=" name))) + +;; rewrite (swank:foo ...) to ((slimefun 'foo) ...) +(df frob-form-for-eval (form) + (match form + ((,op ,@args) + (match (map as-sym (split (sym-name op) #\:)) + ((swank ,name) + `((slimefun ',name) ,@args)))))) + + +;;;; debugger + +(dc ()) +(dp @level ( => )) +(dp @top-frame ( => )) +(dp @restarts ( => )) +(dp @condition ( => )) +(dp @eval-context ( => (t? ))) + +(dv sldb-context|(t? ) #f) + +(df debugger-hook (c| resume) + (let ((tf (find-top-frame 'debugger-hook 2)) + (rs (compute-restarts c)) + (l (if sldb-context (1+ (@level sldb-context)) 1))) + (cond ((> l 10) (emergency-abort c)) + (#t + (dlet ((sldb-context (new + @level l @top-frame tf + @restarts rs @condition c + @eval-context eval-context))) + (let ((bt (compute-backtrace tf 0 10))) + (force-out out) + (dispatch-event `(:debug 0 ,l + ,@(debugger-info c rs bt eval-context)) + (@port eval-context)) + (sldb-loop l (@port eval-context)))))))) + +(df emergency-abort (c) + (post "Maximum debug level reached aborting...\n") + (post "%s\n" (describe-condition c)) + (do-stack-frames (fun (f args) (msg out " %= %=\n" f args))) + (invoke-handler-interactively (find-restart ) in out)) + +(df sldb-loop (level port) + (fin (while #t + (dispatch-event `(:debug-activate 0 ,level) port) + (simple-restart + (msg-to-str "Return to SLDB level %s" level) + (fun () (process-next-event port)))) + (dispatch-event `(:debug-return 0 ,level nil) port))) + +(defslimefun backtrace (start| end|(t+ )) + (backtrace-for-emacs + (compute-backtrace (@top-frame sldb-context) + start + (if (isa? end ) end #f)))) + +(defslimefun throw-to-toplevel () + (invoke-handler-interactively (find-restart ) in out)) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level| n|) + (when (= (@level sldb-context) sldb-level) + (invoke-handler-interactively (elt (@restarts sldb-context) n) in out))) + +(defslimefun debugger-info-for-emacs (start end) + (debugger-info (@condition sldb-context) + (@restarts sldb-context) + (compute-backtrace (@top-frame sldb-context) + start + (if (isa? end ) end #f)))) + +(defslimefun frame-locals-and-catch-tags (frame-idx) + (def frame (nth-frame frame-idx)) + (list + (map-keyed (fun (i name) + (lst ':name (sym-name name) ':id 0 + ':value (safe-write-to-string (frame-var-value frame i)))) + (frame-var-names frame)) + '())) + +(defslimefun inspect-frame-var (frame-idx var-idx) + (reset-inspector) + (inspect-object (frame-var-value (nth-frame frame-idx) var-idx))) + +(defslimefun inspect-current-condition () + (reset-inspector) + (inspect-object (@condition sldb-context))) + +(defslimefun frame-source-location (frame-idx) + (match (nth-frame frame-idx) + ((,f ,@_) + (or (emacs-src-loc f) + `(:error ,(msg-to-str "No src-loc available for: %s" f)))))) + +(defslimefun eval-string-in-frame (string frame-idx) + (def frame (nth-frame frame-idx)) + (let ((names (frame-var-names frame)) + (values (frame-var-values frame))) + (write-to-string + (app (eval `(fun ,names ,(read-from-string string)) + (module-name (buffer-module))) + values)))) + +(df debugger-info (condition restarts backtrace eval-context) + (lst `(,(try-or (fun () (describe-condition condition)) "<...>") + ,(cat " [class: " (class-name-str condition) "]") + ()) + (restarts-for-emacs restarts) + (backtrace-for-emacs backtrace) + (pending-continuations eval-context))) + +(df backtrace-for-emacs (backtrace) + (map (fun (f) + (match f + ((,idx (,f ,@args)) + (lst idx (cat (if (fun-name f) + (sym-name (fun-name f)) + (safe-write-to-string f)) + (safe-write-to-string args)))))) + backtrace)) + +(df restarts-for-emacs (restarts) + (map (fun (x) `(,(sym-name (class-name (%handler-condition-type x))) + ,(describe-restart x))) + restarts)) + +(df describe-restart (restart) + (describe-handler (%handler-info restart) (%handler-condition-type restart))) + +(df compute-restarts (condition) + (packing (%do-handlers-of-type (fun (c) (pack c))))) + +(df find-restart (type) + (esc ret + (%do-handlers-of-type type ret) + #f)) + +(df pending-continuations (context|(t? )) + (if context + (pair (@id context) (pending-continuations (@prev context))) + '())) + +(df find-top-frame (fname| offset|) + (esc ret + (let ((top-seen? #f)) + (do-stack-frames (fun (f args) + (cond (top-seen? + (cond ((== offset 0) + (ret (pair f args))) + (#t (decf offset)))) + ((== (fun-name f) fname) + (set top-seen? #t)))))))) + +(df compute-backtrace (top-frame start| end) + (packing + (esc break + (do-user-frames (fun (idx f args) + (when (and end (<= end idx)) + (break #f)) + (when (<= start idx) + (pack (lst idx (pair f args))))) + top-frame)))) + +(df nth-frame (n|) + (esc ret + (do-user-frames + (fun (idx f args) + (when (= idx n) + (ret (pair f args)))) + (@top-frame sldb-context)))) + +(df frame-var-value (frame var-idx) + (match frame + ((,f ,@args) + (def sig (fun-sig f)) + (def arity (sig-arity sig)) + (def nary? (sig-nary? sig)) + (cond ((< var-idx arity) (elt args var-idx)) + (nary? (sub* args arity)))))) + +(df frame-var-names (frame) + (match frame + ((,f ,@_) (fun-info-names (fun-info f))))) + +(df frame-var-values (frame) + (map (curry frame-var-value frame) (keys (frame-var-names frame)))) + +(df do-user-frames (f| top-frame) + (let ((idx -1) + (top-seen? #f)) + (do-stack-frames + (fun (ffun args) + (cond (top-seen? + (incf idx) + (f idx ffun (rev args))) + ((= (pair ffun args) top-frame) + (set top-seen? #t))))))) + + +;;;; Write some classes a little less verbose + +;; (dm recurring-write (port| x d| recur|) +;; (msg port "#{%s &%s}" (class-name-str x) +;; (num-to-str-base (address-of x) 16))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (module-name x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (binding-name x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (len x))) + +(dm recurring-write (port| x| + d| recur|) + (msg port "#{%s}" (class-name-str x))) + +(dm recurring-write (port| x| + d| recur|) + (msg port "#{%s}" (class-name-str x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s:%=}" (class-name-str x) + (src-loc-file x) (src-loc-line x))) + + +;;;; Inspector + +(dc ()) +(dp! @object ( => )) +(dp! @parts ( => ) (new )) +(dp! @stack ( => ) '()) + +(dv inspector #f) + +(defslimefun init-inspector (form|) + (reset-inspector) + (inspect-object (str-eval form (buffer-module)))) + +(defslimefun quit-inspector () (reset-inspector) 'nil) + +(defslimefun inspect-nth-part (n|) + (inspect-object (elt (@parts inspector) n))) + +(defslimefun inspector-pop () + (cond ((<= 2 (len (@stack inspector))) + (popf (@stack inspector)) + (inspect-object (popf (@stack inspector)))) + (#t 'nil))) + +(df reset-inspector () (set inspector (new ))) + +(df inspect-object (o) + (set (@object inspector) o) + (set (@parts inspector) (new )) + (pushf (@stack inspector) o) + (lst ':title (safe-write-to-string o) ; ':type (class-name-str o) + ':content (inspector-content + `("class: " (:value ,(class-of o)) "\n" + ,@(inspect o))))) + +(df inspector-content (content) + (map (fun (part) + (case-by part isa? + (() part) + (() + (match part + ((:value ,o ,@str) + `(:value ,@(if (nul? str) + (lst (safe-write-to-string o)) + str) + ,(assign-index o))))) + (#t (error "Bad inspector content: %=" part)))) + content)) + +(df assign-index (o) + (pushf (@parts inspector) o) + (1- (len (@parts inspector)))) + +(dg inspect (o)) + +;; a list of dangerous functions +(d. getter-blacklist (lst fun-code fun-env class-row)) + +(dm inspect (o) + (join (map (fun (p) + (let ((getter (prop-getter p))) + `(,(sym-name (fun-name getter)) ": " + ,(cond ((mem? getter-blacklist getter) "<...>") + ((not (prop-bound? o getter)) "") + (#t (try-or (fun () `(:value ,(getter o))) + "<...>")))))) + (class-props (class-of o))) + '("\n"))) + +(dm inspect (o|) + (join (packing (do-keyed (fun (pos val) + (pack `(,(num-to-str pos) ": " (:value ,val)))) + o)) + '("\n"))) + +(dm inspect (o|) + (join (packing (do-keyed (fun (key val) + (pack `((:value ,key) "\t: " (:value ,val)))) + o)) + '("\n"))) + +;; inspecting the env of closures is broken +;; (dm inspect (o|) +;; (cat (sup o) +;; '("\n") +;; (if (%fun-env? o) +;; (inspect (packing (for ((i (below (%fun-env-len o)))) +;; (pack (%fun-env-elt o i))))) +;; '()))) +;; +;; (df %fun-env? (f| => ) #eb{ FUNENV($f) != $#f }) +;; (df %fun-env-len (f| => ) #ei{ ((ENV)FUNENV ($f))->size }) +;; (df %fun-env-elt (f| i| => ) #eg{ FUNENVGET($f, @i) }) + + +;;;; init + +(defslimefun connection-info () + `(:pid + ,(process-id) :style nil + :lisp-implementation (:type "GOO" :name "goo" + :version ,(%lookup '*goo-version* 'eval/main)) + :machine (:instance "" :type "" :version "") + :features () + :package (:name "goo/user" :prompt "goo/user"))) + +(defslimefun quit-lisp () #ei{ exit (0),0 }) + +(defslimefun set-default-directory (dir|) #ei{ chdir(@dir) } dir) + + +;;;; eval + +(defslimefun ping () "PONG") + +(defslimefun create-repl (_) + (let ((name (sym-name (module-name (buffer-module))))) + `(,name ,name))) + +(defslimefun listener-eval (string) + (clear-input in) + `(:values ,(write-to-string (str-eval string (buffer-module))))) + +(defslimefun interactive-eval (string) + (cat "=> " (write-to-string (str-eval string (buffer-module))))) + +(df str-eval (s| m|) + (eval (read-from-string s) (module-name m))) + +(df clear-input (in|) (while (ready? in) (get in))) + +(dc ()) + +(defslimefun simple-break () + (simple-restart + "Continue from break" + (fun () (sig (new + condition-message "Interrupt from Emacs")))) + 'nil) + +(defslimefun clear-repl-results () 'nil) + + +;;;; compile + +(defslimefun compile-string-for-emacs (string buffer position directory) + (def start (current-time)) + (def r (g2c-eval (read-from-string string) + (module-target-environment (buffer-module)))) + (lst (write-to-string r) + (/ (as (- (current-time) start)) 1000000.0))) + +(defslimefun compiler-notes-for-emacs () 'nil) + +(defslimefun filename-to-modulename (filename| => (t+ )) + (try-or (fun () (sym-name (filename-to-modulename filename))) 'nil)) + +(df filename-to-modulename (filename| => ) + (def paths (map pathname-to-components + (map simplify-filename + (pick file-exists? *module-search-path*)))) + (def filename (pathname-to-components filename)) + (def moddir (rep parent ((modpath filename)) + (cond ((any? (curry = modpath) paths) + modpath) + (#t + (parent (components-parent-directory modpath)))))) + (def modfile (components-to-pathname (sub* filename (len moddir)))) + (as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*))))) + + + +;;;; Load + +(defslimefun load-file (filename) + (let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename) + (#t (cat filename ".goo"))))) + (safe-write-to-string (load-file file (filename-to-modulename file))))) + + +;;;; background activities + +(defslimefun operator-arglist (op _) + (try-or (fun () + (let ((value (str-eval op (buffer-module)))) + (if (isa? value ) + (write-to-string value) + 'nil))) + 'nil)) + + +;;;; M-. + +(defslimefun find-definitions-for-emacs (name|) + (match (parse-symbol name) + ((,sym ,modname) + (def env (module-target-environment (runtime-module modname))) + (def b (find-binding sym env)) + (cond (b (find-binding-definitions b)) + (#t 'nil))))) + +(df parse-symbol (name| => ) + (if (mem? name #\:) + (match (split name #\:) + ((,module ,name) (lst (as-sym name) (as-sym module)))) + (lst (as-sym name) (module-name (buffer-module))))) + +(df find-binding-definitions (b|) + (def value (case (binding-kind b) + (('runtime) (loc-val (binding-locative b))) + (('global) (let ((box (binding-global-box b))) + (and box (global-box-value box)))) + (('macro) (binding-info b)) + (#t (error "unknown binding kind %=" (binding-kind b))))) + (map (fun (o) + (def loc (emacs-src-loc o)) + `(,(write-to-string (dspec o)) + ,(or loc `(:error "no src-loc available")))) + (defining-objects value))) + +(dm defining-objects (o => ) '()) +(dm defining-objects (o| => ) (lst o)) +(dm defining-objects (o| => ) (pair o (fun-mets o))) + +(dm emacs-src-loc (o|) + (def loc (fun-src-loc o)) + (and loc `(:location (:file ,(simplify-filename + (find-goo-file-in-path + (module-name-to-relpath (src-loc-file loc)) + *module-search-path*))) + (:line ,(src-loc-line loc)) + ()))) + +(dm dspec (f|) + (cond ((fun-name f) + `(,(if (isa? f ) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f))) + (#t f))) + +(df dspec-arglist (f|) + (map2 (fun (name class) + (cond ((= class ) name) + ((isa? class ) + `(,name ,(class-name class))) + (#t `(,name ,class)))) + (fun-info-names (fun-info f)) + (sig-specs (fun-sig f)))) + +(defslimefun buffer-first-change (filename) 'nil) + + +;;;; apropos + +(defslimefun apropos-list-for-emacs + (pattern only-external? case-sensitive? package) + (def matches (fab 100)) + (do-all-bindings + (fun (b) + (when (finds (binding-name-str b) pattern) + (set (elt matches + (cat-sym (binding-name b) + (module-name (binding-module b)))) + b)))) + (set matches (sort-by (packing-as (for ((b matches)) (pack b))) + (fun (x y) + (< (binding-name x) + (binding-name y))))) + (map (fun (b) + `(:designator + ,(cat (sym-name (module-name (binding-module b))) ":" + (binding-name-str b) + "\tkind: " (sym-name (binding-kind b))))) + (as matches))) + +(df do-all-bindings (f|) + (for ((module (%module-loader-modules (runtime-module-loader)))) + (do f (environment-bindings (module-target-environment module))))) + +(dm < (s1| s2| => ) + (let ((l1 (len s1)) (l2 (len s2))) + (rep loop ((i 0)) + (cond ((= i l1) (~= l1 l2)) + ((= i l2) #f) + ((< (elt s1 i) (elt s2 i)) #t) + ((= (elt s1 i) (elt s2 i)) (loop (1+ i))) + (#t #f))))) + +(df %binding-info (name| module|) + (binding-info + (find-binding + name (module-target-environment (runtime-module module))))) + + +;;;; completion + +(defslimefun simple-completions (pattern| package) + (def matches (lst)) + (for ((b (environment-bindings (module-target-environment (buffer-module))))) + (when (prefix? (binding-name-str b) pattern) + (pushf matches b))) + (def strings (map binding-name-str matches)) + `(,strings ,(cond ((nul? strings) pattern) + (#t (fold+ common-prefix strings))))) + +(df common-prefix (s1| s2|) + (let ((limit (min (len s1) (len s2)))) + (rep loop ((i 0)) + (cond ((or (= i limit) + (~= (elt s1 i) (elt s2 i))) + (sub s1 0 i)) + (#t (loop (1+ i))))))) + +(defslimefun list-all-package-names (_|...) + (map sym-name (keys (all-modules)))) + +(df all-modules () (%module-loader-modules (runtime-module-loader))) + + +;;;; Macroexpand + +(defslimefun swank-macroexpand-1 (str|) + (write-to-string + (%ast-macro-expand (read-from-string str) + (module-target-environment (buffer-module)) + #f))) + + +;;;; streams + +(dc ()) +(dp @socket ( => )) +(dp! @buf-len ( => ) 0) +(dp @buf ( => ) (new )) +(dp! @timestamp ( => ) 0) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x))) + +(dm put (p| c|) + (add! (@buf p) c) + (incf (@buf-len p)) + (maybe-flush p (= c #\newline))) + +(dm puts (p| s|) + (add! (@buf p) s) + (incf (@buf-len p) (len s)) + (maybe-flush p (mem? s #\newline))) + +(df maybe-flush (p| newline?|) + (and (or (> (@buf-len p) 4000) newline?) + (> (- (current-time) (@timestamp p)) 100000) + (force-out p))) + +(dm force-out (p|) + (unless (zero? (@buf-len p)) + (dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p)) + (set (@buf-len p) 0) + (zap! (@buf p))) + (set (@timestamp p) (current-time))) + +(df %buf-to-str (buf|) + (packing-as + (for ((i buf)) + (cond ((isa? i ) (for ((c i)) (pack c))) + (#t (pack i)))))) + +(dc ()) +(dp @socket ( => )) +(dp! @idx ( => ) 0) +(dp! @buf ( => ) "") + +(df receive-input (p|) + (dispatch-event `(:read-string ,0) (@socket p))) + +(dm get (p| => ) + (cond ((< (@idx p) (len (@buf p))) + (def c (elt (@buf p) (@idx p))) + (incf (@idx p)) + c) + (#t + (def input (receive-input p)) + (cond ((zero? (len input)) (eof-object)) + (#t (set (@buf p) input) + (set (@idx p) 0) + (get p)))))) + +(dm ready? (p| => ) (< (@idx p) (len (@buf p)))) + +(dm peek (p| => ) + (let ((c (get p))) + (unless (eof-object? c) + (decf (@idx p))) + c)) + + +;;;; Message encoding + +(df decode-message (port|) + (read-from-string (get-block port (read-message-length port)))) + +(df read-message-length (port) + (or (str-to-num (cat "#x" (get-block port 6))) + (error "can't parse message length"))) + +(df encode-message (message port) + (let ((string (dlet ((*max-print-length* 1000000) + (*max-print-depth* 1000000)) + (write-to-string message)))) + (puts port (encode-message-length (len string))) + (puts port string) + (force-out port))) + +(df encode-message-length (n) + (loc ((hex (byte) + (if (< byte #x10) + (cat "0" (num-to-str-base byte 16)) + (num-to-str-base byte 16))) + (byte (i) (hex (& (>> n (* i 8)) 255)))) + (cat (byte 2) (byte 1) (byte 0)))) + + +;;;; semi general utilities + +;; Return the name of O's class as string. +(df class-name-str (o => ) (sym-name (class-name (class-of o)))) + +(df binding-name-str (b| => ) (sym-name (binding-name b))) + +(df as-sym (str|) (as str)) + +;; Replace '//' in the middle of a filename with with a '/' +(df simplify-filename (str| => ) + (match (pathname-to-components str) + ((,hd ,@tl) + (components-to-pathname (cons hd (del-vals tl 'root)))))) + +;; Execute BODY and only if BODY exits abnormally execute RECOVER. +(df try-recover (body recover) + (let ((ok #f)) + (fin (let ((val (body))) + (set ok #t) + val) + (unless ok + (recover))))) + +;; like CL's IGNORE-ERRORS but return VALUE in case of an error. +(df try-or (body| value) + (esc ret + (try (fun (condition resume) (ret value)) + (body)))) + +(df simple-restart (type msg body) + (esc restart + (try ((type type) (description msg)) + (fun (c r) (restart #f)) + (body)))) + +(df safe-write-to-string (o) + (esc ret + (try (fun (c r) + (ret (cat "#"))) + (write-to-string o)))) + +;; Read a string of length COUNT. +(df get-block (port| count| => ) + (packing-as + (for ((i (below count))) + (let ((c (get port))) + (cond ((eof-object? c) + (error "Premature EOF (read %d of %d)" i count)) + (#t (pack c))))))) + + +;;;; import some internal bindings + +(df %lookup (name| module|) + (loc-val + (binding-locative + (find-binding + name (module-target-environment (runtime-module module)))))) + +(d. %handler-info (%lookup 'handler-info 'goo/conditions)) +(d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions)) +(d. %do-handlers-of-type (%lookup 'do-handlers-of-type 'goo/conditions)) +(d. %module-loader-modules (%lookup 'module-loader-modules 'eval/module)) +(d. %ast-macro-expand (%lookup 'ast-macro-expand 'eval/ast)) + + +;;;; low level socket stuff +;;; this shouldn't be here + +#{ +#include +#include +#include +#include +#include +#include +#include + +/* convert a goo number to a C long */ +static long g2i (P o) { return untag (o); } + +static int +set_reuse_address (int socket, int value) { + return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value); +} + +static int +bind_socket (int socket, int port) { + struct sockaddr_in addr; + addr.sin_family = AF_INET; + addr.sin_port = htons (port); + addr.sin_addr.s_addr = htonl (INADDR_ANY); + return bind (socket, (struct sockaddr *)&addr, sizeof addr); +} + +static int +local_port (int socket) { + struct sockaddr_in addr; + socklen_t len = sizeof addr; + int code = getsockname (socket, (struct sockaddr *)&addr, &len); + return (code == -1) ? -1 : ntohs (addr.sin_port); +} + +static int +c_accept (int socket) { + struct sockaddr_in addr; + socklen_t len = sizeof addr; + return accept (socket, (struct sockaddr *)&addr, &len); +} + +static P tup3 (P e0, P e1, P e2) { + P tup = YPPtfab ((P)3, YPfalse); + YPtelt_setter (e0, tup, (P)0); + YPtelt_setter (e1, tup, (P)1); + YPtelt_setter (e2, tup, (P)2); + return tup; +} + +static P +current_time (void) { + struct timeval timeval; + int code = gettimeofday (&timeval, NULL); + if (code == 0) { + return tup3 (YPib ((P)(timeval.tv_sec >> 24)), + YPib ((P)(timeval.tv_sec & 0xffffff)), + YPib ((P)(timeval.tv_usec))); + } else return YPib ((P)errno); +} +} + +;; Return the current time in microsecs +(df current-time (=> ) + (def t #eg{ current_time () }) + (cond ((isa? t ) (error "%s" (strerror t))) + (#t (+ (* (+ (<< (1st t) 24) + (2nd t)) + 1000000) + (3rd t))))) + +(dm strerror (e| => ) #es{ strerror (g2i ($e)) }) +(dm strerror (e|(t= #f) => ) #es{ strerror (errno) }) + +(df checkr (value|) + (cond ((~== value -1) value) + (#t (error "%s" (strerror #f))))) + +(df create-socket (port| => ) + (let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) }))) + (checkr #ei{ set_reuse_address (g2i ($socket), 1) }) + (checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) }) + (checkr #ei{ listen (g2i ($socket), 1)}) + socket)) + +(df %local-port (fd|) (checkr #ei{ local_port (g2i ($fd)) })) +(df %close (fd|) (checkr #ei{ close (g2i ($fd)) })) + +(dc ( )) +(dp @fd ( => )) +(dp @in ( => )) +(dp @out ( => )) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s fd: %s}" (class-name-str x) (@fd x))) + +(dm get (port| => ) (get (@in port))) + +(dm puts (port| s|) (puts (@out port) s)) +(dm force-out (port|) (force-out (@out port))) + +(dm fdopen (fd| type|(t= ) => ) + (new @fd fd + @in (new port-handle (%fdopen fd "r")) + @out (new port-handle (%fdopen fd "w")))) + +(df %fdopen (fd| mode| => ) + (def addr #ei{ fdopen (g2i ($fd), @mode) }) + (when (zero? addr) + (error "fdopen failed: %s" (strerror #f))) + (%lb (%iu addr))) + +(df accept (socket| => ) + (fdopen (checkr #ei{ c_accept (g2i ($socket)) }) )) + +(export + start-swank + create-server) + +;;; swank-goo.goo ends here \ No newline at end of file diff --git a/elpa/slime-20200319.1939/contrib/swank-hyperdoc.lisp b/elpa/slime-20200319.1939/contrib/swank-hyperdoc.lisp new file mode 100644 index 00000000..1e34a1d0 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-hyperdoc.lisp @@ -0,0 +1,18 @@ +(in-package :swank) + +(defslimefun hyperdoc (string) + (let ((hyperdoc-package (find-package :hyperdoc))) + (when hyperdoc-package + (multiple-value-bind (symbol foundp symbol-name package) + (parse-symbol string *buffer-package*) + (declare (ignore symbol)) + (when foundp + (funcall (find-symbol (string :lookup) hyperdoc-package) + (package-name (if (member package (cons *buffer-package* + (package-use-list + *buffer-package*))) + *buffer-package* + package)) + symbol-name)))))) + +(provide :swank-hyperdoc) diff --git a/elpa/slime-20200319.1939/contrib/swank-ikarus.ss b/elpa/slime-20200319.1939/contrib/swank-ikarus.ss new file mode 100644 index 00000000..e048446c --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-ikarus.ss @@ -0,0 +1,86 @@ +;; swank-larceny.scm --- Swank server for Ikarus +;; +;; License: Public Domain +;; Author: Helmut Eller +;; +;; In a shell execute: +;; ikarus swank-ikarus.ss +;; and then `M-x slime-connect' in Emacs. +;; + +(library (swank os) + (export getpid make-server-socket accept local-port close-socket) + (import (rnrs) + (only (ikarus foreign) make-c-callout dlsym dlopen + pointer-set-c-long! pointer-ref-c-unsigned-short + malloc free pointer-size) + (rename (only (ikarus ipc) tcp-server-socket accept-connection + close-tcp-server-socket) + (tcp-server-socket make-server-socket) + (close-tcp-server-socket close-socket)) + (only (ikarus) + struct-type-descriptor + struct-type-field-names + struct-field-accessor) + ) + + (define libc (dlopen)) + (define (cfun name return-type arg-types) + ((make-c-callout return-type arg-types) (dlsym libc name))) + + (define getpid (cfun "getpid" 'signed-int '())) + + (define (accept socket codec) + (let-values (((in out) (accept-connection socket))) + (values (transcoded-port in (make-transcoder codec)) + (transcoded-port out (make-transcoder codec))))) + + (define (socket-fd socket) + (let ((rtd (struct-type-descriptor socket))) + (do ((i 0 (+ i 1)) + (names (struct-type-field-names rtd) (cdr names))) + ((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket))))) + + (define sockaddr_in/size 16) + (define sockaddr_in/sin_family 0) + (define sockaddr_in/sin_port 2) + (define sockaddr_in/sin_addr 4) + + (define (local-port socket) + (let* ((fd (socket-fd socket)) + (addr (malloc sockaddr_in/size)) + (size (malloc (pointer-size)))) + (pointer-set-c-long! size 0 sockaddr_in/size) + (let ((code (getsockname fd addr size)) + (port (ntohs (pointer-ref-c-unsigned-short + addr sockaddr_in/sin_port)))) + (free addr) + (free size) + (cond ((= code -1) (error "getsockname failed")) + (#t port))))) + + (define getsockname + (cfun "getsockname" 'signed-int '(signed-int pointer pointer))) + + (define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short))) + + ) + + +(library (swank sys) + (export implementation-name eval-in-interaction-environment) + (import (rnrs) + (rnrs eval) + (only (ikarus) interaction-environment)) + + (define (implementation-name) "ikarus") + + (define (eval-in-interaction-environment form) + (eval form (interaction-environment))) + + ) + +(import (only (ikarus) load)) +(load "swank-r6rs.scm") +(import (swank)) +(start-server #f) diff --git a/elpa/slime-20200319.1939/contrib/swank-indentation.lisp b/elpa/slime-20200319.1939/contrib/swank-indentation.lisp new file mode 100644 index 00000000..67e638d5 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-indentation.lisp @@ -0,0 +1,140 @@ +(in-package :swank) + +(defvar *application-hints-tables* '() + "A list of hash tables mapping symbols to indentation hints (lists +of symbols and numbers as per cl-indent.el). Applications can add hash +tables to the list to change the auto indentation slime sends to +emacs.") + +(defun has-application-indentation-hint-p (symbol) + (let ((default (load-time-value (gensym)))) + (dolist (table *application-hints-tables*) + (let ((indentation (gethash symbol table default))) + (unless (eq default indentation) + (return-from has-application-indentation-hint-p + (values indentation t)))))) + (values nil nil)) + +(defun application-indentation-hint (symbol) + (let ((indentation (has-application-indentation-hint-p symbol))) + (labels ((walk (indentation-spec) + (etypecase indentation-spec + (null nil) + (number indentation-spec) + (symbol (string-downcase indentation-spec)) + (cons (cons (walk (car indentation-spec)) + (walk (cdr indentation-spec))))))) + (walk indentation)))) + +;;; override swank version of this function +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. + +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (cond + ((has-application-indentation-hint-p symbol) + (application-indentation-hint symbol)) + ((and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist))))) + (t nil))) + +;;; More complex version. +(defun macro-indentation (arglist) + (labels ((frob (list &optional base) + (if (every (lambda (x) + (member x '(nil "&rest") :test #'equal)) + list) + ;; If there was nothing interesting, don't return anything. + nil + ;; Otherwise substitute leading NIL's with 4 or 1. + (let ((ok t)) + (substitute-if (if base + 4 + 1) + (lambda (x) + (if (and ok (not x)) + t + (setf ok nil))) + list)))) + (walk (list level &optional firstp) + (when (consp list) + (let ((head (car list))) + (if (consp head) + (let ((indent (frob (walk head (+ level 1) t)))) + (cons (list* "&whole" (if (zerop level) + 4 + 1) + indent) (walk (cdr list) level))) + (case head + ;; &BODY is &BODY, this is clear. + (&body + '("&body")) + ;; &KEY is tricksy. If it's at the base level, we want + ;; to indent them normally: + ;; + ;; (foo bar quux + ;; :quux t + ;; :zot nil) + ;; + ;; If it's at a destructuring level, we want indent of 1: + ;; + ;; (with-foo (var arg + ;; :foo t + ;; :quux nil) + ;; ...) + (&key + (if (zerop level) + '("&rest" nil) + '("&rest" 1))) + ;; &REST is tricksy. If it's at the front of + ;; destructuring, we want to indent by 1, otherwise + ;; normally: + ;; + ;; (foo (bar quux + ;; zot) + ;; ...) + ;; + ;; but + ;; + ;; (foo bar quux + ;; zot) + (&rest + (if (and (plusp level) firstp) + '("&rest" 1) + '("&rest" nil))) + ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there + ;; at all. + ((&whole &environment) + (walk (cddr list) level firstp)) + ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker + ;; itself is not counted. + (&optional + (walk (cdr list) level)) + ;; Indent normally, walk the tail -- but + ;; unknown lambda-list keywords terminate the walk. + (otherwise + (unless (member head lambda-list-keywords) + (cons nil (walk (cdr list) level)))))))))) + (frob (walk arglist 0 t) t))) + +#+nil +(progn + (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") + (macro-indentation '(bar quux (&rest slots) &body body)))) + (assert (equal nil + (macro-indentation '(a b c &rest more)))) + (assert (equal '(4 4 4 "&body") + (macro-indentation '(a b c &body more)))) + (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") + (macro-indentation '((name zot &key foo bar) &body body)))) + (assert (equal nil + (macro-indentation '(x y &key z))))) + +(provide :swank-indentation) diff --git a/elpa/slime-20200319.1939/contrib/swank-jolt.k b/elpa/slime-20200319.1939/contrib/swank-jolt.k new file mode 100644 index 00000000..93e53abf --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-jolt.k @@ -0,0 +1,998 @@ +;;; swank-jolt.k --- Swank server for Jolt -*- goo -*- +;; +;; Copyright (C) 2008 Helmut Eller +;; +;; This file is licensed under the terms of the GNU General Public +;; License as distributed with Emacs (press C-h C-c for details). + +;;; Commentary: +;; +;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of +;; C, i.e. most objects are machine words and memory pointers. The +;; standard boot files define an interface to Id Smalltalk. So we can +;; also pretend to do OOP, but we must be careful to pass properly +;; tagged pointers to Smalltalk. +;; +;; This file only implements a minimum of SLIME's functionality. We +;; install a handler with atexit(3) to invoke the debugger. This way +;; we can stop Jolt from terminating the process on every error. +;; Unfortunately, the backtrace doesn't contain much information and +;; we also have no error message (other than the exit code). Jolt +;; usually prints some message to stdout before calling exit, so you +;; have to look in the *inferior-lisp* buffer for hints. We do +;; nothing (yet) to recover from SIGSEGV. + +;;; Installation +;; +;; 1. Download and build cola. See . +;; I used the svn version: +;; svn co http://piumarta.com/svn2/idst/trunk idst +;; 2. Add something like this to your .emacs: +;; +;; (add-to-list 'slime-lisp-implementations +;; '(jolt (".../idst/function/jolt-burg/main" +;; "boot.k" ".../swank-jolt.k" "-") ; note the "-" +;; :init jolt-slime-init +;; :init-function slime-redirect-inferior-output) +;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file))) +;; (defun jolt () (interactive) (slime 'jolt)) +;; +;; 3. Use `M-x jolt' to start it. +;; + +;;; Code + +;; In this file I use 2-3 letters for often used names, like DF or +;; VEC, even if those names are abbreviations. I think that after a +;; little getting used to, this style is just as readable as the more +;; traditional DEFUN and VECTOR. Shorter names make it easier to +;; write terse code, in particular 1-line definitions. + +;; `df' is like `defun' in a traditional lisp +(syntax df + (lambda (form compiler) + (printf "df %s ...\n" [[[form second] asString] _stringValue]) + `(define ,[form second] (lambda ,@[form copyFrom: '2])))) + +;; (! args ...) is the same as [args ...] but easier to edit. +(syntax ! + (lambda (form compiler) + (cond ((== [form size] '3) + (if [[form third] isSymbol] + `(send ',[form third] ,[form second]) + [compiler errorSyntax: [form third]])) + ((and [[form size] > '3] + (== [[form size] \\ '2] '0)) + (let ((args [OrderedCollection new]) + (keys [OrderedCollection new]) + (i '2) (len [form size])) + (while (< i len) + (let ((key [form at: i])) + (if (or [key isKeyword] + (and (== i '2) [key isSymbol])) ; for [X + Y] + [keys addLast: [key asString]] + [compiler errorSyntax: key])) + [args addLast: [form at: [i + '1]]] + (set i [i + '2])) + `(send ',[[keys concatenated] asSymbol] ,[form second] ,@args))) + (1 [compiler errorArgumentCount: form])))) + +(define Integer (import "Integer")) +(define Symbol (import "Symbol")) ;; aka. _selector +(define StaticBlockClosure (import "StaticBlockClosure")) +(define BlockClosure (import "BlockClosure")) +(define SequenceableCollection (import "SequenceableCollection")) +(define _vtable (import "_vtable")) +(define ByteArray (import "ByteArray")) +(define CodeGenerator (import "CodeGenerator")) +(define TheGlobalEnvironment (import "TheGlobalEnvironment")) + +(df error (msg) (! Object error: msg)) +(df print-to-string (obj) + (let ((len '200) + (stream (! WriteStream on: (! String new: len)))) + (! stream print: obj) + (! stream contents))) +(df assertion-failed (exp) + (error (! '"Assertion failed: " , (print-to-string exp)))) + +(syntax assert + (lambda (form) + `(if (not ,(! form second)) + (assertion-failed ',(! form second))))) + +(df isa? (obj type) (! obj isKindOf: type)) +(df equal (o1 o2) (! o1 = o2)) + +(define nil 0) +(define false 0) +(define true (! Object notNil)) +(df bool? (obj) (or (== obj false) (== obj true))) +(df int? (obj) (isa? obj Integer)) + +;; In this file the convention X>Y is used for operations that convert +;; X-to-Y. And _ means "machine word". So _>int is the operator that +;; converts a machine word to an Integer. + +(df _>int (word) (! Integer value_: word)) +(df int>_ (i) (! i _integerValue)) + +;; Fixnum operators. Manual tagging/untagging would probably be more +;; efficent than invoking methods. + +(df fix? (obj) (& obj 1)) +(df _>fix (n) (! SmallInteger value_: n)) +(df fix>_ (i) (! i _integerValue)) +(df fx+ (fx1 fx2) (! fx1 + fx2)) +(df fx* (fx1 fx2) (! fx1 * fx2)) +(df fx1+ (fx) (! fx + '1)) +(df fx1- (fx) (! fx - '1)) + +(df str? (obj) (isa? obj String)) +(df >str (o) (! o asString)) +(df str>_ (s) (! s _stringValue)) +(df _>str (s) (! String value_: s)) +(df sym? (obj) (isa? obj Symbol)) +(df seq? (obj) (isa? obj SequenceableCollection)) +(df array? (obj) (isa? obj Array)) +(df len (obj) (! obj size)) +(df len_ (obj) (! (! obj size) _integerValue)) +(df ref (obj idx) (! obj at: idx)) +(df set-ref (obj idx elt) (! obj at: idx put: elt)) +(df first (obj) (! obj first)) +(df second (obj) (! obj second)) + +(df puts (string stream) (! stream nextPutAll: string)) + +(define _GC_base (dlsym "GC_base")) + +;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows +;; such things. This is useful for debugging, because we can quite +;; safely (i.e. without provoking SIGSEGV) access such addresses. +(df valid-pointer? (addr) + (let ((ptr (& addr (~ 1)))) + (and (_GC_base ptr) + (_GC_base (long@ ptr -1))))) + +;; Print OBJ as a Lisp printer would do. +(df prin1 (obj stream) + (cond ((fix? obj) (! stream print: obj)) + ((== obj nil) (puts '"nil" stream)) + ((== obj false) (puts '"#f" stream)) + ((== obj true) (puts '"#t" stream)) + ((not (valid-pointer? obj)) + (begin (puts '"#int obj) stream) + (puts '">" stream))) + ((int? obj) (! stream print: obj)) + ((sym? obj) (puts (>str obj) stream)) + ((isa? obj StaticBlockClosure) + (begin (puts '"#" stream))) + ((and (str? obj) (len obj)) + (! obj printEscapedOn: stream delimited: (ref '"\"" '0))) + ((and (array? obj) (len obj)) + (begin (puts '"(" stream) + (let ((max (- (len_ obj) 1))) + (for (i 0 1 max) + (prin1 (ref obj (_>fix i)) stream) + (if (!= i max) + (puts '" " stream)))) + (puts '")" stream))) + ((and (isa? obj OrderedCollection) (len obj)) + (begin (puts '"#[" stream) + (let ((max (- (len_ obj) 1))) + (for (i 0 1 max) + (prin1 (ref obj (_>fix i)) stream) + (if (!= i max) + (puts '" " stream)))) + (puts '"]" stream))) + (true + (begin (puts '"#<" stream) + (puts (! obj debugName) stream) + (puts '">" stream)))) + obj) + +(df print (obj) + (prin1 obj StdOut) + (puts '"\n" StdOut)) + +(df prin1-to-string (obj) + (let ((len '100) + (stream (! WriteStream on: (! String new: len)))) + (prin1 obj stream) + (! stream contents))) + +;;(df %vable-tally (_vtable) (long@ _vtable)) +(df cr () (printf "\n")) +(df print-object-selectors (obj) + (let ((vtable (! obj _vtable)) + (tally (long@ vtable 0)) + (bindings (long@ vtable 1))) + (for (i 1 1 tally) + (print (long@ (long@ bindings i))) + (cr)))) + +(df print-object-slots (obj) + (let ((size (! obj _sizeof)) + (end (+ obj size))) + (while (< obj end) + (print (long@ obj)) + (cr) + (incr obj 4)))) + +(df intern (string) (! Symbol intern: string)) + +;; Jolt doesn't seem to have an equivalent for gensym, but it's damn +;; hard to write macros without it. So here we adopt the conventions +;; that symbols which look like ".[0-9]+" are reserved for gensym and +;; shouldn't be used for "user visible variables". +(define gensym-counter 0) +(df gensym () + (set gensym-counter (+ gensym-counter 1)) + (intern (! '"." , (>str (_>fix gensym-counter))))) + +;; Surprisingly, SequenceableCollection doesn't have a indexOf method. +;; So we even need to implement such mundane things. +(df index-of (seq elt) + (let ((max (len seq)) + (i '0)) + (while (! i < max) + (if (equal (ref seq i) elt) + (return i) + (set i (! i + '1)))) + nil)) + +(df find-dot (array) (index-of array '.)) + +;; What followes is the implementation of the pattern matching macro MIF. +;; The syntax is (mif (PATTERN EXP) THEN ELSE). +;; The THEN-branch is executed if PATTERN matches the value produced by EXP. +;; ELSE gets only executed if the match failes. +;; A pattern can be +;; 1) a symbol, which matches all values, but also binds the variable to the +;; value +;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL. +;; 3) (PS ...) matches sequences, if the elements match PS. +;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements +;; at indices 1..n and if Ptail matches the rest +;; of the sequence +;; Examples: +;; (mif (x 10) x 'else) => 10 +;; (mif ('a 'a) 'then 'else) => then +;; (mif ('a 'b) 'then 'else) => else +;; (mif ((a b) '(1 2)) b 'else) => 2 +;; (mif ((a . b) '(1 2)) b 'else) => '(2) +;; (mif ((. x) '(1 2)) x 'else) => '(1 2) + +(define mif% 0) ;; defer +(df mif%array (compiler pattern i value then fail) + ;;(print `(mif%array ,pattern ,i ,value)) + (cond ((== i (len_ pattern)) then) + ((== (ref pattern (_>fix i)) '.) + (begin + (if (!= (- (len_ pattern) 2) i) + (begin + (print pattern) + (! compiler error: (! '"dot in strange position: " + , (>str (_>fix i)))))) + (mif% compiler + (ref pattern (_>fix (+ i 1))) + `(! ,value copyFrom: ',(_>fix i)) + then fail))) + (true + (mif% compiler + (ref pattern (_>fix i)) + `(ref ,value ',(_>fix i)) + (mif%array compiler pattern (+ i 1) value then fail) + fail)))) + +(df mif% (compiler pattern value then fail) + ;;(print `(mif% ,pattern ,value ,then)) + (cond ((== pattern '_) then) + ((== pattern '.) (! compiler errorSyntax: pattern)) + ((sym? pattern) + `(let ((,pattern ,value)) ,then)) + ((seq? pattern) + (cond ((== (len_ pattern) 0) + `(if (== (len_ ,value) 0) ,then (goto ,fail))) + ((== (first pattern) 'quote) + (begin + (if (not (== (len_ pattern) 2)) + (! compiler errorSyntax: pattern)) + `(if (equal ,value ,pattern) ,then (goto ,fail)))) + (true + (let ((tmp (gensym)) (tmp2 (gensym)) + (pos (find-dot pattern))) + `(let ((,tmp2 ,value) + (,tmp ,tmp2)) + (if (and (seq? ,tmp) + ,(if (find-dot pattern) + `(>= (len ,tmp) + ',(_>fix (- (len_ pattern) 2))) + `(== (len ,tmp) ',(len pattern)))) + ,(mif%array compiler pattern 0 tmp then fail) + (goto ,fail))))))) + (true (! compiler errorSyntax: pattern)))) + +(syntax mif + (lambda (node compiler) + ;;(print `(mif ,node)) + (if (not (or (== (len_ node) 4) + (== (len_ node) 3))) + (! compiler errorArgumentCount: node)) + (if (not (and (array? (ref node '1)) + (== (len_ (ref node '1)) 2))) + (! compiler errorSyntax: (ref node '1))) + (let ((pattern (first (ref node '1))) + (value (second (ref node '1))) + (then (ref node '2)) + (else (if (== (len_ node) 4) + (ref node '3) + `(error "mif failed"))) + (destination (gensym)) + (fail (! compiler newLabel)) + (success (! compiler newLabel))) + `(let ((,destination 0)) + ,(mif% compiler pattern value + `(begin (set ,destination ,then) + (goto ,success)) + fail) + (label ,fail) + (set ,destination ,else) + (label ,success) + ,destination)))) + +;; (define *catch-stack* nil) +;; +(df bar (o) (mif ('a o) 'yes 'no)) +(assert (== (bar 'a) 'yes)) +(assert (== (bar 'b) 'no)) +(df foo (o) (mif (('a) o) 'yes 'no)) +(assert (== (foo '(a)) 'yes)) +(assert (== (foo '(b)) 'no)) +(df baz (o) (mif (('a 'b) o) 'yes 'no)) +(assert (== (baz '(a b)) 'yes)) +(assert (== (baz '(a c)) 'no)) +(assert (== (baz '(b c)) 'no)) +(assert (== (baz 'a) 'no)) +(df mifvar (o) (mif (y o) y 'no)) +(assert (== (mifvar 'foo) 'foo)) +(df mifvec (o) (mif ((y) o) y 'no)) +(assert (== (mifvec '(a)) 'a)) +(assert (== (mifvec 'x) 'no)) +(df mifvec2 (o) (mif (('a y) o) y 'no)) +(assert (== (mifvec2 '(a b)) 'b)) +(assert (== (mifvec2 '(b c)) 'no)) +(assert (== (mif ((x) '(a)) x 'no) 'a)) +(assert (== (mif ((x . y) '(a b)) x 'no) 'a)) +(assert (== (mif ((x y . z) '(a b)) y 'no) 'b)) +(assert (equal (mif ((x . y) '(a b)) y 'no) '(b))) +(assert (equal (mif ((. x) '(a b)) x 'no) '(a b))) +(assert (equal (mif (((. x)) '((a b))) x 'no) '(a b))) +(assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c))) +(assert (== (mif (() '()) 'yes 'no) 'yes)) +(assert (== (mif (() '(a)) 'yes 'no) 'no)) + +;; Now that we have a somewhat convenient pattern matcher we can write +;; a more convenient macro defining macro: +(syntax defmacro + (lambda (node compiler) + (mif (('defmacro name (. args) . body) node) + (begin + (printf "defmacro %s ...\n" (str>_ (>str name))) + `(syntax ,name + (lambda (node compiler) + (mif ((',name ,@args) node) + (begin ,@body) + (! compiler errorSyntax: node))))) + (! compiler errorSyntax: node)))) + +;; and an even more convenient pattern matcher: +(defmacro mcase (value . clauses) + (let ((tmp (gensym))) + `(let ((,tmp ,value)) + ,(mif (() clauses) + `(begin (print ,tmp) + (error "mcase failed")) + (mif (((pattern . body) . more) clauses) + `(mif (,pattern ,tmp) + (begin ,@(mif (() body) '(0) body)) + (mcase ,tmp ,@more)) + (! compiler errorSyntax: clauses)))))) + +;; and some traditional macros +(defmacro when (test . body) `(if ,test (begin ,@body))) +(defmacro unless (test . body) `(if ,test 0 (begin ,@body))) +(defmacro or (. args) ; the built in OR returns 1 on success. + (mcase args + (() 0) + ((e) e) + ((e1 . more) + (let ((tmp (gensym))) + `(let ((,tmp ,e1)) + (if ,tmp ,tmp (or ,@more))))))) + +(defmacro dotimes_ ((var n) . body) + (let ((tmp (gensym))) + `(let ((,tmp ,n) + (,var 0)) + (while (< ,var ,tmp) + ,@body + (set ,var (+ ,var 1)))))) + +(defmacro dotimes ((var n) . body) + (let ((tmp (gensym))) + `(let ((,tmp ,n) + (,var '0)) + (while (< ,var ,tmp) + ,@body + (set ,var (fx1+ ,var)))))) + +;; DOVEC is like the traditional DOLIST but works on "vectors" +;; i.e. sequences which can be indexed efficently. +(defmacro dovec ((var seq) . body) + (let ((i (gensym)) + (max (gensym)) + (tmp (gensym))) + `(let ((,i 0) + (,tmp ,seq) + (,max (len_ ,tmp))) + (while (< ,i ,max) + (let ((,var (! ,tmp at: (_>fix ,i)))) + ,@body + (set ,i (+ ,i 1))))))) + +;; "Packing" is what Lispers usually call "collecting". +;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result)) +;; translates to (packing (result) .. (pack x result)) +(defmacro packing ((var) . body) + `(let ((,var (! OrderedCollection new))) + ,@body + (! ,var asArray))) + +(df pack (elt packer) (! packer addLast: elt)) + +(assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p))) + '(0 1))) + +(assert (equal (packing (p) (dovec (e '(2 3)) (pack e p))) + '(2 3))) + +(assert (equal (packing (p) + (let ((a '(2 3))) + (dotimes (i (len a)) + (pack (ref a i) p)))) + '(2 3))) + +;; MAPCAR (more or less) +(df map (fun col) + (packing (r) + (dovec (e col) + (pack (fun e) r)))) + +;; VEC allocates and initializes a new array. +;; The macro translates (vec x y z) to `(,x ,y ,z). +(defmacro vec (. args) + `(quasiquote + (,@(map (lambda (arg) `(,'unquote ,arg)) + args)))) + +(assert (equal (vec '0 '1) '(0 1))) +(assert (equal (vec) '())) +(assert (== (len (vec 0 1 2 3 4)) '5)) + +;; Concatenate. +(defmacro cat (. args) `(! (vec '"" ,@args) concatenated)) + +(assert (equal (cat '"a" '"b" '"c") '"abc")) + +;; Take a vector of bytes and copy the bytes to a continuous +;; block of memory +(df assemble_ (col) (! (! ByteArray withAll: col) _bytes)) + +;; Jolt doesn't seem to have catch/throw or something equivalent. +;; Here I use a pair of assembly routines as substitue. +;; (catch% FUN) calls FUN with the current stack pointer. +;; (throw% VALUE K) unwinds the stack to K and then returns VALUE. +;; catch% is a bit like call/cc. +;; +;; [Would setjmp/longjmp work from Jolt? or does setjmp require +;; C-compiler magic?] +;; [I figure Smalltalk has a way to do non-local-exits but, I don't know +;; how to use that in Jolt.] +;; +(define catch% + (assemble_ + '(0x55 ; push %ebp + 0x89 0xe5 ; mov %esp,%ebp + 0x54 ; push %esp + 0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax + 0xff 0xd0 ; call *%eax + 0xc9 ; leave + 0xc3 ; ret + ))) + +(define throw% + (assemble_ + `(,@'() + 0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax + 0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp + 0xc9 ; leave + 0xc3 ; ret + ))) + +(df bar (i k) + (if (== i 0) + (throw% 100 k) + (begin + (printf "bar %d\n" i) + (bar (- i 1) k)))) +(df foo (k) + (printf "foo.1\n") + (printf "foo.2 %d\n" (bar 10 k))) + +;; Our way to produce closures: we compile a new little function which +;; hardcodes the addresses of the code resp. the data-vector. The +;; nice thing is that such closures can be used called C function +;; pointers. It's probably slow to invoke the compiler for such +;; things, so use with care. +(df make-closure (addr state) + (int>_ + (! `(lambda (a b c d) + (,(_>int addr) ,(_>int state) a b c d)) + eval))) + +;; Return a closure which calls FUN with ARGS and the arguments +;; that the closure was called with. +;; Example: ((curry printf "%d\n") 10) +(defmacro curry (fun . args) + `(make-closure + (lambda (state a b c d) + ((ref state '0) + ,@(packing (sv) + (dotimes (i (len args)) + (pack `(ref state ',(fx1+ i)) sv))) + a b c d)) + (vec ,fun ,@args))) + +(df parse-closure-arglist (vars) + (let ((pos (or (index-of vars '|) + (return nil))) + (cvars (! vars copyFrom: '0 to: (fx1- pos))) + (lvars (! vars copyFrom: (fx1+ pos)))) + (vec cvars lvars))) + +;; Create a closure, to-be-closed-over variables must enumerated +;; explicitly. +;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4. +;; The variables before the "|" are captured by the closure. +(defmacro closure ((. vars) . body) + (mif ((cvars lvars) (parse-closure-arglist vars)) + `(curry (lambda (,@cvars ,@lvars) ,@body) + ,@cvars) + (! compiler errorSyntax: vars))) + +;; The analog for Smalltalkish "blocks". +(defmacro block ((. vars) . body) + (mif ((cvars lvars) (parse-closure-arglist vars)) + `(! StaticBlockClosure + function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body) + ,@cvars) + arity_: ,(len lvars)) + (! compiler errorSyntax: vars))) + +(define %mkstemp (dlsym "mkstemp")) +(df make-temp-file () + (let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy)) + (fd (%mkstemp (! name _stringValue)))) + (if (== fd -1) + (error "mkstemp failed")) + `(,fd ,name))) +(define %unlink (dlsym "unlink")) +(df unlink (filename) (%unlink (! filename _stringValue))) + +(define write (dlsym "write")) +(df write-bytes (addr count fd) + (let ((written (write fd addr count))) + (if (!= written count) + (begin + (printf "write failed %p %d %d => %d" addr count fd written) + (error '"write failed"))))) + +(define system (dlsym "system")) +(define main (dlsym "main")) + +;; Starting at address ADDR, disassemble COUNT bytes. +;; This is implemented by writing the memory region to a file +;; and call ndisasm on it. +(df disas (addr count) + (let ((fd+name (make-temp-file))) + (write-bytes addr count (first fd+name)) + (let ((cmd (str>_ (cat '"ndisasm -u -o " + (>str (_>fix addr)) + '" " (second fd+name))))) + (printf "Running: %s\n" cmd) + (system cmd)) + (unlink (second fd+name)))) + +(df rep () + (let ((result (! (! CokeScanner read: StdIn) eval))) + (puts '"=> " StdOut) + (print result) + (puts '"\n" StdOut))) + +;; Perhaps we could use setcontext/getcontext to return from signal +;; handlers (or not). +(define +ucontext-size+ 350) +(define _getcontext (dlsym "getcontext")) +(define _setcontext (dlsym "setcontext")) +(df getcontext () + (let ((context (malloc 350))) + (_getcontext context) + context)) + +(define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why? + +(define *top-level-restart* 0) +(define *top-level-context* 0) +(define *debugger-hook* 0) + +;; Jolt's error handling strategy is charmingly simple: call exit. +;; We invoke the SLIME debugger from an exit handler. +;; (The handler is registered with atexit, that's a libc function.) + +(df exit-handler (reason arg) + (printf "exit-handler 0x%x\n" reason) + ;;(backtrace) + (on_exit exit-handler nil) + (when *debugger-hook* + (*debugger-hook* `(exit ,reason))) + (cond (*top-level-context* + (_setcontext *top-level-context*)) + (*top-level-restart* + (throw% reason *top-level-restart*)))) + +(df repl () + (set *top-level-context* (getcontext)) + (while (not (! (! StdIn readStream) atEnd)) + (printf "top-level\n") + (catch% + (lambda (k) + (set *top-level-restart* k) + (printf "repl\n") + (while 1 + (rep))))) + (printf "EOF\n")) + +;; (repl) + + +;;; Socket code. (How boring. Duh, should have used netcat instead.) + +(define strerror (dlsym "strerror")) + +(df check-os-code (value) + (if (== value -1) + (error (_>str (strerror (fix>_ (! OS errno))))) + value)) + +;; For now just hard-code constants which usually reside in header +;; files (just like a Forth guy would do). +(define PF_INET 2) +(define SOCK_STREAM 1) +(define SOL_SOCKET 1) +(define SO_REUSEADDR 2) +(define socket (dlsym "socket")) +(define setsockopt (dlsym "setsockopt")) + +(df set-reuse-address (sock value) + (let ((word-size 4) + (val (! Object _balloc: (_>fix word-size)))) + (set-int@ val value) + (check-os-code + (setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size)))) + +(define sockaddr_in/size 16) +(define sockaddr_in/sin_family 0) +(define sockaddr_in/sin_port 2) +(define sockaddr_in/sin_addr 4) +(define INADDR_ANY 0) +(define AF_INET 2) +(define htons (dlsym "htons")) +(define bind (dlsym "bind")) + +(df bind-socket (sock port) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))) + (set-short@ (+ addr sockaddr_in/sin_family) AF_INET) + (set-short@ (+ addr sockaddr_in/sin_port) (htons port)) + (set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY) + (check-os-code + (bind sock addr sockaddr_in/size)))) + +(define listen (dlsym "listen")) + +(df create-socket (port) + (let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0)))) + (set-reuse-address sock 1) + (bind-socket sock port) + (check-os-code (listen sock 1)) + sock)) + +(define accept% (dlsym "accept")) +(df accept (sock) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) + (len (! OS _balloc: 4))) + (set-int@ len sockaddr_in/size) + (check-os-code (accept% sock addr len)))) + +(define getsockname (dlsym "getsockname")) +(define ntohs (dlsym "ntohs")) +(df local-port (sock) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) + (len (! OS _balloc: 4))) + (set-int@ len sockaddr_in/size) + (check-os-code + (getsockname sock addr len)) + (ntohs (short@ (+ addr sockaddr_in/sin_port))))) + +(define close (dlsym "close")) +(define _read (dlsym "read")) + +;; Now, after 2/3 of the file we can begin with the actual Swank +;; server. + +(df read-string (fd count) + (let ((buffer (! String new: count)) + (buffer_ (str>_ buffer)) + (count_ (int>_ count)) + (start 0)) + (while (> (- count_ start) 0) + (let ((rcount (check-os-code (_read fd + (+ buffer_ start) + (- count_ start))))) + (set start (+ start rcount)))) + buffer)) + +;; Read and parse a message from the wire. +(df read-packet (fd) + (let ((header (read-string fd '6)) + (length (! Integer fromString: header base: '16)) + (payload (read-string fd length))) + (! CokeScanner read: payload))) + +;; Print a messag to the wire. +(df send-to-emacs (event fd) + (let ((stream (! WriteStream on: (! String new: '100)))) + (! stream position: '6) + (prin1 event stream) + (let ((len (! stream position))) + (! stream position: '0) + (! (fx+ len '-6) printOn: stream base: '16 width: '6) + (write-bytes (str>_ (! stream collection)) (int>_ len) fd)))) + +(df add-quotes (form) + (mcase form + ((fun . args) + `(,fun ,@(packing (s) + (dovec (e args) + (pack `(quote ,e) s))))))) + +(define sldb 0) ;defer + +(df eval-for-emacs (form id fd abort) + (let ((old-hook *debugger-hook*)) + (mcase (catch% + (closure (form fd | k) + (set *debugger-hook* (curry sldb fd k)) + `(ok ,(int>_ (! (add-quotes form) eval))))) + (('ok value) + (set *debugger-hook* old-hook) + (send-to-emacs `(:return (:ok ,value) ,id) fd) + 'ok) + (arg + (set *debugger-hook* old-hook) + (send-to-emacs `(:return (:abort) ,id) fd) + (throw% arg abort))))) + +(df process-events (fd) + (on_exit exit-handler nil) + (let ((done nil)) + (while (not done) + (mcase (read-packet fd) + ((':emacs-rex form package thread id) + (mcase (catch% (closure (form id fd | abort) + (eval-for-emacs form id fd abort))) + ('ok) + ;;('abort nil) + ('top-level) + (other + ;;(return other) ; compiler breaks with return + (set done 1)))))))) + +(df next-frame (fp) + (let ((next (get-caller-fp fp))) + (if (and (!= next fp) + (<= next %top-level-fp)) + next + nil))) + +(df nth-frame (n top) + (let ((fp top) + (i 0)) + (while fp + (if (== i n) (return fp)) + (set fp (next-frame fp)) + (set i (+ i 1))) + nil)) + +(define Dl_info/size 16) +(define Dl_info/dli_fname 0) +(define Dl_info/dli_sname 8) + +(df get-dl-sym-name (addr) + (let ((info (! OS _balloc: (_>fix Dl_info/size)))) + (when (== (dladdr addr info) 0) + (return nil)) + (let ((sname (long@ (+ info Dl_info/dli_sname)) ) + (fname (long@ (+ info Dl_info/dli_fname)))) + (cond ((and sname fname) + (cat (_>str sname) '" in " (_>str fname))) + (sname (_>str fname)) + (fname (cat '" " (_>str fname))) + (true nil))))) + +;;(get-dl-sym-name printf) + +(df guess-function-name (ip) + (let ((fname (get-function-name ip))) + (if fname + (_>str fname) + (get-dl-sym-name ip)))) + +(df backtrace>el (top_ from_ to_) + (let ((fp (nth-frame from_ top_)) + (i from_)) + (packing (bt) + (while (and fp (< i to_)) + (let ((ip (get-frame-ip fp))) + (pack (vec (_>int i) + (cat (or (guess-function-name ip) '"(no-name)") + '" " ;;(>str (_>int ip)) + )) + bt)) + (set i (+ i 1)) + (set fp (next-frame fp)))))) + +(df debugger-info (fp msg) + (vec `(,(prin1-to-string msg) " [type ...]" ()) + '(("quit" "Return to top level")) + (backtrace>el fp 0 20) + '())) + +(define *top-frame* 0) +(define *sldb-quit* 0) + +(df debugger-loop (fd args abort) + (let ((fp (get-current-fp))) + (set *top-frame* fp) + (send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd) + (while 1 + (mcase (read-packet fd) + ((':emacs-rex form package thread id) + (mcase (catch% (closure (form id fd | k) + (set *sldb-quit* k) + (eval-for-emacs form id fd k) + 'ok)) + ('ok nil) + (other + (send-to-emacs `(:return (:abort) ,id) fd) + (throw% other abort)))))))) + +(df sldb (fd abort args) + (let ((old-top-frame *top-frame*) + (old-sldb-quit *sldb-quit*)) + (mcase (catch% (curry debugger-loop fd args)) + (value + (set *top-frame* old-top-frame) + (set *sldb-quit* old-sldb-quit) + (send-to-emacs `(:debug-return 0 1 nil) fd) + (throw% value abort))))) + +(df swank:backtrace (start end) + (backtrace>el *top-frame* (int>_ start) (int>_ end))) + +(df sldb-quit () + (assert *sldb-quit*) + (throw% 'top-level *sldb-quit*)) + +(df swank:invoke-nth-restart-for-emacs (...) (sldb-quit)) +(df swank:throw-to-toplevel (...) (sldb-quit)) + +(df setup-server (port announce) + (let ((sock (create-socket port))) + (announce sock) + (let ((client (accept sock))) + (process-events client) + (close client)) + (printf "Closing socket: %d %d\n" sock (local-port sock)) + (close sock))) + +(df announce-port (sock) + (printf "Listening on port: %d\n" (local-port sock))) + +(df create-server (port) (setup-server port announce-port)) + +(df write-port-file (filename sock) + (let ((f (! File create: filename))) + (! f write: (print-to-string (_>int (local-port sock)))) + (! f close))) + +(df start-swank (port-file) + (setup-server 0 (curry write-port-file (_>str port-file)))) + +(define getpid (dlsym "getpid")) +(df swank:connection-info () + `(,@'() + :pid ,(_>int (getpid)) + :style nil + :lisp-implementation (,@'() + :type "Coke" + :name "jolt" + :version ,(! CodeGenerator versionString)) + :machine (:instance "" :type ,(! OS architecture) :version "") + :features () + :package (:name "jolt" :prompt "jolt"))) + +(df swank:listener-eval (string) + (let ((result (! (! CokeScanner read: string) eval))) + `(:values ,(prin1-to-string (if (or (fix? result) + (and (valid-pointer? result) + (int? result))) + (int>_ result) + result)) + ,(prin1-to-string result)))) + +(df swank:interactive-eval (string) + (let ((result (! (! CokeScanner read: string) eval))) + (cat '"=> " (prin1-to-string (if (or (fix? result) + (and (valid-pointer? result) + (int? result))) + (int>_ result) + result)) + '", " (prin1-to-string result)))) + +(df swank:operator-arglist () nil) +(df swank:buffer-first-change () nil) +(df swank:create-repl (_) '("jolt" "jolt")) + +(df min (x y) (if (<= x y) x y)) + +(df common-prefix2 (e1 e2) + (let ((i '0) + (max (min (len e1) (len e2)))) + (while (and (< i max) + (== (ref e1 i) (ref e2 i))) + (set i (fx1+ i))) + (! e1 copyFrom: '0 to: (fx1- i)))) + +(df common-prefix (seq) + (mcase seq + (() nil) + (_ + (let ((prefix (ref seq '0))) + (dovec (e seq) + (set prefix (common-prefix2 prefix e))) + prefix)))) + +(df swank:simple-completions (prefix _package) + (let ((matches (packing (s) + (dovec (e (! TheGlobalEnvironment keys)) + (let ((name (>str e))) + (when (! name beginsWith: prefix) + (pack name s))))))) + (vec matches (or (common-prefix matches) prefix)))) + + +;; swank-jolt.k ends here diff --git a/elpa/slime-20200319.1939/contrib/swank-kawa.scm b/elpa/slime-20200319.1939/contrib/swank-kawa.scm new file mode 100644 index 00000000..3dd9c07a --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-kawa.scm @@ -0,0 +1,2504 @@ +;;;; swank-kawa.scm --- Swank server for Kawa +;;; +;;; Copyright (C) 2007 Helmut Eller +;;; +;;; This file is licensed under the terms of the GNU General Public +;;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation +;; +;; 1. You need Kawa (version 2.x) and a JVM with debugger support. +;; +;; 2. Compile this file and create swank-kawa.jar with: +;; java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \ +;; -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm && +;; jar cf swank-kawa.jar -C classes . +;; +;; 3. Add something like this to your .emacs: +#| +;; Kawa, Swank, and the debugger classes (tools.jar) must be in the +;; classpath. You also need to start the debug agent. +(setq slime-lisp-implementations + '((kawa + ("java" + ;; needed jar files + "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar" + ;; channel for debugger + "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n" + ;; depending on JVM, compiler may need more stack + "-Xss2M" + ;; kawa without GUI + "kawa.repl" "-s") + :init kawa-slime-init))) + +(defun kawa-slime-init (file _) + (setq slime-protocol-version 'ignore) + (format "%S\n" + `(begin (import (swank-kawa)) + (start-swank ,file) + ;; Optionally add source paths of your code so + ;; that M-. works better: + ;;(set! swank-java-source-path + ;; (append + ;; '(,(expand-file-name "~/lisp/slime/contrib/") + ;; "/scratch/kawa") + ;; swank-java-source-path)) + ))) + +;; Optionally define a command to start it. +(defun kawa () + (interactive) + (slime 'kawa)) + +|# +;; 4. Start everything with M-- M-x slime kawa +;; +;; + + +;;; Code: + +(define-library (swank macros) + (export df fun seq set fin esc + ! !! !s @ @s + when unless while dotimes dolist for packing with pushf == assert + mif mcase mlet mlet* typecase ignore-errors + ferror + ) + (import (scheme base) + (only (kawa base) + syntax + quasisyntax + syntax-case + define-syntax-case + identifier? + + invoke + invoke-static + field + static-field + instance? + try-finally + try-catch + primitive-throw + + format + reverse! + as + )) + (begin " +(" + +(define (ferror fstring #!rest args) + (let ((err ( + (as (apply format fstring args))))) + (primitive-throw err))) + +(define (rewrite-lambda-list args) + (syntax-case args () + (() #`()) + ((rest x ...) (eq? #'rest #!rest) args) + ((optional x ...) (eq? #'optional #!optional) args) + ((var args ...) (identifier? #'var) + #`(var #,@(rewrite-lambda-list #'(args ...)))) + (((var type) args ...) (identifier? #'var) + #`((var :: type) #,@(rewrite-lambda-list #'(args ...)))))) + +(define-syntax df + (lambda (stx) + (syntax-case stx (=>) + ((df name (args ... => return-type) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type + (seq body ...))) + ((df name (args ...) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) + (seq body ...)))))) + +(define-syntax fun + (lambda (stx) + (syntax-case stx (=>) + ((fun (args ... => return-type) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type + (seq body ...))) + ((fun (args ...) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) + (seq body ...)))))) + +(define-syntax fin + (syntax-rules () + ((fin body handler ...) + (try-finally body (seq handler ...))))) + +(define-syntax seq + (syntax-rules () + ((seq) + (begin #!void)) + ((seq body ...) + (begin body ...)))) + +(define-syntax esc + (syntax-rules () + ((esc abort body ...) + (let* ((key ()) + (abort (lambda (val) (throw key val)))) + (catch key + (lambda () body ...) + (lambda (key val) val)))))) + +(define-syntax ! + (syntax-rules () + ((! name obj args ...) + (invoke obj 'name args ...)))) + +(define-syntax !! + (syntax-rules () + ((!! name1 name2 obj args ...) + (! name1 (! name2 obj args ...))))) + +(define-syntax !s + (syntax-rules () + ((! class name args ...) + (invoke-static class 'name args ...)))) + +(define-syntax @ + (syntax-rules () + ((@ name obj) + (field obj 'name)))) + +(define-syntax @s + (syntax-rules (quote) + ((@s class name) + (static-field class (quote name))))) + +(define-syntax while + (syntax-rules () + ((while exp body ...) + (do () ((not exp)) body ...)))) + +(define-syntax dotimes + (syntax-rules () + ((dotimes (i n result) body ...) + (let ((max :: n)) + (do ((i :: 0 (as (+ i 1)))) + ((= i max) result) + body ...))) + ((dotimes (i n) body ...) + (dotimes (i n #f) body ...)))) + +(define-syntax dolist + (syntax-rules () + ((dolist (e list) body ... ) + (for ((e list)) body ...)))) + +(define-syntax for + (syntax-rules () + ((for ((var iterable)) body ...) + (let ((iter (! iterator iterable))) + (while (! has-next iter) + ((lambda (var) body ...) + (! next iter))))))) + +(define-syntax packing + (syntax-rules () + ((packing (var) body ...) + (let ((var :: '())) + (let ((var (lambda (v) (set! var (cons v var))))) + body ...) + (reverse! var))))) + +;;(define-syntax loop +;; (syntax-rules (for = then collect until) +;; ((loop for var = init then step until test collect exp) +;; (packing (pack) +;; (do ((var init step)) +;; (test) +;; (pack exp)))) +;; ((loop while test collect exp) +;; (packing (pack) (while test (pack exp)))))) + +(define-syntax with + (syntax-rules () + ((with (vars ... (f args ...)) body ...) + (f args ... (lambda (vars ...) body ...))))) + +(define-syntax pushf + (syntax-rules () + ((pushf value var) + (set! var (cons value var))))) + +(define-syntax == + (syntax-rules () + ((== x y) + (eq? x y)))) + +(define-syntax set + (syntax-rules () + ((set x y) + (let ((tmp y)) + (set! x tmp) + tmp)) + ((set x y more ...) + (begin (set! x y) (set more ...))))) + +(define-syntax assert + (syntax-rules () + ((assert test) + (seq + (when (not test) + (error "Assertion failed" 'test)) + 'ok)) + ((assert test fstring args ...) + (seq + (when (not test) + (error "Assertion failed" 'test (format #f fstring args ...))) + 'ok)))) + +(define-syntax mif + (syntax-rules (quote unquote _) + ((mif ('x value) then else) + (if (equal? 'x value) then else)) + ((mif (,x value) then else) + (if (eq? x value) then else)) + ((mif (() value) then else) + (if (eq? value '()) then else)) + #| This variant produces no lambdas but breaks the compiler + ((mif ((p . ps) value) then else) + (let ((tmp value) + (fail? :: 0) + (result #!null)) + (if (instance? tmp ) + (let ((tmp :: tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + (set! result then) + (set! fail? -1)) + (set! fail? -1))) + (set! fail? -1)) + (if (= fail? 0) result else))) + |# + ((mif ((p . ps) value) then else) + (let ((fail (lambda () else)) + (tmp value)) + (if (instance? tmp ) + (let ((tmp :: tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + then + (fail)) + (fail))) + (fail)))) + ((mif (_ value) then else) + then) + ((mif (var value) then else) + (let ((var value)) then)) + ((mif (pattern value) then) + (mif (pattern value) then (values))))) + +(define-syntax mcase + (syntax-rules () + ((mcase exp (pattern body ...) more ...) + (let ((tmp exp)) + (mif (pattern tmp) + (begin body ...) + (mcase tmp more ...)))) + ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp exp)))) + +(define-syntax mlet + (syntax-rules () + ((mlet (pattern value) body ...) + (let ((tmp value)) + (mif (pattern tmp) + (begin body ...) + (error "mlet failed" tmp)))))) + +(define-syntax mlet* + (syntax-rules () + ((mlet* () body ...) (begin body ...)) + ((mlet* ((pattern value) ms ...) body ...) + (mlet (pattern value) (mlet* (ms ...) body ...))))) + +(define-syntax typecase% + (syntax-rules (eql or satisfies) + ((typecase% var (#t body ...) more ...) + (seq body ...)) + ((typecase% var ((eql value) body ...) more ...) + (cond ((eqv? var 'value) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((satisfies predicate) body ...) more ...) + (cond ((predicate var) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((or type) body ...) more ...) + (typecase% var (type body ...) more ...)) + ((typecase% var ((or type ...) body ...) more ...) + (let ((f (lambda (var) body ...))) + (typecase% var + (type (f var)) ... + (#t (typecase% var more ...))))) + ((typecase% var (type body ...) more ...) + (cond ((instance? var type) + (let ((var :: type (as type var))) + body ...)) + (else (typecase% var more ...)))) + ((typecase% var) + (error "typecase% failed" var + (! getClass (as var)))))) + +(define-syntax typecase + (lambda (stx) + (syntax-case stx () + ((_ exp more ...) (identifier? (syntax exp)) + #`(typecase% exp more ...)) + ((_ exp more ...) + #`(let ((tmp exp)) + (typecase% tmp more ...)))))) + +(define-syntax ignore-errors + (syntax-rules () + ((ignore-errors body ...) + (try-catch (seq body ...) + (v #f) + (v #f))))) + +)) + +(define-library (swank-kawa) + (export start-swank + create-swank-server + swank-java-source-path + break) + (import (scheme base) + (scheme file) + (scheme repl) + (scheme read) + (scheme write) + (scheme eval) + (scheme process-context) + (swank macros) + (only (kawa base) + + define-alias + define-variable + + define-simple-class + this + + invoke-special + instance? + as + + primitive-throw + try-finally + try-catch + synchronized + + call-with-input-string + call-with-output-string + force-output + format + + make-process + command-parse + + runnable + + scheme-implementation-version + reverse! + ) + (rnrs hashtables) + (only (gnu kawa slib syntaxutils) expand) + (only (kawa regex) regex-match)) + (begin " +(" + + +;;(define-syntax dc +;; (syntax-rules () +;; ((dc name () %% (props ...) prop more ...) +;; (dc name () %% (props ... (prop )) more ...)) +;; ;;((dc name () %% (props ...) (prop type) more ...) +;; ;; (dc name () %% (props ... (prop type)) more ...)) +;; ((dc name () %% ((prop type) ...)) +;; (define-simple-class name () +;; ((*init* (prop :: type) ...) +;; (set (field (this) 'prop) prop) ...) +;; (prop :type type) ...)) +;; ((dc name () props ...) +;; (dc name () %% () props ...)))) + + +;;;; Aliases + +(define-alias java.net.ServerSocket) +(define-alias java.net.Socket) +(define-alias java.io.InputStreamReader) +(define-alias java.io.OutputStreamWriter) +(define-alias gnu.kawa.io.InPort) +(define-alias gnu.kawa.io.OutPort) +(define-alias java.io.File) +(define-alias java.lang.String) +(define-alias java.lang.StringBuilder) +(define-alias java.lang.Throwable) +(define-alias gnu.text.SourceError) +(define-alias gnu.expr.ModuleInfo) +(define-alias java.lang.Iterable) +(define-alias java.lang.Thread) +(define-alias java.util.concurrent.LinkedBlockingQueue) +(define-alias java.util.concurrent.Exchanger) +(define-alias java.util.concurrent.TimeUnit) +(define-alias com.sun.jdi.VirtualMachine) +(define-alias com.sun.jdi.Mirror) +(define-alias com.sun.jdi.Value) +(define-alias com.sun.jdi.ThreadReference) +(define-alias com.sun.jdi.ObjectReference) +(define-alias com.sun.jdi.ArrayReference) +(define-alias com.sun.jdi.StringReference) +(define-alias com.sun.jdi.Method) +(define-alias com.sun.jdi.ClassType) +(define-alias com.sun.jdi.ReferenceType) +(define-alias com.sun.jdi.StackFrame) +(define-alias com.sun.jdi.Field) +(define-alias com.sun.jdi.LocalVariable) +(define-alias com.sun.jdi.Location) +(define-alias com.sun.jdi.AbsentInformationException) +(define-alias com.sun.jdi.event.Event) +(define-alias com.sun.jdi.event.ExceptionEvent) +(define-alias com.sun.jdi.event.StepEvent) +(define-alias com.sun.jdi.event.BreakpointEvent) +(define-alias gnu.mapping.Environment) + +(define-simple-class () + (owner :: #:init (!s java.lang.Thread currentThread)) + (peer :: ) + (queue :: #:init ()) + (lock #:init ())) + + +;;;; Entry Points + +(df create-swank-server (port-number) + (setup-server port-number announce-port)) + +(df start-swank (port-file) + (let ((announce (fun ((socket )) + (with (f (call-with-output-file port-file)) + (format f "~d\n" (! get-local-port socket)))))) + (spawn (fun () + (setup-server 0 announce))))) + +(df setup-server ((port-number ) announce) + (! set-name (current-thread) "swank") + (let ((s ( port-number))) + (announce s) + (let ((c (! accept s))) + (! close s) + (log "connection: ~s\n" c) + (fin (dispatch-events c) + (log "closing socket: ~a\n" s) + (! close c))))) + +(df announce-port ((socket )) + (log "Listening on port: ~d\n" (! get-local-port socket))) + + +;;;; Event dispatcher + +(define-variable *the-vm* #f) +(define-variable *last-exception* #f) +(define-variable *last-stacktrace* #f) +(df %vm (=> ) *the-vm*) + +;; FIXME: this needs factorization. But I guess the whole idea of +;; using bidirectional channels just sucks. Mailboxes owned by a +;; single thread to which everybody can send are much easier to use. + +(df dispatch-events ((s )) + (mlet* ((charset "iso-8859-1") + (ins ( (! getInputStream s) charset)) + (outs ( (! getOutputStream s) charset)) + ((in . _) (spawn/chan/catch (fun (c) (reader ins c)))) + ((out . _) (spawn/chan/catch (fun (c) (writer outs c)))) + ((dbg . _) (spawn/chan/catch vm-monitor)) + (user-env (interaction-environment)) + (x (seq + (! set-flag user-env #t #|:THREAD_SAFE|# 8) + (! set-flag user-env #f #|:DIRECT_INHERITED_ON_SET|# 16) + #f)) + ((listener . _) + (spawn/chan (fun (c) (listener c user-env)))) + (inspector #f) + (threads '()) + (repl-thread #f) + (extra '()) + (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm))))))) + (while #t + (mlet ((c . event) (recv* (append (list in out dbg listener) + (if inspector (list inspector) '()) + (map car threads) + extra))) + ;;(log "event: ~s\n" event) + (mcase (list c event) + ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to) + pkg thread id)) + (send dbg `(debug-info ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id)) + (send dbg `(throw-to-toplevel ,thread ,id))) + ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id)) + (send dbg `(thread-continue ,thread ,id))) + ((_ (':emacs-rex ('|swank:frame-source-location| frame) + pkg thread id)) + (send dbg `(frame-src-loc ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame) + pkg thread id)) + (send dbg `(frame-details ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:sldb-disassemble| frame) + pkg thread id)) + (send dbg `(disassemble-frame ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id)) + (send dbg `(thread-frames ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id)) + (send dbg `(list-threads ,id))) + ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _)) + (send dbg `(debug-nth-thread ,n))) + ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id)) + (send dbg `(quit-thread-browser ,id))) + ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id)) + (set inspector (make-inspector user-env (vm))) + (send inspector `(init ,str ,id))) + ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var) + pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-local ,ex ,thread ,frame ,var)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-exception ,ex ,thread)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id)) + (send inspector `(inspect-part ,n ,id))) + ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id)) + (send inspector `(pop ,id))) + ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id)) + (send inspector `(quit ,id))) + ((_ (':emacs-interrupt id)) + (let* ((vm (vm)) + (t (find-thread id (map cdr threads) repl-thread vm))) + (send dbg `(interrupt-thread ,t)))) + ((_ (':emacs-rex form _ _ id)) + (send listener `(,form ,id))) + ((_ ('get-vm c)) + (send dbg `(get-vm ,c))) + ((_ ('get-channel c)) + (mlet ((im . ex) (chan)) + (pushf im extra) + (send c ex))) + ((_ ('forward x)) + (send out x)) + ((_ ('set-listener x)) + (set repl-thread x)) + ((_ ('publish-vm vm)) + (set *the-vm* vm)) + ))))) + +(df find-thread (id threads listener (vm )) + (cond ((== id ':repl-thread) listener) + ((== id 't) listener + ;;(if (null? threads) + ;; listener + ;; (vm-mirror vm (car threads))) + ) + (#t + (let ((f (find-if threads + (fun (t :: ) + (= id (! uniqueID + (as (vm-mirror vm t))))) + #f))) + (cond (f (vm-mirror vm f)) + (#t listener)))))) + + +;;;; Reader thread + +(df reader ((in ) (c )) + (! set-name (current-thread) "swank-net-reader") + (let ((rt (!s gnu.kawa.lispexpr.ReadTable createInitial))) ; ':' not special + (while #t + (send c (decode-message in rt))))) + +(df decode-message ((in ) (rt ) => ) + (let* ((header (read-chunk in 6)) + (len (!s java.lang.Integer parseInt header 16))) + (call-with-input-string (read-chunk in len) + (fun ((port )) + (%read port rt))))) + +(df read-chunk ((in ) (len ) => ) + (let ((chars ( #:length len))) + (let loop ((offset :: 0)) + (cond ((= offset len) ( chars)) + (#t (let ((count (! read in chars offset (- len offset)))) + (assert (not (= count -1)) "partial packet") + (loop (+ offset count)))))))) + +;;; FIXME: not thread safe +(df %read ((port ) (table )) + (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent))) + (try-finally + (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table) + (read port)) + (!s gnu.kawa.lispexpr.ReadTable setCurrent old)))) + + +;;;; Writer thread + +(df writer ((out ) (c )) + (! set-name (current-thread) "swank-net-writer") + (while #t + (encode-message out (recv c)))) + +(df encode-message ((out ) (message )) + (let ((builder ( (as 512)))) + (print-for-emacs message builder) + (! write out (! toString (format "~6,'0x" (! length builder)))) + (! write out builder) + (! flush out))) + +(df print-for-emacs (obj (out )) + (let ((pr (fun (o) (! append out (! toString (format "~s" o))))) + (++ (fun ((s )) (! append out (! toString s))))) + (cond ((null? obj) (++ "nil")) + ((string? obj) (pr obj)) + ((number? obj) (pr obj)) + ;;((keyword? obj) (++ ":") (! append out (to-str obj))) + ((symbol? obj) (pr obj)) + ((pair? obj) + (++ "(") + (let loop ((obj obj)) + (print-for-emacs (car obj) out) + (let ((cdr (cdr obj))) + (cond ((null? cdr) (++ ")")) + ((pair? cdr) (++ " ") (loop cdr)) + (#t (++ " . ") (print-for-emacs cdr out) (++ ")")))))) + (#t (error "Unprintable object" obj))))) + +;;;; SLIME-EVAL + +(df eval-for-emacs ((form ) env (id ) (c )) + ;;(! set-uncaught-exception-handler (current-thread) + ;; ( (fun (t e) (reply-abort c id)))) + (reply c (%eval form env) id)) + +(define-variable *slime-funs*) +(set *slime-funs* (tab)) + +(df %eval (form env) + (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form))) + +(df lookup-slimefun ((name ) tab) + ;; name looks like '|swank:connection-info| + (or (get tab name #f) + (ferror "~a not implemented" name))) + +(df %defslimefun ((name ) (fun )) + (let ((string (symbol->string name))) + (cond ((regex-match #/:/ string) + (put *slime-funs* name fun)) + (#t + (let ((qname (string->symbol (string-append "swank:" string)))) + (put *slime-funs* qname fun)))))) + +(define-syntax defslimefun + (syntax-rules () + ((defslimefun name (args ...) body ...) + (seq + (df name (args ...) body ...) + (%defslimefun 'name name))))) + +(defslimefun connection-info ((env )) + (let ((prop (fun (name) (!s java.lang.System getProperty name)))) + `(:pid + 0 + :style :spawn + :lisp-implementation (:type "Kawa" :name "kawa" + :version ,(scheme-implementation-version)) + :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name") + :version ,(prop "java.runtime.version")) + :features () + :package (:name "??" :prompt ,(! getName env)) + :encoding (:coding-systems ("iso-8859-1")) + ))) + + +;;;; Listener + +(df listener ((c ) (env )) + (! set-name (current-thread) "swank-listener") + (log "listener: ~s ~s ~s ~s\n" + (current-thread) (! hashCode (current-thread)) c env) + (let ((out (make-swank-outport (rpc c `(get-channel))))) + (set (current-output-port) out) + (let ((vm (as (rpc c `(get-vm))))) + (send c `(set-listener ,(vm-mirror vm (current-thread)))) + (request-uncaught-exception-events vm) + ;;stack snaphost are too expensive + ;;(request-caught-exception-events vm) + ) + (rpc c `(get-vm)) + (listener-loop c env out))) + +(define-simple-class () + ((*init*) + (invoke-special (this) '*init* )) + ((abort) :: void + (primitive-throw (this)))) + +(df listener-loop ((c ) (env ) port) + (while (not (nul? c)) + ;;(log "listener-loop: ~s ~s\n" (current-thread) c) + (mlet ((form id) (recv c)) + (let ((restart (fun () + (close-port port) + (reply-abort c id) + (send (car (spawn/chan + (fun (cc) + (listener (recv cc) env)))) + c) + (set c #!null)))) + (! set-uncaught-exception-handler (current-thread) + ( (fun (t e) (restart)))) + (try-catch + (let* ((val (%eval form env))) + (force-output) + (reply c val id)) + (ex (invoke-debugger ex) (restart)) + (ex (invoke-debugger ex) (restart)) + (ex + (let ((flag (!s java.lang.Thread interrupted))) + (log "listener-abort: ~s ~a\n" ex flag)) + (restart)) + ))))) + +(df invoke-debugger (condition) + ;;(log "should now invoke debugger: ~a" condition) + (try-catch + (break condition) + (ex (seq)))) + +(defslimefun |swank-repl:create-repl| (env #!rest _) + (list "user" "user")) + +(defslimefun interactive-eval (env str) + (values-for-echo-area (eval (read-from-string str) env))) + +(defslimefun interactive-eval-region (env (s )) + (with (port (call-with-input-string s)) + (values-for-echo-area + (let next ((result (values))) + (let ((form (read port))) + (cond ((== form #!eof) result) + (#t (next (eval form env))))))))) + +(defslimefun |swank-repl:listener-eval| (env string) + (let* ((form (read-from-string string)) + (list (values-to-list (eval form env)))) + `(:values ,@(map pprint-to-string list)))) + +(defslimefun pprint-eval (env string) + (let* ((form (read-from-string string)) + (l (values-to-list (eval form env)))) + (apply cat (map pprint-to-string l)))) + +(defslimefun eval-and-grab-output (env string) + (let ((form (read (open-input-string string)))) + (let-values ((values (eval form env))) + (list "" + (format #f "~{~S~^~%~}" values))))) + +(df call-with-abort (f) + (try-catch (f) (ex (exception-message ex)))) + +(df exception-message ((ex )) + (typecase ex + ( (! to-string ex)) + ( (format "~a: ~a" + (class-name-sans-package ex) + (! getMessage ex))))) + +(df values-for-echo-area (values) + (let ((values (values-to-list values))) + (cond ((null? values) "; No value") + (#t (format "~{~a~^, ~}" (map pprint-to-string values)))))) + +;;;; Compilation + +(defslimefun compile-file-for-emacs (env (filename ) load? + #!optional options) + (let ((jar (cat (path-sans-extension (filepath filename)) ".jar"))) + (wrap-compilation + (fun ((m )) + (!s kawa.lang.CompileFile read filename m)) + jar (if (lisp-bool load?) env #f) #f))) + +(df wrap-compilation (f jar env delete?) + (let ((start-time (current-time)) + (messages ())) + (try-catch + (let ((c (as (f messages)))) + (set (@ explicit c) #t) + (! compile-to-archive c (! get-module c) jar)) + (ex + (log "error during compilation: ~a\n~a" ex (! getStackTrace ex)) + (! error messages (as #\f) + (to-str (exception-message ex)) #!null) + #f)) + (log "compilation done.\n") + (let ((success? (zero? (! get-error-count messages)))) + (when (and env success?) + (log "loading ...\n") + (eval `(load ,jar) env) + (log "loading ... done.\n")) + (when delete? + (ignore-errors (delete-file jar) #f)) + (let ((end-time (current-time))) + (list ':compilation-result + (compiler-notes-for-emacs messages) + (if success? 't 'nil) + (/ (- end-time start-time) 1000.0)))))) + +(defslimefun compile-string-for-emacs (env string buffer offset dir) + (wrap-compilation + (fun ((m )) + (let ((c (as + (call-with-input-string + string + (fun ((p )) + (! set-path p + (format "~s" + `(buffer ,buffer offset ,offset str ,string))) + (!s kawa.lang.CompileFile read p m)))))) + (let ((o (@ currentOptions c))) + (! set o "warn-invoke-unknown-method" #t) + (! set o "warn-undefined-variable" #t)) + (let ((m (! getModule c))) + (! set-name m (format ":~a/~a" buffer (current-time)))) + c)) + "/tmp/kawa-tmp.zip" env #t)) + +(df compiler-notes-for-emacs ((messages )) + (packing (pack) + (do ((e (! get-errors messages) (@ next e))) + ((nul? e)) + (pack (source-error>elisp e))))) + +(df source-error>elisp ((e ) => ) + (list ':message (to-string (@ message e)) + ':severity (case (integer->char (@ severity e)) + ((#\e #\f) ':error) + ((#\w) ':warning) + (else ':note)) + ':location (error-loc>elisp e))) + +(df error-loc>elisp ((e )) + (cond ((nul? (@ filename e)) `(:error "No source location")) + ((! starts-with (@ filename e) "(buffer ") + (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s) + (read-from-string (@ filename e))) + (let ((off (line>offset (1- (@ line e)) s)) + (col (1- (@ column e)))) + `(:location (:buffer ,b) (:position ,(+ o off col)) nil)))) + (#t + `(:location (:file ,(to-string (@ filename e))) + (:line ,(@ line e) ,(1- (@ column e))) + nil)))) + +(df line>offset ((line ) (s ) => ) + (let ((offset :: 0)) + (dotimes (i line) + (set offset (! index-of s (as #\newline) offset)) + (assert (>= offset 0)) + (set offset (as (+ offset 1)))) + (log "line=~a offset=~a\n" line offset) + offset)) + +(defslimefun load-file (env filename) + (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env))) + +;;;; Completion + +(defslimefun simple-completions (env (pattern ) _) + (let* ((env (as env)) + (matches (packing (pack) + (let ((iter (! enumerate-all-locations env))) + (while (! has-next iter) + (let ((l (! next-location iter))) + (typecase l + ( + (let ((name (!! get-name get-key-symbol l))) + (when (! starts-with name pattern) + (pack name))))))))))) + `(,matches ,(cond ((null? matches) pattern) + (#t (fold+ common-prefix matches)))))) + +(df common-prefix ((s1 ) (s2 ) => ) + (let ((limit (min (! length s1) (! length s2)))) + (let loop ((i 0)) + (cond ((or (= i limit) + (not (== (! char-at s1 i) + (! char-at s2 i)))) + (! substring s1 0 i)) + (#t (loop (1+ i))))))) + +(df fold+ (f list) + (let loop ((s (car list)) + (l (cdr list))) + (cond ((null? l) s) + (#t (loop (f s (car l)) (cdr l)))))) + +;;; Quit + +(defslimefun quit-lisp (env) + (exit)) + +;;(defslimefun set-default-directory (env newdir)) + + +;;;; Dummy defs + +(defslimefun buffer-first-change (#!rest y) '()) +(defslimefun swank-require (#!rest y) '()) +(defslimefun frame-package-name (#!rest y) '()) + +;;;; arglist + +(defslimefun operator-arglist (env name #!rest _) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex 'nil)) + (('ok obj) + (mcase (arglist obj) + ('#f 'nil) + ((args rtype) + (format "(~a~{~^ ~a~})~a" name + (map (fun (e) + (if (equal (cadr e) "java.lang.Object") (car e) e)) + args) + (if (equal rtype "java.lang.Object") + "" + (format " => ~a" rtype)))))) + (_ 'nil))) + +(df arglist (obj) + (typecase obj + ( + (let* ((mref (module-method>meth-ref obj))) + (list (mapi (! arguments mref) + (fun ((v )) + (list (! name v) (! typeName v)))) + (! returnTypeName mref)))) + ( #f))) + +;;;; M-. + +(defslimefun find-definitions-for-emacs (env name) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex `(error ,(exception-message ex)))) + (('ok obj) (mapi (all-definitions obj) + (fun (d) + `(,(format "~a" d) ,(src-loc>elisp (src-loc d)))))) + (('error msg) `((,name (:error ,msg)))))) + +(define-simple-class () + (file #:init #f) + (line #:init #f) + ((*init* file name) + (set (@ file (this)) file) + (set (@ line (this)) line)) + ((lineNumber) :: (or line (absent))) + ((lineNumber (s :: )) :: int (! lineNumber (this))) + ((method) :: (absent)) + ((sourcePath) :: (or file (absent))) + ((sourcePath (s :: )) :: (! sourcePath (this))) + ((sourceName) :: (absent)) + ((sourceName (s :: )) :: (! sourceName (this))) + ((declaringType) :: (absent)) + ((codeIndex) :: -1) + ((virtualMachine) :: *the-vm*) + ((compareTo o) :: + (typecase o + ( (- (! codeIndex (this)) (! codeIndex o)))))) + +(df absent () (primitive-throw ())) + +(df all-definitions (o) + (typecase o + ( (list o)) + ( (list o)) + ( (append (mappend all-definitions (gf-methods o)) + (let ((s (! get-setter o))) + (if s (all-definitions s) '())))) + ( (list o)) + ( (all-definitions (! get-class o))) + ( (list o)) + ( (all-definitions (! getReflectClass o))) + ( '()) + )) + +(df gf-methods ((f )) + (let* ((o :: (vm-mirror *the-vm* f)) + (f (! field-by-name (! reference-type o) "methods")) + (ms (vm-demirror *the-vm* (! get-value o f)))) + (filter (array-to-list ms) (fun (x) (not (nul? x)))))) + +(df src-loc (o => ) + (typecase o + ( (src-loc (@ method o))) + ( (module-method>src-loc o)) + ( ( #f #f)) + ( (class>src-loc o)) + ( ( #f #f)) + ( (bytemethod>src-loc o)))) + +(df module-method>src-loc ((f )) + (! location (module-method>meth-ref f))) + +(df module-method>meth-ref ((f ) => ) + (let* ((module (! reference-type + (as (vm-mirror *the-vm* (@ module f))))) + (1st-method-by-name (fun (name) + (let ((i (! methods-by-name module name))) + (cond ((! is-empty i) #f) + (#t (1st i))))))) + (as (or (1st-method-by-name (! get-name f)) + (let ((mangled (mangled-name f))) + (or (1st-method-by-name mangled) + (1st-method-by-name (cat mangled "$V")) + (1st-method-by-name (cat mangled "$X")))))))) + +(df mangled-name ((f )) + (let* ((name0 (! get-name f)) + (name (cond ((nul? name0) (format "lambda~d" (@ selector f))) + (#t (!s gnu.expr.Compilation mangleName name0))))) + name)) + +(df class>src-loc ((c ) => ) + (let* ((type (class>ref-type c)) + (locs (! all-line-locations type))) + (cond ((not (! isEmpty locs)) (1st locs)) + (#t ( (1st (! source-paths type "Java")) + #f))))) + +(df class>ref-type ((class ) => ) + (! reflectedType (as + (vm-mirror *the-vm* class)))) + +(df class>class-type ((class ) => ) + (as (class>ref-type class))) + +(df bytemethod>src-loc ((m ) => ) + (let* ((cls (class>class-type (! get-reflect-class + (! get-declaring-class m)))) + (name (! get-name m)) + (sig (! get-signature m)) + (meth (! concrete-method-by-name cls name sig))) + (! location meth))) + +(df src-loc>elisp ((l )) + (df src-loc>list ((l )) + (list (ignore-errors (! source-name l "Java")) + (ignore-errors (! source-path l "Java")) + (ignore-errors (! line-number l "Java")))) + (mcase (src-loc>list l) + ((name path line) + (cond ((not path) + `(:error ,(call-with-abort (fun () (! source-path l))))) + ((! starts-with (as path) "(buffer ") + (mlet (('buffer b 'offset o 'str s) (read-from-string path)) + `(:location (:buffer ,b) + (:position ,(+ o (line>offset line s))) + nil))) + (#t + `(:location ,(or (find-file-in-path name (source-path)) + (find-file-in-path path (source-path)) + (ferror "Can't find source-path: ~s ~s ~a" + path name (source-path))) + (:line ,(or line -1)) ())))))) + +(df src-loc>str ((l )) + (cond ((nul? l) "") + (#t (format "~a ~a ~a" + (or (ignore-errors (! source-path l)) + (ignore-errors (! source-name l)) + (ignore-errors (!! name declaring-type l))) + (ignore-errors (!! name method l)) + (ignore-errors (! lineNumber l)))))) + +;;;;;; class-path hacking + +;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path)) + +(df find-file-in-path ((filename ) (path )) + (let ((f ( filename))) + (cond ((! isAbsolute f) `(:file ,filename)) + (#t (let ((result #f)) + (find-if path (fun (dir) + (let ((x (find-file-in-dir f dir))) + (set result x))) + #f) + result))))) + +(df find-file-in-dir ((file ) (dir )) + (let ((filename :: (! getPath file))) + (or (let ((child ( ( dir) filename))) + (and (! exists child) + `(:file ,(! getPath child)))) + (try-catch + (and (not (nul? (! getEntry ( dir) filename))) + `(:zip ,dir ,filename)) + (ex #f))))) + +(define swank-java-source-path + (let* ((jre-home :: (!s getProperty "java.home")) + (parent :: (! get-parent ( jre-home)))) + (list (! get-path ( parent "src.zip"))))) + +(df source-path () + (mlet ((base) (search-path-prop "user.dir")) + (append + (list base) + (map (fun ((s )) + (let ((f ( s)) + (base :: (as base))) + (cond ((! isAbsolute f) s) + (#t (! getPath ( base s)))))) + (class-path)) + swank-java-source-path))) + +(df class-path () + (append (search-path-prop "java.class.path") + (search-path-prop "sun.boot.class.path"))) + +(df search-path-prop ((name )) + (array-to-list (! split (!s java.lang.System getProperty name) + (@s pathSeparator)))) + +;;;; Disassemble + +(defslimefun disassemble-form (env form) + (mcase (read-from-string form) + (('quote name) + (let ((f (eval name env))) + (typecase f + ( + (disassemble-to-string (module-method>meth-ref f)))))))) + +(df disassemble-to-string ((mr ) => ) + (with-sink #f (fun (out) (disassemble-meth-ref mr out)))) + +(df disassemble-meth-ref ((mr ) (out )) + (let* ((t (! declaring-type mr))) + (disas-header mr out) + (disas-code (! constant-pool t) + (! constant-pool-count t) + (! bytecodes mr) + out))) + +(df disas-header ((mr ) (out )) + (let* ((++ (fun ((str )) (! write out str))) + (? (fun (flag str) (if flag (++ str))))) + (? (! is-static mr) "static ") + (? (! is-final mr) "final ") + (? (! is-private mr) "private ") + (? (! is-protected mr) "protected ") + (? (! is-public mr) "public ") + (++ (! name mr)) (++ (! signature mr)) (++ "\n"))) + +(df disas-code ((cpool ) (cpoolcount ) (bytecode ) + (out )) + (let* ((ct ( "foo")) + (met (! addMethod ct "bar" 0)) + (ca ( met)) + (constants (let* ((bs ()) + (s ( bs))) + (! write-short s cpoolcount) + (! write s cpool) + (! flush s) + (! toByteArray bs)))) + (vm-set-slot *the-vm* ct "constants" + ( + ( + ( + constants)))) + (! setCode ca bytecode) + (let ((w ( ct out 0))) + (! print ca w) + (! flush w)))) + +(df with-sink (sink (f )) + (cond ((instance? sink ) (f sink)) + ((== sink #t) (f (as (current-output-port)))) + ((== sink #f) + (let* ((buffer ()) + (out ( buffer))) + (f out) + (! flush out) + (! toString buffer))) + (#t (ferror "Invalid sink designator: ~s" sink)))) + +(df test-disas ((c ) (m )) + (let* ((vm (as *the-vm*)) + (c (as (1st (! classes-by-name vm c)))) + (m (as (1st (! methods-by-name c m))))) + (with-sink #f (fun (out) (disassemble-meth-ref m out))))) + +;; (test-disas "java.lang.Class" "toString") + + +;;;; Macroexpansion + +(defslimefun swank-expand-1 (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand-all (env s) (%swank-macroexpand s env)) + +(df %swank-macroexpand (string env) + (pprint-to-string (%macroexpand (read-from-string string) env))) + +(df %macroexpand (sexp env) (expand sexp #:env env)) + + +;;;; Inspector + +(define-simple-class () + (object #:init #!null) + (parts :: #:init () ) + (stack :: #:init '()) + (content :: #:init '())) + +(df make-inspector (env (vm ) => ) + (car (spawn/chan (fun (c) (inspector c env vm))))) + +(df inspector ((c ) env (vm )) + (! set-name (current-thread) "inspector") + (let ((state :: ()) + (open #t)) + (while open + (mcase (recv c) + (('init str id) + (set state ()) + (let ((obj (try-catch (eval (read-from-string str) env) + (ex ex)))) + (reply c (inspect-object obj state vm) id))) + (('init-mirror cc id) + (set state ()) + (let* ((mirror (recv cc)) + (obj (vm-demirror vm mirror))) + (reply c (inspect-object obj state vm) id))) + (('inspect-part n id) + (let ((part (! get (@ parts state) n))) + (reply c (inspect-object part state vm) id))) + (('pop id) + (reply c (inspector-pop state vm) id)) + (('quit id) + (reply c 'nil id) + (set open #f)))))) + +(df inspect-object (obj (state ) (vm )) + (set (@ object state) obj) + (set (@ parts state) ()) + (pushf obj (@ stack state)) + (set (@ content state) (inspector-content + `("class: " (:value ,(! getClass obj)) "\n" + ,@(inspect obj vm)) + state)) + (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `())) + (#t + (list ':title (pprint-to-string obj) + ':id (assign-index obj state) + ':content (let ((c (@ content state))) + (content-range c 0 (len c))))))) + +(df inspect (obj vm) + (let ((obj (as (vm-mirror vm obj)))) + (typecase obj + ( (inspect-array-ref vm obj)) + ( (inspect-obj-ref vm obj))))) + +(df inspect-array-ref ((vm ) (obj )) + (packing (pack) + (let ((i 0)) + (for (((v :: ) (! getValues obj))) + (pack (format "~d: " i)) + (pack `(:value ,(vm-demirror vm v))) + (pack "\n") + (set i (1+ i)))))) + +(df inspect-obj-ref ((vm ) (obj )) + (let* ((type (! referenceType obj)) + (fields (! allFields type)) + (values (! getValues obj fields)) + (ifields '()) (sfields '()) (imeths '()) (smeths '()) + (frob (lambda (lists) (apply append (reverse lists))))) + (for (((f :: ) fields)) + (let* ((val (as (! get values f))) + (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n"))) + (if (! is-static f) + (pushf l sfields) + (pushf l ifields)))) + (for (((m :: ) (! allMethods type))) + (let ((l `(,(! name m) ,(! signature m) "\n"))) + (if (! is-static m) + (pushf l smeths) + (pushf l imeths)))) + `(,@(frob ifields) + "--- static fields ---\n" ,@(frob sfields) + "--- methods ---\n" ,@(frob imeths) + "--- static methods ---\n" ,@(frob smeths)))) + +(df inspector-content (content (state )) + (map (fun (part) + (mcase part + ((':value val) + `(:value ,(pprint-to-string val) ,(assign-index val state))) + (x (to-string x)))) + content)) + +(df assign-index (obj (state ) => ) + (! add (@ parts state) obj) + (1- (! size (@ parts state)))) + +(df content-range (l start end) + (let* ((len (length l)) (end (min len end))) + (list (subseq l start end) len start end))) + +(df inspector-pop ((state ) vm) + (cond ((<= 2 (len (@ stack state))) + (let ((obj (cadr (@ stack state)))) + (set (@ stack state) (cddr (@ stack state))) + (inspect-object obj state vm))) + (#t 'nil))) + +;;;; IO redirection + +(define-simple-class () + (q :: #:init ( (as 100))) + ((*init*) (invoke-special (this) '*init*)) + ((write (buffer :: ) (from :: ) (to :: )) :: + (synchronized (this) + (assert (not (== q #!null))) + (! put q `(write ,( buffer from to))))) + ((close) :: + (synchronized (this) + (! put q 'close) + (set! q #!null))) + ((flush) :: + (synchronized (this) + (assert (not (== q #!null))) + (let ((ex ())) + (! put q `(flush ,ex)) + (! exchange ex #!null))))) + +(df swank-writer ((in ) (q )) + (! set-name (current-thread) "swank-redirect-thread") + (let* ((out (as (recv in))) + (builder ()) + (flush (fun () + (unless (zero? (! length builder)) + (send out `(forward (:write-string ,( builder)))) + (! setLength builder 0)))) + (closed #f)) + (while (not closed) + (mcase (! poll q (as long 200) (@s MILLISECONDS)) + ('#!null (flush)) + (('write s) + (! append builder (as s)) + (when (> (! length builder) 4000) + (flush))) + (('flush ex) + (flush) + (! exchange (as ex) #!null)) + ('close + (set closed #t) + (flush)))))) + +(df make-swank-outport ((out )) + (let ((w ())) + (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w))))) + (send in out)) + ( w #t #t))) + + +;;;; Monitor + +;;(define-simple-class () +;; (threadmap type: (tab))) + +(df vm-monitor ((c )) + (! set-name (current-thread) "swank-vm-monitor") + (let ((vm (vm-attach))) + (log-vm-props vm) + (request-breakpoint vm) + (mlet* (((ev . _) (spawn/chan/catch + (fun (c) + (let ((q (! eventQueue vm))) + (while #t + (send c `(vm-event ,(to-list (! remove q))))))))) + (to-string (vm-to-string vm)) + (state (tab))) + (send c `(publish-vm ,vm)) + (while #t + (mcase (recv* (list c ev)) + ((_ . ('get-vm cc)) + (send cc vm)) + ((,c . ('debug-info thread from to id)) + (reply c (debug-info thread from to state) id)) + ((,c . ('throw-to-toplevel thread id)) + (set state (throw-to-toplevel thread id c state))) + ((,c . ('thread-continue thread id)) + (set state (thread-continue thread id c state))) + ((,c . ('frame-src-loc thread frame id)) + (reply c (frame-src-loc thread frame state) id)) + ((,c . ('frame-details thread frame id)) + (reply c (list (frame-locals thread frame state) '()) id)) + ((,c . ('disassemble-frame thread frame id)) + (reply c (disassemble-frame thread frame state) id)) + ((,c . ('thread-frames thread from to id)) + (reply c (thread-frames thread from to state) id)) + ((,c . ('list-threads id)) + (reply c (list-threads vm state) id)) + ((,c . ('interrupt-thread ref)) + (set state (interrupt-thread ref state c))) + ((,c . ('debug-nth-thread n)) + (let ((t (nth (get state 'all-threads #f) n))) + ;;(log "thread ~d : ~a\n" n t) + (set state (interrupt-thread t state c)))) + ((,c . ('quit-thread-browser id)) + (reply c 't id) + (set state (del state 'all-threads))) + ((,ev . ('vm-event es)) + ;;(log "vm-events: len=~a\n" (len es)) + (for (((e :: ) (as es))) + (set state (process-vm-event e c state)))) + ((_ . ('get-exception from tid)) + (mlet ((_ _ es) (get state tid #f)) + (send from (let ((e (car es))) + (typecase e + ( (! exception e)) + ( e)))))) + ((_ . ('get-local rc tid frame var)) + (send rc (frame-local-var tid frame var state))) + ))))) + +(df reply ((c ) value id) + (send c `(forward (:return (:ok ,value) ,id)))) + +(df reply-abort ((c ) id) + (send c `(forward (:return (:abort nil) ,id)))) + +(df process-vm-event ((e ) (c ) state) + ;;(log "vm-event: ~s\n" e) + (typecase e + ( + ;;(log "exception: ~s\n" (! exception e)) + ;;(log "exception-message: ~s\n" + ;; (exception-message (vm-demirror *the-vm* (! exception e)))) + ;;(log "exception-location: ~s\n" (src-loc>str (! location e))) + ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e))) + (cond ((! notifyUncaught (as + (! request e))) + (process-exception e c state)) + (#t + (let* ((t (! thread e)) + (r (! request e)) + (ex (! exception e))) + (unless (eq? *last-exception* ex) + (set *last-exception* ex) + (set *last-stacktrace* (copy-stack t))) + (! resume t)) + state))) + ( + (let* ((r (! request e)) + (k (! get-property r 'continuation))) + (! disable r) + (log "k: ~s\n" k) + (k e)) + state) + ( + (log "breakpoint event: ~a\n" e) + (debug-thread (! thread e) e state c)) + )) + +(df process-exception ((e ) (c ) state) + (let* ((tref (! thread e)) + (tid (! uniqueID tref)) + (s (get state tid #f))) + (mcase s + ('#f + ;; XXX redundant in debug-thread + (let* ((level 1) + (state (put state tid (list tref level (list e))))) + (send c `(forward (:debug ,tid ,level + ,@(debug-info tid 0 15 state)))) + (send c `(forward (:debug-activate ,tid ,level))) + state)) + ((_ level exs) + (send c `(forward (:debug-activate ,(! uniqueID tref) ,level))) + (put state tid (list tref (1+ level) (cons e exs))))))) + +(define-simple-class () + (loc :: ) + (args) + (names) + (values :: ) + (self) + ((*init* (loc :: ) args names (values :: ) self) + (set (@ loc (this)) loc) + (set (@ args (this)) args) + (set (@ names (this)) names) + (set (@ values (this)) values) + (set (@ self (this)) self)) + ((toString) :: + (format "#" (src-loc>str loc)))) + +(df copy-stack ((t )) + (packing (pack) + (iter (! frames t) + (fun ((f )) + (let ((vars (ignore-errors (! visibleVariables f)))) + (pack ( + (or (ignore-errors (! location f)) #!null) + (ignore-errors (! getArgumentValues f)) + (or vars #!null) + (or (and vars (ignore-errors (! get-values f vars))) + #!null) + (ignore-errors (! thisObject f))))))))) + +(define-simple-class () + (thread :: ) + ((*init* (thread :: )) (set (@ thread (this)) thread)) + ((request) :: #!null) + ((virtualMachine) :: (! virtualMachine thread))) + +(df break (#!optional condition) + ((breakpoint condition))) + +;; We set a breakpoint on this function. It returns a function which +;; specifies what the debuggee should do next (the actual return value +;; is set via JDI). Lets hope that the compiler doesn't optimize this +;; away. +(df breakpoint (condition => ) + (fun () #!null)) + +;; Enable breakpoints event on the breakpoint function. +(df request-breakpoint ((vm )) + (let* ((swank-classes (! classesByName vm "swank-kawa")) + (swank-classes-legacy (! classesByName vm "swank$Mnkawa")) + (class :: (1st (if (= (length swank-classes) 0) + swank-classes-legacy + swank-classes))) + (meth :: (1st (! methodsByName class "breakpoint"))) + (erm (! eventRequestManager vm)) + (req (! createBreakpointRequest erm (! location meth)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! put-property req 'swank #t) + (! put-property req 'argname "condition") + (! enable req))) + +(df log-vm-props ((vm )) + (letrec-syntax ((p (syntax-rules () + ((p name) (log "~s: ~s\n" 'name (! name vm))))) + (p* (syntax-rules () + ((p* n ...) (seq (p n) ...))))) + (p* canBeModified + canRedefineClasses + canAddMethod + canUnrestrictedlyRedefineClasses + canGetBytecodes + canGetConstantPool + canGetSyntheticAttribute + canGetSourceDebugExtension + canPopFrames + canForceEarlyReturn + canGetMethodReturnValues + canGetInstanceInfo + ))) + +;;;;; Debugger + +(df debug-thread ((tref ) (ev ) state (c )) + (unless (! is-suspended tref) + (! suspend tref)) + (let* ((id (! uniqueID tref)) + (level 1) + (state (put state id (list tref level (list ev))))) + (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state)))) + (send c `(forward (:debug-activate ,id ,level))) + state)) + +(df interrupt-thread ((tref ) state (c )) + (debug-thread tref ( tref) state c)) + +(df debug-info ((tid ) (from ) to state) + (mlet ((thread-ref level evs) (get state tid #f)) + (let* ((tref (as thread-ref)) + (vm (! virtualMachine tref)) + (ev (as (car evs))) + (ex (typecase ev + ( (breakpoint-condition ev)) + ( (! exception ev)) + ( ( "Interrupt")))) + (desc (typecase ex + ( + ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex)) + (! toString (vm-demirror vm ex))) + ( (! toString ex)))) + (type (format " [type ~a]" + (typecase ex + ( (! name (! referenceType ex))) + ( (!! getName getClass ex))))) + (bt (thread-frames tid from to state))) + `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ())))) + +(df breakpoint-condition ((e ) => ) + (let ((frame (! frame (! thread e) 0))) + (1st (! get-argument-values frame)))) + +(df thread-frames ((tid ) (from ) to state) + (mlet ((thread level evs) (get state tid #f)) + (let* ((thread (as thread)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (fstart (max (- from missing) 0)) + (flen (max (- to from missing) 0)) + (frames (! frames thread fstart (min flen (- fcount fstart))))) + (packing (pack) + (let ((i from)) + (dotimes (_ (max (- missing from) 0)) + (pack (list i (format "~a" (stacktrace i)))) + (set i (1+ i))) + (iter frames (fun ((f )) + (let ((s (frame-to-string f))) + (pack (list i s)) + (set i (1+ i)))))))))) + +(df event-stacktrace ((ev )) + (let ((nothing (fun () ())) + (vm (! virtualMachine ev))) + (typecase ev + ( + (let ((condition (vm-demirror vm (breakpoint-condition ev)))) + (cond ((instance? condition ) + (throwable-stacktrace vm condition)) + (#t (nothing))))) + ( + (throwable-stacktrace vm (vm-demirror vm (! exception ev)))) + ( (nothing))))) + +(df throwable-stacktrace ((vm ) (ex )) + (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*))) + *last-stacktrace*) + (#t + (! getStackTrace ex)))) + +(df frame-to-string ((f )) + (let ((loc (! location f)) + (vm (! virtualMachine f))) + (format "~a (~a)" (!! name method loc) + (call-with-abort + (fun () (format "~{~a~^ ~}" + (mapi (! getArgumentValues f) + (fun (arg) + (pprint-to-string + (vm-demirror vm arg)))))))))) + +(df frame-src-loc ((tid ) (n ) state) + (try-catch + (mlet* (((frame vm) (nth-frame tid n state)) + (vm (as vm))) + (src-loc>elisp + (typecase frame + ( (! location frame)) + ( (@ loc frame)) + ( + (let* ((classname (! getClassName frame)) + (classes (! classesByName vm classname)) + (t (as (1st classes)))) + (1st (! locationsOfLine t (! getLineNumber frame)))))))) + (ex + (let ((msg (! getMessage ex))) + `(:error ,(if (== msg #!null) + (! toString ex) + msg)))))) + +(df nth-frame ((tid ) (n ) state) + (mlet ((tref level evs) (get state tid #f)) + (let* ((thread (as tref)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (vm (! virtualMachine thread)) + (frame (cond ((< n missing) + (stacktrace n)) + (#t (! frame thread (- n missing)))))) + (list frame vm)))) + +;;;;; Locals + +(df frame-locals ((tid ) (n ) state) + (mlet ((thread _ _) (get state tid #f)) + (let* ((thread (as thread)) + (vm (! virtualMachine thread)) + (p (fun (x) (pprint-to-string + (call-with-abort (fun () (vm-demirror vm x))))))) + (map (fun (x) + (mlet ((name value) x) + (list ':name name ':value (p value) ':id 0))) + (%frame-locals tid n state))))) + +(df frame-local-var ((tid ) (frame ) (var ) state => ) + (cadr (nth (%frame-locals tid frame state) var))) + +(df %frame-locals ((tid ) (n ) state) + (mlet ((frame _) (nth-frame tid n state)) + (typecase frame + ( + (let* ((visible (try-catch (! visibleVariables frame) + (ex + '()))) + (map (! getValues frame visible)) + (p (fun (x) x))) + (packing (pack) + (let ((self (ignore-errors (! thisObject frame)))) + (when self + (pack (list "this" (p self))))) + (iter (! entrySet map) + (fun ((e )) + (let ((var (as (! getKey e))) + (val (as (! getValue e)))) + (pack (list (! name var) (p val))))))))) + ( + (packing (pack) + (when (@ self frame) + (pack (list "this" (@ self frame)))) + (iter (! entrySet (@ values frame)) + (fun ((e )) + (let ((var (as (! getKey e))) + (val (as (! getValue e)))) + (pack (list (! name var) val))))))) + ( '())))) + +(df disassemble-frame ((tid ) (frame ) state) + (mlet ((frame _) (nth-frame tid frame state)) + (typecase frame + ( "") + ( + (let* ((l (! location frame)) + (m (! method l)) + (c (! declaringType l))) + (disassemble-to-string m)))))) + +;;;;; Restarts + +;; FIXME: factorize +(df throw-to-toplevel ((tid ) (id ) (c ) state) + (mlet ((tref level exc) (get state tid #f)) + (let* ((t (as tref)) + (ev (car exc))) + (typecase ev + ( ; actually uncaughtException + (! resume t) + (reply-abort c id) + ;;(send-debug-return c tid state) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + ( + ;; XXX race condition? + (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t)) + (let ((vm (! virtualMachine t)) + (k (fun () (primitive-throw ())))) + (reply-abort c id) + (! force-early-return t (vm-mirror vm k)) + (! resume t) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + ( + (log "resume from from interrupt\n") + (let ((vm (! virtualMachine t))) + (! stop t (vm-mirror vm ())) + (! resume t) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + ))))) + +(df thread-continue ((tid ) (id ) (c ) state) + (mlet ((tref level exc) (get state tid #f)) + (log "thread-continue: ~a ~a ~a \n" tref level exc) + (let* ((t (as tref))) + (! resume t)) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + +(df thread-step ((t ) k) + (let* ((vm (! virtual-machine t)) + (erm (! eventRequestManager vm)) + ( ) + (req (! createStepRequest erm t + (@s STEP_MIN) + (@s STEP_OVER)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addCountFilter req 1) + (! put-property req 'continuation k) + (! enable req))) + +(df eval-in-thread ((t ) sexp + #!optional (env :: (!s current))) + (let* ((vm (! virtualMachine t)) + (sc :: + (1st (! classes-by-name vm "kawa.standard.Scheme"))) + (ev :: + (1st (! methods-by-name sc "eval" + (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)" + "Ljava/lang/Object;"))))) + (! invokeMethod sc t ev (list sexp env) + (@s INVOKE_SINGLE_THREADED)))) + +;;;;; Threads + +(df list-threads (vm :: state) + (let* ((threads (! allThreads vm))) + (put state 'all-threads threads) + (packing (pack) + (pack '(\:id \:name \:status \:priority)) + (iter threads (fun ((t )) + (pack (list (! uniqueID t) + (! name t) + (let ((s (thread-status t))) + (if (! is-suspended t) + (cat "SUSPENDED/" s) + s)) + 0))))))) + +(df thread-status (t :: ) + (let ((s (! status t))) + (cond ((= s (@s THREAD_STATUS_UNKNOWN)) "UNKNOWN") + ((= s (@s THREAD_STATUS_ZOMBIE)) "ZOMBIE") + ((= s (@s THREAD_STATUS_RUNNING)) "RUNNING") + ((= s (@s THREAD_STATUS_SLEEPING)) "SLEEPING") + ((= s (@s THREAD_STATUS_MONITOR)) "MONITOR") + ((= s (@s THREAD_STATUS_WAIT)) "WAIT") + ((= s (@s THREAD_STATUS_NOT_STARTED)) "NOT_STARTED") + (#t "")))) + +;;;;; Bootstrap + +(df vm-attach (=> ) + (attach (getpid) 20)) + +(df attach (pid timeout) + (log "attaching: ~a ~a\n" pid timeout) + (let* (( ) + ( ) + (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager)) + (pa (as + (or + (find-if (! attaching-connectors vmm) + (fun (x :: ) + (! equals (! name x) "com.sun.jdi.ProcessAttach")) + #f) + (error "ProcessAttach connector not found")))) + (args (! default-arguments pa))) + (! set-value (as (! get args (to-str "pid"))) pid) + (when timeout + (! set-value (as (! get args (to-str "timeout"))) timeout)) + (log "attaching2: ~a ~a\n" pa args) + (! attach pa args))) + +(df getpid () + (let ((p (make-process (command-parse "echo $PPID") #!null))) + (! waitFor p) + (! read-line ( ( (! get-input-stream p)))))) + +(df request-uncaught-exception-events ((vm )) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #f #t))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! enable req))) + + +(df request-caught-exception-events ((vm )) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #t #f))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! addClassExclusionFilter req "java.lang.ClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader$1") + (! enable req))) + +(df set-stacktrace-recording ((vm ) (flag )) + (for (((e :: ) + (!! exceptionRequests eventRequestManager vm))) + (when (! notify-caught e) + (! setEnabled e flag)))) + +;; (set-stacktrace-recording *the-vm* #f) + +(df vm-to-string ((vm )) + (let* ((obj (as (1st (! classesByName vm "java.lang.Object")))) + (met (as (1st (! methodsByName obj "toString"))))) + (fun ((o ) (t )) + (! value + (as + (! invokeMethod o t met '() + (@s INVOKE_SINGLE_THREADED))))))) + +(define-simple-class () + (var #:allocation 'static)) + +(define-variable *global-get-mirror* #!null) +(define-variable *global-set-mirror* #!null) +(define-variable *global-get-raw* #!null) +(define-variable *global-set-raw* #!null) + +(df init-global-field ((vm )) + (when (nul? *global-get-mirror*) + (set (@s var) #!null) ; prepare class + (let* ((swank-global-variable-classes + (! classes-by-name vm "swank-global-variable")) + (swank-global-variable-classes-legacy + (! classes-by-name vm "swank$Mnglobal$Mnvariable")) + (c (as + (1st (if (= (length swank-global-variable-classes) 0) + swank-global-variable-classes-legacy + swank-global-variable-classes)))) + (f (! fieldByName c "var"))) + (set *global-get-mirror* (fun () (! getValue c f))) + (set *global-set-mirror* (fun ((v )) (! setValue c f v)))) + (set *global-get-raw* (fun () '() (@s var))) + (set *global-set-raw* (fun (x) + (set (@s var) x))))) + +(df vm-mirror ((vm ) obj) + (synchronized vm + (init-global-field vm) + (*global-set-raw* obj) + (*global-get-mirror*))) + +(df vm-demirror ((vm ) (v )) + (synchronized vm + (if (== v #!null) + #!null + (typecase v + ( (init-global-field vm) + (*global-set-mirror* v) + (*global-get-raw*)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)))))) + +(df vm-set-slot ((vm ) (o ) (name ) value) + (let* ((o (as (vm-mirror vm o))) + (t (! reference-type o)) + (f (! field-by-name t name))) + (! set-value o f (vm-mirror vm value)))) + +(define-simple-class + () + (f :: ) + ((*init* (f :: )) (set (@ f (this)) f)) + ((uncaughtException (t :: ) (e :: )) + :: + (! println (@s java.lang.System err) (to-str "uhexc:::")) + (! apply2 f t e) + #!void)) + +;;;; Channels + +(df spawn (f) + (let ((thread ( (%%runnable f)))) + (! start thread) + thread)) + + +;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...} +;; idiom which defeats all attempts to use a break-on-error-style +;; debugger. Previously I had my own version of RunnableClosure +;; without that deficiency but something in upstream changed and it no +;; longer worked. Now we use the normal RunnableClosure and at the +;; cost of taking stack snapshots on every throw. +(df %%runnable (f => ) + ;;( f) + ;;( f) + ;;(runnable f) + (%runnable f) + ) + +(df %runnable (f => ) + (runnable + (fun () + (try-catch (f) + (ex + (log "exception in thread ~s: ~s" (current-thread) + ex) + (! printStackTrace ex)))))) + +(df chan () + (let ((lock ()) + (im ()) + (ex ())) + (set (@ lock im) lock) + (set (@ lock ex) lock) + (set (@ peer im) ex) + (set (@ peer ex) im) + (cons im ex))) + +(df immutable? (obj) + (or (== obj #!null) + (symbol? obj) + (number? obj) + (char? obj) + (instance? obj ) + (null? obj))) + +(df send ((c ) value => ) + (df pass (obj) + (cond ((immutable? obj) obj) + ((string? obj) (! to-string obj)) + ((pair? obj) + (let loop ((r (list (pass (car obj)))) + (o (cdr obj))) + (cond ((null? o) (reverse! r)) + ((pair? o) (loop (cons (pass (car o)) r) (cdr o))) + (#t (append (reverse! r) (pass o)))))) + ((instance? obj ) + (let ((o :: obj)) + (assert (== (@ owner o) (current-thread))) + (synchronized (@ lock c) + (set (@ owner o) (@ owner (@ peer c)))) + o)) + ((or (instance? obj ) + (instance? obj )) + ;; those can be shared, for pragmatic reasons + obj + ) + (#t (error "can't send" obj (class-name-sans-package obj))))) + ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c))) + (assert (== (@ owner c) (current-thread))) + ;;(log "lock: ~s send\n" (@ owner (@ peer c))) + (synchronized (@ owner (@ peer c)) + (! put (@ queue (@ peer c)) (pass value)) + (! notify (@ owner (@ peer c)))) + ;;(log "unlock: ~s send\n" (@ owner (@ peer c))) + ) + +(df recv ((c )) + (cdr (recv/timeout (list c) 0))) + +(df recv* ((cs )) + (recv/timeout cs 0)) + +(df recv/timeout ((cs ) (timeout )) + (let ((self (current-thread)) + (end (if (zero? timeout) + 0 + (+ (current-time) timeout)))) + ;;(log "lock: ~s recv\n" self) + (synchronized self + (let loop () + ;;(log "receive-loop: ~s\n" self) + (let ((ready (find-if cs + (fun ((c )) + (not (! is-empty (@ queue c)))) + #f))) + (cond (ready + ;;(log "unlock: ~s recv\n" self) + (cons ready (! take (@ queue (as ready))))) + ((zero? timeout) + ;;(log "wait: ~s recv\n" self) + (! wait self) (loop)) + (#t + (let ((now (current-time))) + (cond ((<= end now) + 'timeout) + (#t + ;;(log "wait: ~s recv\n" self) + (! wait self (- end now)) + (loop))))))))))) + +(df rpc ((c ) msg) + (mlet* (((im . ex) (chan)) + ((op . args) msg)) + (send c `(,op ,ex . ,args)) + (recv im))) + +(df spawn/chan (f) + (mlet ((im . ex) (chan)) + (let ((thread ( (%%runnable (fun () (f ex)))))) + (set (@ owner ex) thread) + (! start thread) + (cons im thread)))) + +(df spawn/chan/catch (f) + (spawn/chan + (fun (c) + (try-catch + (f c) + (ex + (send c `(error ,(! toString ex) + ,(class-name-sans-package ex) + ,(map (fun (e) (! to-string e)) + (array-to-list (! get-stack-trace ex)))))))))) + +;;;; Logging + +(define swank-log-port (current-error-port)) +(df log (fstr #!rest args) + (synchronized swank-log-port + (apply format swank-log-port fstr args) + (force-output swank-log-port)) + #!void) + +;;;; Random helpers + +(df 1+ (x) (+ x 1)) +(df 1- (x) (- x 1)) + +(df len (x => ) + (typecase x + ( (length x)) + ( (! length x)) + ( (string-length x)) + ( (vector-length x)) + ( (! size x)) + ( (@ length x)))) + +;;(df put (tab key value) (hash-table-set! tab key value) tab) +;;(df get (tab key default) (hash-table-ref/default tab key default)) +;;(df del (tab key) (hash-table-delete! tab key) tab) +;;(df tab () (make-hash-table)) + +(df put (tab key value) (hashtable-set! tab key value) tab) +(df get (tab key default) (hashtable-ref tab key default)) +(df del (tab key) (hashtable-delete! tab key) tab) +(df tab () (make-eqv-hashtable)) + +(df equal (x y => ) (equal? x y)) + +(df current-thread (=> ) (!s java.lang.Thread currentThread)) +(df current-time (=> ) (!s java.lang.System currentTimeMillis)) + +(df nul? (x) (== x #!null)) + +(df read-from-string (str) + (call-with-input-string str read)) + +;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p)))) + +(df pprint-to-string (obj) + (let* ((w ()) + (p ( w #t #f))) + (try-catch (print-object obj p) + (ex + (format p "#" + ex (class-name-sans-package ex)))) + (! flush p) + (to-string (! getBuffer w)))) + +(df print-object (obj stream) + (typecase obj + #; + ((or (eql #!null) (eql #!eof) + ) + (write obj stream)) + (#t + #;(print-unreadable-object obj stream) + (write obj stream) + ))) + +(df print-unreadable-object ((o ) stream) + (let* ((string (! to-string o)) + (class (! get-class o)) + (name (! get-name class)) + (simplename (! get-simple-name class))) + (cond ((! starts-with string "#<") + (format stream "~a" string)) + ((or (! starts-with string name) + (! starts-with string simplename)) + (format stream "#<~a>" string)) + (#t + (format stream "#<~a ~a>" name string))))) + +(define cat string-append) + +(df values-to-list (values) + (typecase values + ( (array-to-list (! getValues values))) + ( (list values)))) + +;; (to-list (as-list (values 1 2 2))) + +(df array-to-list ((array ) => ) + (packing (pack) + (dotimes (i (@ length array)) + (pack (array i))))) + +(df lisp-bool (obj) + (cond ((== obj 'nil) #f) + ((== obj 't) #t) + (#t (error "Can't map lisp boolean" obj)))) + +(df path-sans-extension ((p path) => ) + (let ((ex (! get-extension p)) + (str (! to-string p))) + (to-string (cond ((not ex) str) + (#t (! substring str 0 (- (len str) (len ex) 1))))))) + +(df class-name-sans-package ((obj )) + (cond ((nul? obj) "<#!null>") + (#t + (try-catch + (let* ((c (! get-class obj)) + (n (! get-simple-name c))) + (cond ((equal n "") (! get-name c)) + (#t n))) + (e + (format "#<~a: ~a>" e (! get-message e))))))) + +(df list-env (#!optional (env :: (!s current))) + (let ((enum (! enumerateAllLocations env))) + (packing (pack) + (while (! hasMoreElements enum) + (pack (! nextLocation enum)))))) + +(df list-file (filename) + (with (port (call-with-input-file filename)) + (let* ((lang (!s gnu.expr.Language getDefaultLanguage)) + (messages ()) + (comp (! parse lang (as port) messages 0))) + (! get-module comp)))) + +(df list-decls (file) + (let* ((module (as (list-file file)))) + (do ((decl :: + (! firstDecl module) (! nextDecl decl))) + ((nul? decl)) + (format #t "~a ~a:~d:~d\n" decl + (! getFileName decl) + (! getLineNumber decl) + (! getColumnNumber decl) + )))) + +(df %time (f) + (define-alias ) + (define-alias ) + (let* ((gcs (!s getGarbageCollectorMXBeans)) + (mem (!s getMemoryMXBean)) + (jit (!s getCompilationMXBean)) + (oldjit (! getTotalCompilationTime jit)) + (oldgc (packing (pack) + (iter gcs (fun ((gc )) + (pack (cons gc + (list (! getCollectionCount gc) + (! getCollectionTime gc)))))))) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nonheap (!! getUsed getNonHeapMemoryUsage mem)) + (start (!s java.lang.System nanoTime)) + (values (f)) + (end (!s java.lang.System nanoTime)) + (newheap (!! getUsed getHeapMemoryUsage mem)) + (newnonheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "~&") + (let ((njit (! getTotalCompilationTime jit))) + (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit)) + (iter gcs (fun ((gc )) + (mlet ((_ count time) (assoc gc oldgc)) + (format #t "; GC ~a: ~:d ms (~d)\n" + (! getName gc) + (- (! getCollectionTime gc) time) + (- (! getCollectionCount gc) count))))) + (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap) + (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap) + (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000)) + values)) + +(define-syntax time + (syntax-rules () + ((time form) + (%time (lambda () form))))) + +(df gc () + (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (oheap (!! getUsed getHeapMemoryUsage mem)) + (onheap (!! getUsed getNonHeapMemoryUsage mem)) + (_ (! gc mem)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n" + (- heap oheap) heap (- onheap nheap) nheap))) + +(df room () + (let* ((pools (!s java.lang.management.ManagementFactory + getMemoryPoolMXBeans)) + (mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (iter pools (fun ((p )) + (format #t "~&; ~a~1,16t: ~10:d\n" + (! getName p) + (!! getUsed getUsage p)))) + (format #t "; Heap~1,16t: ~10:d\n" heap) + (format #t "; Non-Heap~1,16t: ~10:d\n" nheap))) + +;; (df javap (class #!key method signature) +;; (let* (( ) +;; (bytes +;; (typecase class +;; ( (read-bytes ( (to-str class)))) +;; ( class) +;; ( (read-class-file class)))) +;; (cdata ( ( bytes))) +;; (p ( +;; ( bytes) +;; (current-output-port) +;; ()))) +;; (cond (method +;; (dolist ((m ) +;; (array-to-list (! getMethods cdata))) +;; (when (and (equal (to-str method) (! getName m)) +;; (or (not signature) +;; (equal signature (! getInternalSig m)))) +;; (! printMethodSignature p m (! getAccess m)) +;; (! printExceptions p m) +;; (newline) +;; (! printVerboseHeader p m) +;; (! printcodeSequence p m)))) +;; (#t (p:print))) +;; (values))) + +(df read-bytes ((is ) => ) + (let ((os ())) + (let loop () + (let ((c (! read is))) + (cond ((= c -1)) + (#t (! write os c) (loop))))) + (! to-byte-array os))) + +(df read-class-file ((name ) => ) + (let ((f (cat (! replace (to-str name) (as #\.) (as #\/)) + ".class"))) + (mcase (find-file-in-path f (class-path)) + ('#f (ferror "Can't find classfile for ~s" name)) + ((:zip zipfile entry) + (let* ((z ( (as zipfile))) + (e (! getEntry z (as entry)))) + (read-bytes (! getInputStream z e)))) + ((:file s) (read-bytes ( (as s))))))) + +(df all-instances ((vm ) (classname )) + (mappend (fun ((c )) (to-list (! instances c (as long 9999)))) + (%all-subclasses vm classname))) + +(df %all-subclasses ((vm ) (classname )) + (mappend (fun ((c )) (cons c (to-list (! subclasses c)))) + (to-list (! classes-by-name vm classname)))) + +(df with-output-to-string (thunk => ) + (call-with-output-string + (fun (s) (parameterize ((current-output-port s)) (thunk))))) + +(df find-if ((i ) test default) + (let ((iter (! iterator i)) + (found #f)) + (while (and (not found) (! has-next iter)) + (let ((e (! next iter))) + (when (test e) + (set found #t) + (set default e)))) + default)) + +(df filter ((i ) test => ) + (packing (pack) + (for ((e i)) + (when (test e) + (pack e))))) + +(df iter ((i ) f) + (for ((e i)) (f e))) + +(df mapi ((i ) f => ) + (packing (pack) (for ((e i)) (pack (f e))))) + +(df nth ((i ) (n )) + (let ((iter (! iterator i))) + (dotimes (i n) + (! next iter)) + (! next iter))) + +(df 1st ((i )) (!! next iterator i)) + +(df to-list ((i ) => ) + (packing (pack) (for ((e i)) (pack e)))) + +(df as-list ((o ) => ) + (!s java.util.Arrays asList o)) + +(df mappend (f list) + (apply append (map f list))) + +(df subseq (s from to) + (typecase s + ( (apply list (! sub-list s from to))) + ( (apply vector (! sub-list s from to))) + ( (! substring s from to)) + ( (let* ((len (as (- to from))) + (t ( #:length len))) + (!s java.lang.System arraycopy s from t 0 len) + t)))) + +(df to-string (obj => ) + (typecase obj + ( ( obj)) + ((satisfies string?) obj) + ((satisfies symbol?) (symbol->string obj)) + ( ( obj)) + ( ( obj)) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +(df to-str (obj => ) + (cond ((instance? obj ) obj) + ((string? obj) (! toString obj)) + ((symbol? obj) (! getName (as obj))) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +)) + +;; Local Variables: +;; mode: goo +;; compile-command: "\ +;; rm -rf classes && \ +;; JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \ +;; jar cf swank-kawa.jar -C classes ." +;; End: diff --git a/elpa/slime-20200319.1939/contrib/swank-larceny.scm b/elpa/slime-20200319.1939/contrib/swank-larceny.scm new file mode 100644 index 00000000..e4d730d2 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-larceny.scm @@ -0,0 +1,176 @@ +;; swank-larceny.scm --- Swank server for Larceny +;; +;; License: Public Domain +;; Author: Helmut Eller +;; +;; In a shell execute: +;; larceny -r6rs -program swank-larceny.scm +;; and then `M-x slime-connect' in Emacs. + +(library (swank os) + (export getpid make-server-socket accept local-port close-socket) + (import (rnrs) + (primitives foreign-procedure + ffi/handle->address + ffi/string->asciiz + sizeof:pointer + sizeof:int + %set-pointer + %get-int)) + + (define getpid (foreign-procedure "getpid" '() 'int)) + (define fork (foreign-procedure "fork" '() 'int)) + (define close (foreign-procedure "close" '(int) 'int)) + (define dup2 (foreign-procedure "dup2" '(int int) 'int)) + + (define bytevector-content-offset$ sizeof:pointer) + + (define execvp% (foreign-procedure "execvp" '(string boxed) 'int)) + (define (execvp file . args) + (let* ((nargs (length args)) + (argv (make-bytevector (* (+ nargs 1) + sizeof:pointer)))) + (do ((offset 0 (+ offset sizeof:pointer)) + (as args (cdr as))) + ((null? as)) + (%set-pointer argv + offset + (+ (ffi/handle->address (ffi/string->asciiz (car as))) + bytevector-content-offset$))) + (%set-pointer argv (* nargs sizeof:pointer) 0) + (execvp% file argv))) + + (define pipe% (foreign-procedure "pipe" '(boxed) 'int)) + (define (pipe) + (let ((array (make-bytevector (* sizeof:int 2)))) + (let ((r (pipe% array))) + (values r (%get-int array 0) (%get-int array sizeof:int))))) + + (define (fork/exec file . args) + (let ((pid (fork))) + (cond ((= pid 0) + (apply execvp file args)) + (#t pid)))) + + (define (start-process file . args) + (let-values (((r1 down-out down-in) (pipe)) + ((r2 up-out up-in) (pipe)) + ((r3 err-out err-in) (pipe))) + (assert (= 0 r1)) + (assert (= 0 r2)) + (assert (= 0 r3)) + (let ((pid (fork))) + (case pid + ((-1) + (error "Failed to fork a subprocess.")) + ((0) + (close up-out) + (close err-out) + (close down-in) + (dup2 down-out 0) + (dup2 up-in 1) + (dup2 err-in 2) + (apply execvp file args) + (exit 1)) + (else + (close down-out) + (close up-in) + (close err-in) + (list pid + (make-fd-io-stream up-out down-in) + (make-fd-io-stream err-out err-out))))))) + + (define (make-fd-io-stream in out) + (let ((write (lambda (bv start count) (fd-write out bv start count))) + (read (lambda (bv start count) (fd-read in bv start count))) + (closeit (lambda () (close in) (close out)))) + (make-custom-binary-input/output-port + "fd-stream" read write #f #f closeit))) + + (define write% (foreign-procedure "write" '(int ulong int) 'int)) + (define (fd-write fd bytevector start count) + (write% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define read% (foreign-procedure "read" '(int ulong int) 'int)) + (define (fd-read fd bytevector start count) + ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count) + (read% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define (make-server-socket port) + (let* ((args `("/bin/bash" "bash" + "-c" + ,(string-append + "netcat -s 127.0.0.1 -q 0 -l -v " + (if port + (string-append "-p " (number->string port)) + "")))) + (nc (apply start-process args)) + (err (transcoded-port (list-ref nc 2) + (make-transcoder (latin-1-codec)))) + (line (get-line err)) + (pos (last-index-of line '#\]))) + (cond (pos + (let* ((tail (substring line (+ pos 1) (string-length line))) + (port (get-datum (open-string-input-port tail)))) + (list (car nc) (cadr nc) err port))) + (#t (error "netcat failed: " line))))) + + (define (accept socket codec) + (let* ((line (get-line (caddr socket))) + (pos (last-index-of line #\]))) + (cond (pos + (close-port (caddr socket)) + (let ((stream (cadr socket))) + (let ((io (transcoded-port stream (make-transcoder codec)))) + (values io io)))) + (else (error "accept failed: " line))))) + + (define (local-port socket) + (list-ref socket 3)) + + (define (last-index-of str chr) + (let loop ((i (string-length str))) + (cond ((<= i 0) #f) + (#t (let ((i (- i 1))) + (cond ((char=? (string-ref str i) chr) + i) + (#t + (loop i)))))))) + + (define (close-socket socket) + ;;(close-port (cadr socket)) + #f + ) + + ) + +(library (swank sys) + (export implementation-name eval-in-interaction-environment) + (import (rnrs) + (primitives system-features + aeryn-evaluator)) + + (define (implementation-name) "larceny") + + ;; see $LARCENY/r6rsmode.sch: + ;; Larceny's ERR5RS and R6RS modes. + ;; Code names: + ;; Aeryn ERR5RS + ;; D'Argo R6RS-compatible + ;; Spanky R6RS-conforming (not yet implemented) + (define (eval-in-interaction-environment form) + (aeryn-evaluator form)) + + ) + +(import (rnrs) (rnrs eval) (larceny load)) +(load "swank-r6rs.scm") +(eval '(start-server #f) (environment '(swank))) diff --git a/elpa/slime-20200319.1939/contrib/swank-listener-hooks.lisp b/elpa/slime-20200319.1939/contrib/swank-listener-hooks.lisp new file mode 100644 index 00000000..f289c90f --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-listener-hooks.lisp @@ -0,0 +1,91 @@ +;;; swank-listener-hooks.lisp --- listener with special hooks +;; +;; Author: Alan Ruttenberg + +;; Provides *slime-repl-eval-hooks* special variable which +;; can be used for easy interception of SLIME REPL form evaluation +;; for purposes such as integration with application event loop. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(export '*slime-repl-eval-hooks*) + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + +(defun %eval-region (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (if *slime-repl-eval-hooks* + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) + (finish-output)))))) + +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) + +(defun %listener-eval (string) + (clear-user-input) + (with-buffer-syntax () + (swank-repl::track-package + (lambda () + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (%eval-region string) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (unless (eq *slime-repl-suppress-output* t) + (funcall swank-repl::*send-repl-results-function* values))))))) + nil) + +(setq swank-repl::*listener-eval-function* '%listener-eval) + +(provide :swank-listener-hooks) diff --git a/elpa/slime-20200319.1939/contrib/swank-macrostep.lisp b/elpa/slime-20200319.1939/contrib/swank-macrostep.lisp new file mode 100644 index 00000000..7595e36b --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-macrostep.lisp @@ -0,0 +1,227 @@ +;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el +;; +;; Authors: Luis Oliveira +;; Jon Oddie +;; +;; License: Public Domain + +(defpackage swank-macrostep + (:use cl swank) + (:import-from swank + #:*macroexpand-printer-bindings* + #:with-buffer-syntax + #:with-bindings + #:to-string + #:macroexpand-all + #:compiler-macroexpand-1 + #:defslimefun + #:collect-macro-forms) + (:export #:macrostep-expand-1 + #:macro-form-p)) + +(in-package #:swank-macrostep) + +(defslimefun macrostep-expand-1 (string compiler-macros? context) + (with-buffer-syntax () + (let ((form (read-from-string string))) + (multiple-value-bind (expansion error-message) + (expand-form-once form compiler-macros? context) + (if error-message + `(:error ,error-message) + (multiple-value-bind (macros compiler-macros) + (collect-macro-forms-in-context expansion context) + (let* ((all-macros (append macros compiler-macros)) + (pretty-expansion (pprint-to-string expansion)) + (positions (collect-form-positions expansion + pretty-expansion + all-macros)) + (subform-info + (loop + for form in all-macros + for (start end) in positions + when (and start end) + collect (let ((op-name (to-string (first form))) + (op-type + (if (member form macros) + :macro + :compiler-macro))) + (list op-name + op-type + start))))) + `(:ok ,pretty-expansion ,subform-info)))))))) + +(defun expand-form-once (form compiler-macros? context) + (multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (if expanded? + (values expansion nil) + (if (not compiler-macros?) + (values nil "Not a macro form") + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (if expanded? + (values expansion nil) + (values nil "Not a macro or compiler-macro form"))))))) + +(defslimefun macro-form-p (string compiler-macros? context) + (with-buffer-syntax () + (let ((form + (handler-case + (read-from-string string) + (error (condition) + (unless (debug-on-swank-error) + (return-from macro-form-p + `(:error ,(format nil "Read error: ~A" condition)))))))) + `(:ok ,(macro-form-type form compiler-macros? context))))) + +(defun macro-form-type (form compiler-macros? context) + (cond + ((or (not (consp form)) + (not (symbolp (car form)))) + nil) + ((multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (declare (ignore expansion)) + expanded?) + :macro) + ((and compiler-macros? + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (declare (ignore expansion)) + expanded?)) + :compiler-macro) + (t + nil))) + + +;;;; Hacks to support macro-expansion within local context + +(defparameter *macrostep-tag* (gensym)) + +(defparameter *macrostep-placeholder* '*macrostep-placeholder*) + +(define-condition expansion-in-context-failed (simple-error) + ()) + +(defmacro throw-expansion (form &environment env) + (throw *macrostep-tag* (macroexpand-1 form env))) + +(defmacro throw-collected-macro-forms (form &environment env) + (throw *macrostep-tag* (collect-macro-forms form env))) + +(defun macroexpand-1-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-expansion ,form) context) + (error () + (macroexpand-1 form)))) + +(defun collect-macro-forms-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-collected-macro-forms ,form) context) + (error () + (collect-macro-forms form)))) + +(defun macroexpand-and-catch (form context) + (catch *macrostep-tag* + (macroexpand-all (enclose-form-in-context form context)) + (error 'expansion-in-context-failed))) + +(defun enclose-form-in-context (form context) + (with-buffer-syntax () + (destructuring-bind (prefix suffix) context + (let* ((placeholder-form + (read-from-string + (concatenate + 'string + prefix (prin1-to-string *macrostep-placeholder*) suffix))) + (substituted-form (subst form *macrostep-placeholder* + placeholder-form))) + (if (not (equal placeholder-form substituted-form)) + substituted-form + (error 'expansion-in-context-failed)))))) + + +;;;; Tracking Pretty Printer + +(defun marker-char-p (char) + (<= #xe000 (char-code char) #xe8ff)) + +(defun make-marker-char (id) + ;; using the private-use characters U+E000..U+F8FF as markers, so + ;; that's our upper limit for how many we can use. + (assert (<= 0 id #x8ff)) + (code-char (+ #xe000 id))) + +(defun marker-char-id (char) + (assert (marker-char-p char)) + (- (char-code char) #xe000)) + +(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) + +(defun whitespacep (char) + (member char +whitespace+)) + +(defun pprint-to-string (object &optional pprint-dispatch) + (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) + (with-bindings *macroexpand-printer-bindings* + (to-string object)))) + +#-clisp +(defun collect-form-positions (expansion printed-expansion forms) + (loop for (start end) + in (collect-marker-positions + (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) + (length forms)) + collect (when (and start end) + (list (find-non-whitespace-position printed-expansion start) + (find-non-whitespace-position printed-expansion end))))) + +;; The pprint-dispatch table constructed by +;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack +;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS +;; entry point a no-op in thi case, so that basic macro-expansion will +;; still work (without detection of inner macro forms) +#+clisp +(defun collect-form-positions (expansion printed-expansion forms) + nil) + +(defun make-tracking-pprint-dispatch (forms) + (let ((original-table *print-pprint-dispatch*) + (table (copy-pprint-dispatch))) + (flet ((maybe-write-marker (position stream) + (when position + (write-char (make-marker-char position) stream)))) + (set-pprint-dispatch 'cons + (lambda (stream cons) + (let ((pos (position cons forms))) + (maybe-write-marker pos stream) + ;; delegate printing to the original table. + (funcall (pprint-dispatch cons original-table) + stream + cons) + (maybe-write-marker pos stream))) + most-positive-fixnum + table)) + table)) + +(defun collect-marker-positions (string position-count) + (let ((positions (make-array position-count :initial-element nil))) + (loop with p = 0 + for char across string + unless (whitespacep char) + do (if (marker-char-p char) + (push p (aref positions (marker-char-id char))) + (incf p))) + (map 'list #'reverse positions))) + +(defun find-non-whitespace-position (string position) + (loop with non-whitespace-position = -1 + for i from 0 and char across string + unless (whitespacep char) + do (incf non-whitespace-position) + until (eql non-whitespace-position position) + finally (return i))) + +(provide :swank-macrostep) diff --git a/elpa/slime-20200319.1939/contrib/swank-media.lisp b/elpa/slime-20200319.1939/contrib/swank-media.lisp new file mode 100644 index 00000000..3d5ef7cc --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-media.lisp @@ -0,0 +1,25 @@ +;;; swank-media.lisp --- insert other media (images) +;; +;; Authors: Christophe Rhodes +;; +;; Licence: GPLv2 or later +;; + +(in-package :swank) + +;; this file is empty of functionality. The slime-media contrib +;; allows swank to return messages other than :write-string as repl +;; results; this is used in the R implementation of swank to display R +;; objects with graphical representations (such as trellis objects) as +;; image presentations in the swank repl. In R, this is done by +;; having a hook function for the preparation of the repl results, in +;; addition to the already-existing hook for sending the repl results +;; (*send-repl-results-function*, used by swank-presentations.lisp). +;; The swank-media.R contrib implementation defines a generic function +;; for use as this hook, along with methods for commonly-encountered +;; graphical R objects. (This strategy is harder in CL, where methods +;; can only be defined if their specializers already exist; in R's S3 +;; object system, methods are ordinary functions with a special naming +;; convention) + +(provide :swank-media) diff --git a/elpa/slime-20200319.1939/contrib/swank-mit-scheme.scm b/elpa/slime-20200319.1939/contrib/swank-mit-scheme.scm new file mode 100644 index 00000000..e7729ff0 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-mit-scheme.scm @@ -0,0 +1,870 @@ +;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme +;; +;; Copyright (C) 2008 Helmut Eller +;; +;; This file is licensed under the terms of the GNU General Public +;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation: +#| + +1. You need MIT Scheme 9.2 + +2. The Emacs side needs some fiddling. I have the following in + my .emacs: + +(setq slime-lisp-implementations + '((mit-scheme ("mit-scheme") :init mit-scheme-init))) + +(defun mit-scheme-init (file encoding) + (format "%S\n\n" + `(begin + (load-option 'format) + (load-option 'sos) + (eval + '(create-package-from-description + (make-package-description '(swank) (list (list)) + (vector) (vector) (vector) false)) + (->environment '(package))) + (load ,(expand-file-name + ".../contrib/swank-mit-scheme.scm" ; <-- insert your path + slime-path) + (->environment '(swank))) + (eval '(start-swank ,file) (->environment '(swank)))))) + +(defun mit-scheme () + (interactive) + (slime 'mit-scheme)) + +(defun find-mit-scheme-package () + (save-excursion + (let ((case-fold-search t)) + (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t) + (match-string-no-properties 1))))) + +(setq slime-find-buffer-package-function 'find-mit-scheme-package) +(add-hook 'scheme-mode-hook (lambda () (slime-mode 1))) + + The `mit-scheme-init' function first loads the SOS and FORMAT + libraries, then creates a package "(swank)", and loads this file + into that package. Finally it starts the server. + + `find-mit-scheme-package' tries to figure out which package the + buffer belongs to, assuming that ";;; package: (FOO)" appears + somewhere in the file. Luckily, this assumption is true for many of + MIT Scheme's own files. Alternatively, you could add Emacs style + -*- slime-buffer-package: "(FOO)" -*- file variables. + +4. Start everything with `M-x mit-scheme'. + +|# + +;;; package: (swank) + +(if (< (car (get-subsystem-version "Release")) + '9) + (error "This file requires MIT Scheme Release 9")) + +(define (swank port) + (accept-connections (or port 4005) #f)) + +;; ### hardcoded port number for now. netcat-openbsd doesn't print +;; the listener port anymore. +(define (start-swank port-file) + (accept-connections 4055 port-file) + ) + +;;;; Networking + +(define (accept-connections port port-file) + (let ((sock (open-tcp-server-socket port (host-address-loopback)))) + (format #t "Listening on port: ~s~%" port) + (if port-file (write-port-file port port-file)) + (dynamic-wind + (lambda () #f) + (lambda () (serve (tcp-server-connection-accept sock #t #f))) + (lambda () (close-tcp-server-socket sock))))) + +(define (write-port-file portnumber filename) + (call-with-output-file filename (lambda (p) (write portnumber p)))) + +(define *top-level-restart* #f) +(define (serve socket) + (with-simple-restart + 'disconnect "Close connection." + (lambda () + (with-keyboard-interrupt-handler + (lambda () (main-loop socket)))))) + +(define (disconnect) + (format #t "Disconnecting ...~%") + (invoke-restart (find-restart 'disconnect))) + +(define (main-loop socket) + (do () (#f) + (with-simple-restart + 'abort "Return to SLIME top-level." + (lambda () + (fluid-let ((*top-level-restart* (find-restart 'abort))) + (dispatch (read-packet socket) socket 0)))))) + +(define (with-keyboard-interrupt-handler fun) + (define (set-^G-handler exp) + (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp) + (->environment '(runtime interrupt-handler)))) + (dynamic-wind + (lambda () #f) + (lambda () + (set-^G-handler + `(lambda (char) (with-simple-restart + 'continue "Continue from interrupt." + (lambda () (error "Keyboard Interrupt."))))) + (fun)) + (lambda () + (set-^G-handler '^G-interrupt-handler)))) + + +;;;; Reading/Writing of SLIME packets + +(define (read-packet in) + "Read an S-expression from STREAM using the SLIME protocol." + (let* ((len (read-length in)) + (buffer (make-string len))) + (fill-buffer! in buffer) + (read-from-string buffer))) + +(define (write-packet message out) + (let* ((string (write-to-string message))) + (log-event "WRITE: [~a]~s~%" (string-length string) string) + (write-length (string-length string) out) + (write-string string out) + (flush-output out))) + +(define (fill-buffer! in buffer) + (read-string! buffer in)) + +(define (read-length in) + (if (eof-object? (peek-char in)) (disconnect)) + (do ((len 6 (1- len)) + (sum 0 (+ (* sum 16) (char->hex-digit (read-char in))))) + ((zero? len) sum))) + +(define (ldb size position integer) + "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER." + (fix:and (fix:lsh integer (- position)) + (1- (fix:lsh 1 size)))) + +(define (write-length len out) + (do ((pos 20 (- pos 4))) + ((< pos 0)) + (write-hex-digit (ldb 4 pos len) out))) + +(define (write-hex-digit n out) + (write-char (hex-digit->char n) out)) + +(define (hex-digit->char n) + (digit->char n 16)) + +(define (char->hex-digit c) + (char->digit c 16)) + + +;;;; Event dispatching + +(define (dispatch request socket level) + (log-event "READ: ~s~%" request) + (case (car request) + ((:emacs-rex) (apply emacs-rex socket level (cdr request))))) + +(define (swank-package) + (or (name->package '(swank)) + (name->package '(user)))) + +(define *buffer-package* #f) +(define (find-buffer-package name) + (if (elisp-false? name) + #f + (let ((v (ignore-errors + (lambda () (name->package (read-from-string name)))))) + (and (package? v) v)))) + +(define swank-env (->environment (swank-package))) +(define (user-env buffer-package) + (cond ((string? buffer-package) + (let ((p (find-buffer-package buffer-package))) + (if (not p) (error "Invalid package name: " buffer-package)) + (package/environment p))) + (else (nearest-repl/environment)))) + +;; quote keywords +(define (hack-quotes list) + (map (lambda (x) + (cond ((symbol? x) `(quote ,x)) + (#t x))) + list)) + +(define (emacs-rex socket level sexp package thread id) + (let ((ok? #f) (result #f) (condition #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (bind-condition-handler + (list condition-type:serious-condition) + (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c)) + (lambda () + (fluid-let ((*buffer-package* package)) + (set! result + (eval (cons* (car sexp) socket (hack-quotes (cdr sexp))) + swank-env)) + (set! ok? #t))))) + (lambda () + (write-packet `(:return + ,(if ok? `(:ok ,result) + `(:abort + ,(if condition + (format #f "~a" + (condition/type condition)) + ""))) + ,id) + socket))))) + +(define (swank:connection-info _) + (let ((p (environment->package (user-env #f)))) + `(:pid ,(unix/current-pid) + :package (:name ,(write-to-string (package/name p)) + :prompt ,(write-to-string (package/name p))) + :lisp-implementation + (:type "MIT Scheme" :version ,(get-subsystem-version-string "release")) + :encoding (:coding-systems ("iso-8859-1")) + ))) + +(define (swank:quit-lisp _) + (%exit)) + + +;;;; Evaluation + +(define (swank-repl:listener-eval socket string) + ;;(call-with-values (lambda () (eval-region string socket)) + ;; (lambda values `(:values . ,(map write-to-string values)))) + `(:values ,(write-to-string (eval-region string socket)))) + +(define (eval-region string socket) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (with-output-to-repl socket + (lambda () (eval sexp (user-env *buffer-package*))))))) + +(define (with-output-to-repl socket fun) + (let ((p (make-port repl-port-type socket))) + (dynamic-wind + (lambda () #f) + (lambda () (with-output-to-port p fun)) + (lambda () (flush-output p))))) + +(define (swank:interactive-eval socket string) + ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area) + (format-values (eval-region string socket)) + ) + +(define (format-values . values) + (if (null? values) + "; No value" + (with-string-output-port + (lambda (out) + (write-string "=> " out) + (do ((vs values (cdr vs))) ((null? vs)) + (write (car vs) out) + (if (not (null? (cdr vs))) + (write-string ", " out))))))) + +(define (swank:pprint-eval _ string) + (pprint-to-string (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (swank:interactive-eval-region socket string) + (format-values (eval-region string socket))) + +(define (swank:set-package _ package) + (set-repl/environment! (nearest-repl) + (->environment (read-from-string package))) + (let* ((p (environment->package (user-env #f))) + (n (write-to-string (package/name p)))) + (list n n))) + + +(define (repl-write-substring port string start end) + (cond ((< start end) + (write-packet `(:write-string ,(substring string start end)) + (port/state port)))) + (- end start)) + +(define (repl-write-char port char) + (write-packet `(:write-string ,(string char)) + (port/state port))) + +(define repl-port-type + (make-port-type `((write-substring ,repl-write-substring) + (write-char ,repl-write-char)) #f)) + +(define (swank-repl:create-repl socket . _) + (let* ((env (user-env #f)) + (name (format #f "~a" (package/name (environment->package env))))) + (list name name))) + + +;;;; Compilation + +(define (swank:compile-string-for-emacs _ string . x) + (apply + (lambda (errors seconds) + `(:compilation-result ,errors t ,seconds nil nil)) + (call-compiler + (lambda () + (let* ((sexps (snarf-string string)) + (env (user-env *buffer-package*)) + (scode (syntax `(begin ,@sexps) env)) + (compiled-expression (compile-scode scode #t))) + (scode-eval compiled-expression env)))))) + +(define (snarf-string string) + (with-input-from-string string + (lambda () + (let loop () + (let ((e (read))) + (if (eof-object? e) '() (cons e (loop)))))))) + +(define (call-compiler fun) + (let ((time #f)) + (with-timings fun + (lambda (run-time gc-time real-time) + (set! time real-time))) + (list 'nil (internal-time/ticks->seconds time)))) + +(define (swank:compiler-notes-for-emacs _) nil) + +(define (swank:compile-file-for-emacs socket file load?) + (apply + (lambda (errors seconds) + (list ':compilation-result errors 't seconds load? + (->namestring (pathname-name file)))) + (call-compiler + (lambda () (with-output-to-repl socket (lambda () (compile-file file))))))) + +(define (swank:load-file socket file) + (with-output-to-repl socket + (lambda () + (pprint-to-string + (load file (user-env *buffer-package*)))))) + +(define (swank:disassemble-form _ string) + (let ((sexp (let ((sexp (read-from-string string))) + (cond ((and (pair? sexp) (eq? (car sexp) 'quote)) + (cadr sexp)) + (#t sexp))))) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval sexp (user-env *buffer-package*))))))) + +(define (swank:disassemble-symbol _ string) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval (read-from-string string) + (user-env *buffer-package*)))))) + + +;;;; Macroexpansion + +(define (swank:swank-macroexpand-all _ string) + (with-output-to-string + (lambda () + (pp (syntax (read-from-string string) + (user-env *buffer-package*)))))) +(define swank:swank-macroexpand-1 swank:swank-macroexpand-all) +(define swank:swank-macroexpand swank:swank-macroexpand-all) + + +;;; Arglist + +(define (swank:operator-arglist socket name pack) + (let ((v (ignore-errors + (lambda () + (string-trim-right + (with-output-to-string + (lambda () + (carefully-pa + (eval (read-from-string name) (user-env pack)))))))))) + (if (condition? v) 'nil v))) + +(define (carefully-pa o) + (cond ((arity-dispatched-procedure? o) + ;; MIT Scheme crashes for (pa /) + (display "arity-dispatched-procedure")) + ((procedure? o) (pa o)) + (else (error "Not a procedure")))) + + +;;; Some unimplemented stuff. +(define (swank:buffer-first-change . _) nil) +(define (swank:filename-to-modulename . _) nil) +(define (swank:swank-require . _) nil) + +;; M-. is beyond my capabilities. +(define (swank:find-definitions-for-emacs . _) nil) + + +;;; Debugger + +(define-structure (sldb-state (conc-name sldb-state.)) condition restarts) + +(define *sldb-state* #f) +(define (invoke-sldb socket level condition) + (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts)))) + (dynamic-wind + (lambda () #f) + (lambda () + (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20)) + socket) + (sldb-loop level socket)) + (lambda () + (write-packet `(:debug-return 0 ,level nil) socket))))) + +(define (sldb-loop level socket) + (write-packet `(:debug-activate 0 ,level) socket) + (with-simple-restart + 'abort (format #f "Return to SLDB level ~a." level) + (lambda () (dispatch (read-packet socket) socket level))) + (sldb-loop level socket)) + +(define (sldb-info state start end) + (let ((c (sldb-state.condition state)) + (rs (sldb-state.restarts state))) + (list (list (condition/report-string c) + (format #f " [~a]" (%condition-type/name (condition/type c))) + nil) + (sldb-restarts rs) + (sldb-backtrace c start end) + ;;'((0 "dummy frame")) + '()))) + +(define %condition-type/name + (eval '%condition-type/name (->environment '(runtime error-handler)))) + +(define (sldb-restarts restarts) + (map (lambda (r) + (list (symbol->string (restart/name r)) + (with-string-output-port + (lambda (p) (write-restart-report r p))))) + restarts)) + +(define (swank:throw-to-toplevel . _) + (invoke-restart *top-level-restart*)) + +(define (swank:sldb-abort . _) + (abort (sldb-state.restarts *sldb-state*))) + +(define (swank:sldb-continue . _) + (continue (sldb-state.restarts *sldb-state*))) + +(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n) + (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n))) + +(define (swank:debugger-info-for-emacs _ from to) + (sldb-info *sldb-state* from to)) + +(define (swank:backtrace _ from to) + (sldb-backtrace (sldb-state.condition *sldb-state*) from to)) + +(define (sldb-backtrace condition from to) + (sldb-backtrace-aux (condition/continuation condition) from to)) + +(define (sldb-backtrace-aux k from to) + (let ((l (map frame>string (substream (continuation>frames k) from to)))) + (let loop ((i from) (l l)) + (if (null? l) + '() + (cons (list i (car l)) (loop (1+ i) (cdr l))))))) + +;; Stack parser fails for this: +;; (map (lambda (x) x) "/tmp/x.x") + +(define (continuation>frames k) + (let loop ((frame (continuation->stack-frame k))) + (cond ((not frame) (stream)) + (else + (let ((next (ignore-errors + (lambda () (stack-frame/next-subproblem frame))))) + (cons-stream frame + (if (condition? next) + (stream next) + (loop next)))))))) + +(define (frame>string frame) + (if (condition? frame) + (format #f "Bogus frame: ~a ~a" frame + (condition/report-string frame)) + (with-string-output-port (lambda (p) (print-frame frame p))))) + +(define (print-frame frame port) + (define (invalid-subexpression? subexpression) + (or (debugging-info/undefined-expression? subexpression) + (debugging-info/unknown-expression? subexpression))) + (define (invalid-expression? expression) + (or (debugging-info/undefined-expression? expression) + (debugging-info/compiled-code? expression))) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((debugging-info/compiled-code? expression) + (write-string ";unknown compiled code" port)) + ((not (debugging-info/undefined-expression? expression)) + (fluid-let ((*unparse-primitives-by-name?* #t)) + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression)) + port))) + ((debugging-info/noise? expression) + (write-string ";" port) + (write-string ((debugging-info/noise expression) #f) + port)) + (else + (write-string ";undefined expression" port)))))) + +(define (substream s from to) + (let loop ((i 0) (l '()) (s s)) + (cond ((or (= i to) (stream-null? s)) (reverse l)) + ((< i from) (loop (1+ i) l (stream-cdr s))) + (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s)))))) + +(define (swank:frame-locals-and-catch-tags _ frame) + (list (map frame-var>elisp (frame-vars (sldb-get-frame frame))) + '())) + +(define (frame-vars frame) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((environment? environment) + (environment>frame-vars environment)) + (else '()))))) + +(define (environment>frame-vars environment) + (let loop ((e environment)) + (cond ((environment->package e) '()) + (else (append (environment-bindings e) + (if (environment-has-parent? e) + (loop (environment-parent e)) + '())))))) + +(define (frame-var>elisp b) + (list ':name (write-to-string (car b)) + ':value (cond ((null? (cdr b)) "{unavailable}") + (else (>line (cadr b)))) + ':id 0)) + +(define (sldb-get-frame index) + (stream-ref (continuation>frames + (condition/continuation + (sldb-state.condition *sldb-state*))) + index)) + +(define (frame-var-value frame var) + (let ((binding (list-ref (frame-vars frame) var))) + (cond ((cdr binding) (cadr binding)) + (else unspecific)))) + +(define (swank:inspect-frame-var _ frame var) + (reset-inspector) + (inspect-object (frame-var-value (sldb-get-frame frame) var))) + + +;;;; Completion + +(define (swank:simple-completions _ string package) + (let ((strings (all-completions string (user-env package) string-prefix?))) + (list (sort strings stringstring (environment-names env)))) + (keep-matching-items ss (lambda (s) (match? pattern s))))) + +;; symbol->string is too slow +(define %symbol->string symbol-name) + +(define (environment-names env) + (append (environment-bound-names env) + (if (environment-has-parent? env) + (environment-names (environment-parent env)) + '()))) + +(define (longest-common-prefix strings) + (define (common-prefix s1 s2) + (substring s1 0 (string-match-forward s1 s2))) + (reduce common-prefix "" strings)) + + +;;;; Apropos + +(define (swank:apropos-list-for-emacs _ name #!optional + external-only case-sensitive package) + (let* ((pkg (and (string? package) + (find-package (read-from-string package)))) + (parent (and (not (default-object? external-only)) + (elisp-false? external-only))) + (ss (append-map (lambda (p) + (map (lambda (s) (cons p s)) + (apropos-list name p (and pkg parent)))) + (if pkg (list pkg) (all-packages)))) + (ss (sublist ss 0 (min (length ss) 200)))) + (map (lambda (e) + (let ((p (car e)) (s (cdr e))) + (list ':designator (format #f "~a ~a" s (package/name p)) + ':variable (>line + (ignore-errors + (lambda () (package-lookup p s))))))) + ss))) + +(define (swank:list-all-package-names . _) + (map (lambda (p) (write-to-string (package/name p))) + (all-packages))) + +(define (all-packages) + (define (package-and-children package) + (append (list package) + (append-map package-and-children (package/children package)))) + (package-and-children system-global-package)) + + +;;;; Inspector + +(define-structure (inspector-state (conc-name istate.)) + object parts next previous content) + +(define istate #f) + +(define (reset-inspector) + (set! istate #f)) + +(define (swank:init-inspector _ string) + (reset-inspector) + (inspect-object (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (inspect-object o) + (let ((previous istate) + (content (inspect o)) + (parts (make-eqv-hash-table))) + (set! istate (make-inspector-state o parts #f previous content)) + (if previous (set-istate.next! previous istate)) + (istate>elisp istate))) + +(define (istate>elisp istate) + (list ':title (>line (istate.object istate)) + ':id (assign-index (istate.object istate) (istate.parts istate)) + ':content (prepare-range (istate.parts istate) + (istate.content istate) + 0 500))) + +(define (assign-index o parts) + (let ((i (hash-table/count parts))) + (hash-table/put! parts i o) + i)) + +(define (prepare-range parts content from to) + (let* ((cs (substream content from to)) + (ps (prepare-parts cs parts))) + (list ps + (if (< (length cs) (- to from)) + (+ from (length cs)) + (+ to 1000)) + from to))) + +(define (prepare-parts ps parts) + (define (line label value) + `(,(format #f "~a: " label) + (:value ,(>line value) ,(assign-index value parts)) + "\n")) + (append-map (lambda (p) + (cond ((string? p) (list p)) + ((symbol? p) (list (symbol->string p))) + (#t + (case (car p) + ((line) (apply line (cdr p))) + (else (error "Invalid part:" p)))))) + ps)) + +(define (swank:inspect-nth-part _ index) + (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part))) + +(define (swank:quit-inspector _) + (reset-inspector)) + +(define (swank:inspector-pop _) + (cond ((istate.previous istate) + (set! istate (istate.previous istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-next _) + (cond ((istate.next istate) + (set! istate (istate.next istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-range _ from to) + (prepare-range (istate.parts istate) + (istate.content istate) + from to)) + +(define-syntax stream* + (syntax-rules () + ((stream* tail) tail) + ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...))))) + +(define (iline label value) `(line ,label ,value)) + +(define-generic inspect (o)) + +(define-method inspect ((o )) + (cond ((environment? o) (inspect-environment o)) + ((vector? o) (inspect-vector o)) + ((procedure? o) (inspect-procedure o)) + ((compiled-code-block? o) (inspect-code-block o)) + ;;((system-pair? o) (inspect-system-pair o)) + ((probably-scode? o) (inspect-scode o)) + (else (inspect-fallback o)))) + +(define (inspect-fallback o) + (let* ((class (object-class o)) + (slots (class-slots class))) + (stream* + (iline "Class" class) + (let loop ((slots slots)) + (cond ((null? slots) (stream)) + (else + (let ((n (slot-name (car slots)))) + (stream* (iline n (slot-value o n)) + (loop (cdr slots)))))))))) + +(define-method inspect ((o )) + (if (or (pair? (cdr o)) (null? (cdr o))) + (inspect-list o) + (inspect-cons o))) + +(define (inspect-cons o) + (stream (iline "car" (car o)) + (iline "cdr" (cdr o)))) + +(define (inspect-list o) + (let loop ((i 0) (o o)) + (cond ((null? o) (stream)) + ((or (pair? (cdr o)) (null? (cdr o))) + (stream* (iline i (car o)) + (loop (1+ i) (cdr o)))) + (else + (stream (iline i (car o)) + (iline "tail" (cdr o))))))) + +(define (inspect-environment o) + (stream* + (iline "(package)" (environment->package o)) + (let loop ((bs (environment-bindings o))) + (cond ((null? bs) + (if (environment-has-parent? o) + (stream (iline "()" (environment-parent o))) + (stream))) + (else + (let* ((b (car bs)) (s (car b))) + (cond ((null? (cdr b)) + (stream* s " {" (environment-reference-type o s) "}\n" + (loop (cdr bs)))) + (else + (stream* (iline s (cadr b)) + (loop (cdr bs))))))))))) + +(define (inspect-vector o) + (let ((len (vector-length o))) + (let loop ((i 0)) + (cond ((= i len) (stream)) + (else (stream* (iline i (vector-ref o i)) + (loop (1+ i)))))))) + +(define (inspect-procedure o) + (cond ((primitive-procedure? o) + (stream (iline "name" (primitive-procedure-name o)) + (iline "arity" (primitive-procedure-arity o)) + (iline "doc" (primitive-procedure-documentation o)))) + ((compound-procedure? o) + (stream (iline "arity" (procedure-arity o)) + (iline "lambda" (procedure-lambda o)) + (iline "env" (ignore-errors + (lambda () (procedure-environment o)))))) + (else + (stream + (iline "block" (compiled-entry/block o)) + (with-output-to-string (lambda () (compiler:disassemble o))))))) + +(define (inspect-code-block o) + (stream-append + (let loop ((i (compiled-code-block/constants-start o))) + (cond ((>= i (compiled-code-block/constants-end o)) (stream)) + (else + (stream* + (iline i (system-vector-ref o i)) + (loop (+ i compiled-code-block/bytes-per-object)))))) + (stream (iline "debuginfo" (compiled-code-block/debugging-info o)) + (iline "env" (compiled-code-block/environment o)) + (with-output-to-string (lambda () (compiler:disassemble o)))))) + +(define (inspect-scode o) + (stream (pprint-to-string o))) + +(define (probably-scode? o) + (define tests (list access? assignment? combination? comment? + conditional? definition? delay? disjunction? lambda? + quotation? sequence? the-environment? variable?)) + (let loop ((tests tests)) + (cond ((null? tests) #f) + (((car tests) o)) + (else (loop (cdr tests)))))) + +(define (inspect-system-pair o) + (stream (iline "car" (system-pair-car o)) + (iline "cdr" (system-pair-cdr o)))) + + +;;;; Auxilary functions + +(define nil '()) +(define t 't) +(define (elisp-false? o) (member o '(nil ()))) +(define (elisp-true? o) (not (elisp-false? o))) +(define (>line o) + (let ((r (write-to-string o 100))) + (cond ((not (car r)) (cdr r)) + (else (string-append (cdr r) " .."))))) +;; Must compile >line otherwise we can't write unassigend-reference-traps. +(set! >line (compile-procedure >line)) +(define (read-from-string s) (with-input-from-string s read)) +(define (pprint-to-string o) + (with-string-output-port + (lambda (p) + (fluid-let ((*unparser-list-breadth-limit* 10) + (*unparser-list-depth-limit* 4) + (*unparser-string-length-limit* 100)) + (pp o p))))) +;(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (package-lookup package name) + (let ((p (if (package? package) package (find-package package)))) + (environment-lookup (package/environment p) name))) +(define log-port (current-output-port)) +(define (log-event fstring . args) + ;;(apply format log-port fstring args) + #f + ) + +;;; swank-mit-scheme.scm ends here diff --git a/elpa/slime-20200319.1939/contrib/swank-mlworks.sml b/elpa/slime-20200319.1939/contrib/swank-mlworks.sml new file mode 100644 index 00000000..3efac53e --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-mlworks.sml @@ -0,0 +1,348 @@ +(* swank-mlworks.sml -- SWANK server for MLWorks + * + * This code has been placed in the Public Domain. + *) + +(* This is an experiment to see how the interfaces/modules would look + * in a language with a supposedly "good" module system. + * + * MLWorks is probably the only SML implementation that tries to + * support "interactive programming". Since MLWorks wasn't maintained + * the last 15 or so years, big chunks of the SML Basis Library are + * missing or not the way as required by the standard. That makes it + * rather hard to do anything; it also shows that MLWorks hasn't been + * "used in anger" for a long time. + *) + +structure Swank = struct + + structure Util = struct + fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v + fun stringToUtf8 s = Byte.stringToBytes s + end + + structure Map = struct + datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref, + eq: ('a * 'a) -> bool} + + fun stringMap () = + Alist {list = ref [], + eq = (fn (x:string,y:string) => x = y)} + + + fun lookup (Alist {list, eq}, key) = + let fun search [] = NONE + | search ((key', value) :: xs) = + if eq (key', key) then SOME value + else search xs + in search (!list) + end + + fun put (Alist {list, eq}, key, value) = + let val l = (key, value) :: (!list) + in list := l + end + + end + + structure CharBuffer = struct + local + structure C = CharArray + datatype buffer = B of {array : C.array ref, + index: int ref} + in + + fun new hint = B {array = ref (C.array (hint, #"\000")), + index = ref 0} + + fun append (buffer as B {array, index}, char) = + let val a = !array + val i = !index + val len = C.length a + in if i < len then + (C.update (a, i, char); + index := i + 1; + ()) + else let val aa = C.array (2 * len, #"\000") + fun copy (src, dst) = + let val len = C.length src + fun loop i = + if i = len then () + else (C.update (dst, i, C.sub (src, i)); + loop (i + 1)) + in loop 0 end + in copy (a, aa); + C.update (aa, i, char); + array := aa; + index := i + 1; + () + end + end + + fun toString (B {array, index}) = + let val a = !array + val i = !index + in CharVector.tabulate (i, fn i => C.sub (a, i)) end + + end + + end + + + structure Sexp = struct + structure Type = struct + datatype sexp = Int of int + | Str of string + | Lst of sexp list + | Sym of string + | QSym of string * string + | T + | Nil + | Quote + end + open Type + + exception ReadError + + fun fromUtf8 v = + let val len = Word8Vector.length v + val index = ref 0 + fun getc () = + case getc' () of + SOME c => c + | NONE => raise ReadError + and getc' () = + let val i = !index + in if i = len then NONE + else (index := i + 1; + SOME (Byte.byteToChar (Word8Vector.sub (v, i)))) + end + and ungetc () = index := !index - 1 + and sexp () : sexp = + case getc () of + #"\"" => string (CharBuffer.new 100) + | #"(" => lst () + | #"'" => Lst [Quote, sexp ()] + | _ => (ungetc(); token ()) + and string buf : sexp = + case getc () of + #"\"" => Str (CharBuffer.toString buf) + | #"\\" => (CharBuffer.append (buf, getc ()); string buf) + | c => (CharBuffer.append (buf, c); string buf) + and lst () = + let val x = sexp () + in case getc () of + #")" => Lst [x] + | #" " => let val Lst y = lst () in Lst (x :: y) end + | _ => raise ReadError + end + and token () = + let val tok = token' (CharBuffer.new 50) + val c0 = String.sub (tok, 0) + in if Char.isDigit c0 then (case Int.fromString tok of + SOME i => Int i + | NONE => raise ReadError) + else + Sym (tok) + end + and token' buf : string = + case getc' () of + NONE => CharBuffer.toString buf + | SOME #"\\" => (CharBuffer.append (buf, getc ()); + token' buf) + | SOME #" " => (ungetc (); CharBuffer.toString buf) + | SOME #")" => (ungetc (); CharBuffer.toString buf) + | SOME c => (CharBuffer.append (buf, c); token' buf) + in + sexp () + end + + fun toString sexp = + case sexp of + (Str s) => "\"" ^ String.toCString s ^ "\"" + | (Lst []) => "nil" + | (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")" + | Sym (name) => name + | QSym (pkg, name) => pkg ^ ":" ^ name + | Quote => "quote" + | T => "t" + | Nil => "nil" + | Int i => Int.toString i + + fun toUtf8 sexp = Util.stringToUtf8 (toString sexp) + end + + structure Net = struct + local + structure S = Socket + structure I = INetSock + structure W = Word8Vector + + fun createSocket (port) = + let val sock : S.passive I.stream_sock = I.TCP.socket () + val SOME localhost = NetHostDB.fromString "127.0.0.1" + in + S.Ctl.setREUSEADDR (sock, true); + S.bind (sock, I.toAddr (localhost, port)); + S.listen (sock, 2); + sock + end + + fun addrToString sockAddr = + let val (ip, port) = I.fromAddr sockAddr + in NetHostDB.toString ip ^ ":" ^ Int.toString port + end + + exception ShortRead of W.vector + exception InvalidHexString of string + in + + fun acceptConnection port = + let val sock = createSocket port + val addr = S.Ctl.getSockName sock + val _ = print ("Listening on: " ^ addrToString addr ^ "\n") + val (peer, addr) = S.accept sock + in + S.close sock; + print ("Connection from: " ^ addrToString addr ^ "\n"); + peer + end + + fun receivePacket socket = + let val v = S.recvVec (socket, 6) + val _ = if W.length v = 6 then () + else raise ShortRead v + val s = Util.utf8ToString v + val _ = print ("s = " ^ s ^ "\n") + val len = + case StringCvt.scanString (Int.scan StringCvt.HEX) s of + SOME len => len + | NONE => raise InvalidHexString s + val _ = print ("len = " ^ Int.toString len ^ "\n") + val payload = S.recvVec (socket, len) + val plen = W.length payload + val _ = print ("plen = " ^ Int.toString plen ^ "\n") + val _ = if plen = len then () + else raise ShortRead payload + in + payload + end + + fun nibbleToHex i:string = Int.fmt StringCvt.HEX i + + fun loadNibble i pos = + Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i, + Word.fromInt (pos * 4)), + 0wxf)) + + fun hexDigit i pos = nibbleToHex (loadNibble i pos) + + fun lenToHex i = + concat [hexDigit i 5, + hexDigit i 4, + hexDigit i 3, + hexDigit i 2, + hexDigit i 1, + hexDigit i 0] + + fun sendPacket (payload:W.vector, socket) = + let val len = W.length payload + val header = Util.stringToUtf8 (lenToHex len) + val packet = W.concat [header, payload] + in print ("len = " ^ Int.toString len ^ "\n" + ^ "header = " ^ lenToHex len ^ "\n" + ^ "paylad = " ^ Util.utf8ToString payload ^ "\n"); + S.sendVec (socket, {buf = packet, i = 0, sz = NONE}) + end + + end + end + + structure Rpc = struct + open Sexp.Type + + val funTable : (string, sexp list -> sexp) Map.map + = Map.stringMap () + + fun define name f = Map.put (funTable, name, f) + + exception UnknownFunction of string + fun call (name, args) = + (print ("call: " ^ name ^ "\n"); + case Map.lookup (funTable, name) of + SOME f => f args + | NONE => raise UnknownFunction name) + + + local fun getpid () = + Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())) + in + fun connectionInfo [] = + Lst [Sym ":pid", Int (getpid ()), + Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks", + Sym ":name", Str "mlworks", + Sym ":version", Str "2.x"], + Sym ":machine", Lst [Sym ":instance", Str "", + Sym ":type", Str "", + Sym ":version", Str ""], + Sym ":features", Nil, + Sym ":package", Lst [Sym ":name", Str "root", + Sym ":prompt", Str "-"]] + end + + fun nyi _ = Nil + + local structure D = Shell.Dynamic + in + fun interactiveEval [Str string] = + let val x = D.eval string + in Str (concat [D.printValue x, " : ", D.printType (D.getType x)]) + end + end + + val _ = + (define "swank:connection-info" connectionInfo; + define "swank:swank-require" nyi; + define "swank:interactive-eval" interactiveEval; + ()) + end + + structure EventLoop = struct + open Sexp.Type + + fun execute (sexp, pkg) = + (print ("sexp = " ^ (Sexp.toString sexp) ^ "\n"); + case sexp of + Lst (Sym name :: args) => Rpc.call (name, args)) + + fun emacsRex (sexp, pkg, id as Int _, sock) = + let val result = (Lst [Sym (":ok"), execute (sexp, pkg)] + handle exn => (Lst [Sym ":abort", + Str (exnName exn ^ ": " + ^ exnMessage exn)])) + val reply = Lst [Sym ":return", result, id] + in Net.sendPacket (Sexp.toUtf8 reply, sock) + end + + fun dispatch (Lst ((Sym key) :: args), sock) = + case key of + ":emacs-rex" => let val [sexp, pkg, _, id] = args + in emacsRex (sexp, pkg, id, sock) + end + + fun processRequests socket:unit = + let val sexp = Sexp.fromUtf8 (Net.receivePacket socket) + in print ("request: " + ^ Util.utf8ToString (Sexp.toUtf8 sexp) + ^ "\n"); + dispatch (sexp, socket); + processRequests socket + end + + end + + (* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *) + val _ = () + end + +(* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *) diff --git a/elpa/slime-20200319.1939/contrib/swank-mrepl.lisp b/elpa/slime-20200319.1939/contrib/swank-mrepl.lisp new file mode 100644 index 00000000..cc8ce811 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-mrepl.lisp @@ -0,0 +1,162 @@ +;;; swank-mrepl.lisp +;; +;; Licence: public domain + +(in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((api '( + *emacs-connection* + channel + channel-id + define-channel-method + defslimefun + dcase + log-event + process-requests + send-to-remote-channel + use-threads-p + wait-for-event + with-bindings + with-connection + with-top-level-restart + with-slime-interrupts + ))) + (eval `(defpackage #:swank-api + (:use) + (:import-from #:swank . ,api) + (:export . ,api))))) + +(defpackage :swank-mrepl + (:use :cl :swank-api) + (:export #:create-mrepl)) + +(in-package :swank-mrepl) + +(defclass listener-channel (channel) + ((remote :initarg :remote) + (env :initarg :env) + (mode :initform :eval) + (tag :initform nil))) + +(defun package-prompt (package) + (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) + (cons (package-name package) (package-nicknames package)))) + +(defslimefun create-mrepl (remote) + (let* ((pkg *package*) + (conn *emacs-connection*) + (thread (if (use-threads-p) + (spawn-listener-thread conn) + nil)) + (ch (make-instance 'listener-channel :remote remote :thread thread))) + (setf (slot-value ch 'env) (initial-listener-env ch)) + (when thread + (swank/backend:send thread `(:serve-channel ,ch))) + (list (channel-id ch) + (swank/backend:thread-id (or thread (swank/backend:current-thread))) + (package-name pkg) + (package-prompt pkg)))) + +(defun initial-listener-env (listener) + `((*package* . ,*package*) + (*standard-output* . ,(make-listener-output-stream listener)) + (*standard-input* . ,(make-listener-input-stream listener)))) + +(defun spawn-listener-thread (connection) + (swank/backend:spawn + (lambda () + (with-connection (connection) + (dcase (swank/backend:receive) + ((:serve-channel c) + (loop + (with-top-level-restart (connection (drop-unprocessed-events c)) + (process-requests nil))))))) + :name "mrepl thread")) + +(defun drop-unprocessed-events (channel) + (with-slots (mode) channel + (let ((old-mode mode)) + (setf mode :drop) + (unwind-protect + (process-requests t) + (setf mode old-mode))) + (send-prompt channel))) + +(define-channel-method :process ((c listener-channel) string) + (log-event ":process ~s~%" string) + (with-slots (mode remote) c + (ecase mode + (:eval (mrepl-eval c string)) + (:read (mrepl-read c string)) + (:drop)))) + +(defun mrepl-eval (channel string) + (with-slots (remote env) channel + (let ((aborted t)) + (with-bindings env + (unwind-protect + (let ((result (with-slime-interrupts (read-eval-print string)))) + (send-to-remote-channel remote `(:write-result ,result)) + (setq aborted nil)) + (setf env (loop for (sym) in env + collect (cons sym (symbol-value sym)))) + (cond (aborted + (send-to-remote-channel remote `(:evaluation-aborted))) + (t + (send-prompt channel)))))))) + +(defun send-prompt (channel) + (with-slots (env remote) channel + (let ((pkg (or (cdr (assoc '*package* env)) *package*)) + (out (cdr (assoc '*standard-output* env))) + (in (cdr (assoc '*standard-input* env)))) + (when out (force-output out)) + (when in (clear-input in)) + (send-to-remote-channel remote `(:prompt ,(package-name pkg) + ,(package-prompt pkg)))))) + +(defun mrepl-read (channel string) + (with-slots (tag) channel + (assert tag) + (throw tag string))) + +(defun read-eval-print (string) + (with-input-from-string (in string) + (setq / ()) + (loop + (let* ((form (read in nil in))) + (cond ((eq form in) (return)) + (t (setq / (multiple-value-list (eval (setq + form)))))))) + (force-output) + (if / + (format nil "~{~s~%~}" /) + "; No values"))) + +(defun make-listener-output-stream (channel) + (let ((remote (slot-value channel 'remote))) + (swank/backend:make-output-stream + (lambda (string) + (send-to-remote-channel remote `(:write-string ,string)))))) + +(defun make-listener-input-stream (channel) + (swank/backend:make-input-stream (lambda () (read-input channel)))) + +(defun set-mode (channel new-mode) + (with-slots (mode remote) channel + (unless (eq mode new-mode) + (send-to-remote-channel remote `(:set-read-mode ,new-mode))) + (setf mode new-mode))) + +(defun read-input (channel) + (with-slots (mode tag remote) channel + (force-output) + (let ((old-mode mode) + (old-tag tag)) + (setf tag (cons nil nil)) + (set-mode channel :read) + (unwind-protect + (catch tag (process-requests nil)) + (setf tag old-tag) + (set-mode channel old-mode))))) + +(provide :swank-mrepl) diff --git a/elpa/slime-20200319.1939/contrib/swank-package-fu.lisp b/elpa/slime-20200319.1939/contrib/swank-package-fu.lisp new file mode 100644 index 00000000..a22807a1 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-package-fu.lisp @@ -0,0 +1,65 @@ + +(in-package :swank) + +(defslimefun package= (string1 string2) + (let* ((pkg1 (guess-package string1)) + (pkg2 (guess-package string2))) + (and pkg1 pkg2 (eq pkg1 pkg2)))) + +(defslimefun export-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (export `(,(from-string symbol-str)) package))))) + +(defslimefun unexport-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (unexport `(,(from-string symbol-str)) package))))) + +#+sbcl +(defun list-structure-symbols (name) + (let ((dd (sb-kernel:find-defstruct-description name ))) + (list* name + (sb-kernel:dd-default-constructor dd) + (sb-kernel:dd-predicate-name dd) + (sb-kernel::dd-copier-name dd) + (mapcar #'sb-kernel:dsd-accessor-name + (sb-kernel:dd-slots dd))))) + +#+ccl +(defun list-structure-symbols (name) + (let ((definition (gethash name ccl::%defstructs%))) + (list* name + (ccl::sd-constructor definition) + (ccl::sd-refnames definition)))) + +(defun list-class-symbols (name) + (let* ((class (find-class name)) + (slots (swank-mop:class-direct-slots class))) + (labels ((extract-symbol (name) + (if (and (consp name) (eql (car name) 'setf)) + (cadr name) + name)) + (slot-accessors (slot) + (nintersection (copy-list (swank-mop:slot-definition-readers slot)) + (copy-list (swank-mop:slot-definition-readers slot)) + :key #'extract-symbol))) + (list* (class-name class) + (mapcan #'slot-accessors slots))))) + +(defslimefun export-structure (name package) + (let ((*package* (guess-package package))) + (when *package* + (let* ((name (from-string name)) + (symbols (cond #+(or sbcl ccl) + ((or (not (find-class name nil)) + (subtypep name 'structure-object)) + (list-structure-symbols name)) + (t + (list-class-symbols name))))) + (export symbols) + symbols)))) + +(provide :swank-package-fu) diff --git a/elpa/slime-20200319.1939/contrib/swank-presentation-streams.lisp b/elpa/slime-20200319.1939/contrib/swank-presentation-streams.lisp new file mode 100644 index 00000000..93a6d1d4 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-presentation-streams.lisp @@ -0,0 +1,334 @@ +;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg +;;; Matthias Koeppe +;;; Helmut Eller +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-presentations)) + +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. + +;; Control +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) + +;; doing it + +(defmacro presenting-object (object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl" + `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) + +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () ,@body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +;;; Get pretty printer patches for SBCL at load (not compile) time. +#+#:disable-dangerous-patching ; #+sbcl +(eval-when (:load-toplevel) + (handler-bind ((simple-error + (lambda (c) + (declare (ignore c)) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank/sbcl::with-debootstrapping + (load (make-pathname + :name "sbcl-pprint-patch" + :type "lisp" + :directory (pathname-directory + swank-loader:*source-directory*))))))) + +(let ((last-stream nil) + (last-answer nil)) + (defun slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we +don't want to present anything. +Two special return values: +:DEDICATED -- Output ends up on a dedicated output stream +:REPL-RESULT -- Output ends up on the :repl-results target. +" + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (fboundp 'pretty-print::enqueue-annotation) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) + #+sbcl + (let () + (declare (notinline sb-pretty::pretty-stream-target)) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream)))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) + (loop for connection in *connections* + thereis (or (and (eq stream (connection.dedicated-output connection)) + :dedicated) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)) + (and (eq stream (connection.repl-results connection)) + :repl-result))))))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *enable-presenting-readable-objects*) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (and (typep stream 'pp:pretty-stream) + (fboundp 'pp::enqueue-annotation)) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (let ((enqueue-annotation + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) + (if (and enqueue-annotation + (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) + (funcall enqueue-annotation stream function arg) + (funcall function arg stream nil)))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p) + (target)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string "<" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-start ,pid ,target))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string ">" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-end ,pid ,target))))))) + +(defun presenting-object-1 (object stream continue) + "Uses the bridge mechanism with two messages >id and ) + (pp-end-block stream ">")) + nil)) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) + (ccl::def-load-pointers clear-presentations () + (swank::clear-presentation-tables))) + +(in-package :swank) + +#+cmu +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (defun monkey-patch-stream-printing () + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper))) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + + (defun monkey-patch-stream-printing () + (sb-ext:without-package-locks + (when (eq (fdefinition 'sb-impl::%print-unreadable-object) + *saved-%print-unreadable-object*) + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream &rest args) + (presenting-object object stream + (apply *saved-%print-unreadable-object* + object stream args))))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method)))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (defun monkey-patch-stream-printing () + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper))) + +#-(or allegro sbcl cmu openmcl) +(defun monkey-patch-stream-printing () + (values)) + +;; Hook into SWANK. + +(defslimefun init-presentation-streams () + (monkey-patch-stream-printing) + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* + 'present-repl-results-via-presentation-streams)) + +(provide :swank-presentation-streams) diff --git a/elpa/slime-20200319.1939/contrib/swank-presentations.lisp b/elpa/slime-20200319.1939/contrib/swank-presentations.lisp new file mode 100644 index 00000000..11326afe --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-presentations.lisp @@ -0,0 +1,246 @@ +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: Alan Ruttenberg +;; Luke Gorrie +;; Helmut Eller +;; Matthias Koeppe +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +;;;; Recording and accessing results of computations + +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved for later lookup.") + +(defvar *object-to-presentation-id* + (make-weak-key-hash-table :test 'eq) + "Store the mapping of objects to numeric identifiers") + +(defvar *presentation-id-to-object* + (make-weak-value-hash-table :test 'eql) + "Store the mapping of numeric identifiers to objects") + +(defun clear-presentation-tables () + (clrhash *object-to-presentation-id*) + (clrhash *presentation-id-to-object*)) + +(defvar *presentation-counter* 0 "identifier counter") + +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + +;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the +;; rest of slime isn't thread safe either), do we really care? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) + +(defslimefun lookup-presented-object (id) + "Retrieve the object corresponding to ID. +The secondary value indicates the absence of an entry." + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (dcase id + ((:frame-var thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (inspector-nth-part part-index)))))) + +(defslimefun lookup-presented-object-or-lose (id) + "Get the result of the previous REPL evaluation with ID." + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (error "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun lookup-and-save-presented-object-or-lose (id) + "Get the object associated with ID and save it in the presentation tables." + (let ((obj (lookup-presented-object-or-lose id))) + (save-presented-object obj))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) + ;; Override a function in swank.lisp, so that + ;; presentations are associated with every REPL result. + (flet ((send (value) + (let ((id (and *record-repl-results* + (save-presented-object value)))) + (send-to-emacs `(:presentation-start ,id :repl-result)) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:presentation-end ,id :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result))))) + (fresh-line) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (mapc #'send values)))) + + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) + (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") + :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") + object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object-or-lose id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + +(defslimefun init-presentations () + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* 'present-repl-results)) + +(provide :swank-presentations) diff --git a/elpa/slime-20200319.1939/contrib/swank-quicklisp.lisp b/elpa/slime-20200319.1939/contrib/swank-quicklisp.lisp new file mode 100644 index 00000000..36545991 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-quicklisp.lisp @@ -0,0 +1,17 @@ +;;; swank-quicklisp.lisp -- Quicklisp support +;; +;; Authors: Matthew Kennedy +;; License: Public Domain +;; + +(in-package :swank) + +(defslimefun list-quicklisp-systems () + "Returns the Quicklisp systems list." + (if (member :quicklisp *features*) + (let ((ql-dist-name (find-symbol "NAME" "QL-DIST")) + (ql-system-list (find-symbol "SYSTEM-LIST" "QL"))) + (mapcar ql-dist-name (funcall ql-system-list))) + (error "Could not find Quicklisp already loaded."))) + +(provide :swank-quicklisp) diff --git a/elpa/slime-20200319.1939/contrib/swank-r6rs.scm b/elpa/slime-20200319.1939/contrib/swank-r6rs.scm new file mode 100644 index 00000000..4e480507 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-r6rs.scm @@ -0,0 +1,416 @@ +;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny +;; +;; Licence: public domain +;; Author: Helmut Eller +;; +;; This is a Swank server barely capable enough to process simple eval +;; requests from Emacs before dying. No fancy features like +;; backtraces, module redefintion, M-. etc. are implemented. Don't +;; even think about pc-to-source mapping. +;; +;; Despite standard modules, this file uses (swank os) and (swank sys) +;; which define implementation dependend functionality. There are +;; multiple modules in this files, which is probably not standardized. +;; + +;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c +(library (swank format) + (export format printf fprintf) + (import (rnrs)) + + (define (format f . args) + (call-with-string-output-port + (lambda (port) (apply fprintf port f args)))) + + (define (printf f . args) + (let ((port (current-output-port))) + (apply fprintf port f args) + (flush-output-port port))) + + (define (fprintf port f . args) + (let ((len (string-length f))) + (let loop ((i 0) (args args)) + (cond ((= i len) (assert (null? args))) + ((and (char=? (string-ref f i) #\~) + (< (+ i 1) len)) + (dispatch-format (string-ref f (+ i 1)) port (car args)) + (loop (+ i 2) (cdr args))) + (else + (put-char port (string-ref f i)) + (loop (+ i 1) args)))))) + + (define (dispatch-format char port arg) + (let ((probe (assoc char format-dispatch-table))) + (cond (probe ((cdr probe) arg port)) + (else (error "invalid format char: " char))))) + + (define format-dispatch-table + `((#\a . ,display) + (#\s . ,write) + (#\d . ,(lambda (arg port) (put-string port (number->string arg 10)))) + (#\x . ,(lambda (arg port) (put-string port (number->string arg 16)))) + (#\c . ,(lambda (arg port) (put-char port arg)))))) + + +;; CL-style restarts to let us continue after errors. +(library (swank restarts) + (export with-simple-restart compute-restarts invoke-restart restart-name + write-restart-report) + (import (rnrs)) + + (define *restarts* '()) + + (define-record-type restart + (fields name reporter continuation)) + + (define (with-simple-restart name reporter thunk) + (call/cc + (lambda (k) + (let ((old-restarts *restarts*) + (restart (make-restart name (coerce-to-reporter reporter) k))) + (dynamic-wind + (lambda () (set! *restarts* (cons restart old-restarts))) + thunk + (lambda () (set! *restarts* old-restarts))))))) + + (define (compute-restarts) *restarts*) + + (define (invoke-restart restart . args) + (apply (restart-continuation restart) args)) + + (define (write-restart-report restart port) + ((restart-reporter restart) port)) + + (define (coerce-to-reporter obj) + (cond ((string? obj) (lambda (port) (put-string port obj))) + (#t (assert (procedure? obj)) obj))) + + ) + +;; This module encodes & decodes messages from the wire and queues them. +(library (swank event-queue) + (export make-event-queue wait-for-event enqueue-event + read-event write-event) + (import (rnrs) + (rnrs mutable-pairs) + (swank format)) + + (define-record-type event-queue + (fields (mutable q) wait-fun) + (protocol (lambda (init) + (lambda (wait-fun) + (init '() wait-fun))))) + + (define (wait-for-event q pattern) + (or (poll q pattern) + (begin + ((event-queue-wait-fun q) q) + (wait-for-event q pattern)))) + + (define (poll q pattern) + (let loop ((lag #f) + (l (event-queue-q q))) + (cond ((null? l) #f) + ((event-match? (car l) pattern) + (cond (lag + (set-cdr! lag (cdr l)) + (car l)) + (else + (event-queue-q-set! q (cdr l)) + (car l)))) + (else (loop l (cdr l)))))) + + (define (event-match? event pattern) + (cond ((or (number? pattern) + (member pattern '(t nil))) + (equal? event pattern)) + ((symbol? pattern) #t) + ((pair? pattern) + (case (car pattern) + ((quote) (equal? event (cadr pattern))) + ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern))) + (else (and (pair? event) + (event-match? (car event) (car pattern)) + (event-match? (cdr event) (cdr pattern)))))) + (else (error "Invalid pattern: " pattern)))) + + (define (enqueue-event q event) + (event-queue-q-set! q + (append (event-queue-q q) + (list event)))) + + (define (write-event event port) + (let ((payload (call-with-string-output-port + (lambda (port) (write event port))))) + (write-length (string-length payload) port) + (put-string port payload) + (flush-output-port port))) + + (define (write-length len port) + (do ((i 24 (- i 4))) + ((= i 0)) + (put-string port + (number->string (bitwise-bit-field len (- i 4) i) + 16)))) + + (define (read-event port) + (let* ((header (string-append (get-string-n port 2) + (get-string-n port 2) + (get-string-n port 2))) + (_ (printf "header: ~s\n" header)) + (len (string->number header 16)) + (_ (printf "len: ~s\n" len)) + (payload (get-string-n port len))) + (printf "payload: ~s\n" payload) + (read (open-string-input-port payload)))) + + ) + +;; Entry points for SLIME commands. +(library (swank rpc) + (export connection-info interactive-eval + ;;compile-string-for-emacs + throw-to-toplevel sldb-abort + operator-arglist buffer-first-change + create-repl listener-eval) + (import (rnrs) + (rnrs eval) + (only (rnrs r5rs) scheme-report-environment) + (swank os) + (swank format) + (swank restarts) + (swank sys) + ) + + (define (connection-info . _) + `(,@'() + :pid ,(getpid) + :package (:name ">" :prompt ">") + :lisp-implementation (,@'() + :name ,(implementation-name) + :type "R6RS-Scheme"))) + + (define (interactive-eval string) + (call-with-values + (lambda () + (eval-in-interaction-environment (read-from-string string))) + (case-lambda + (() "; no value") + ((value) (format "~s" value)) + (values (format "values: ~s" values))))) + + (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel)) + + (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort)) + + (define (invoke-restart-by-name-or-nil name) + (let ((r (find (lambda (r) (eq? (restart-name r) name)) + (compute-restarts)))) + (if r (invoke-restart r) 'nil))) + + (define (create-repl target) + (list "" "")) + + (define (listener-eval string) + (call-with-values (lambda () (eval-region string)) + (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values))))) + + (define (eval-region string) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (eval-in-interaction-environment sexp)))) + + (define (read-from-string string) + (call-with-port (open-string-input-port string) read)) + + (define (operator-arglist . _) 'nil) + (define (buffer-first-change . _) 'nil) + + ) + +;; The server proper. Does the TCP stuff and exception handling. +(library (swank) + (export start-server) + (import (rnrs) + (rnrs eval) + (swank os) + (swank format) + (swank event-queue) + (swank restarts)) + + (define-record-type connection + (fields in-port out-port event-queue)) + + (define (start-server port) + (accept-connections (or port 4005) #f)) + + (define (start-server/port-file port-file) + (accept-connections #f port-file)) + + (define (accept-connections port port-file) + (let ((sock (make-server-socket port))) + (printf "Listening on port: ~s\n" (local-port sock)) + (when port-file + (write-port-file (local-port sock) port-file)) + (let-values (((in out) (accept sock (latin-1-codec)))) + (dynamic-wind + (lambda () #f) + (lambda () + (close-socket sock) + (serve in out)) + (lambda () + (close-port in) + (close-port out)))))) + + (define (write-port-file port port-file) + (call-with-output-file + (lambda (file) + (write port file)))) + + (define (serve in out) + (let ((err (current-error-port)) + (q (make-event-queue + (lambda (q) + (let ((e (read-event in))) + (printf "read: ~s\n" e) + (enqueue-event q e)))))) + (dispatch-loop (make-connection in out q)))) + + (define-record-type sldb-state + (fields level condition continuation next)) + + (define (dispatch-loop conn) + (let ((event (wait-for-event (connection-event-queue conn) 'x))) + (case (car event) + ((:emacs-rex) + (with-simple-restart + 'toplevel "Return to SLIME's toplevel" + (lambda () + (apply emacs-rex conn #f (cdr event))))) + (else (error "Unhandled event: ~s" event)))) + (dispatch-loop conn)) + + (define (recover thunk on-error-thunk) + (let ((ok #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (call-with-values thunk + (lambda vals + (set! ok #t) + (apply values vals)))) + (lambda () + (unless ok + (on-error-thunk)))))) + + ;; Couldn't resist to exploit the prefix feature. + (define rpc-entries (environment '(prefix (swank rpc) swank:))) + + (define (emacs-rex conn sldb-state form package thread tag) + (let ((out (connection-out-port conn))) + (recover + (lambda () + (with-exception-handler + (lambda (condition) + (call/cc + (lambda (k) + (sldb-exception-handler conn condition k sldb-state)))) + (lambda () + (let ((value (apply (eval (car form) rpc-entries) (cdr form)))) + (write-event `(:return (:ok ,value) ,tag) out))))) + (lambda () + (write-event `(:return (:abort) ,tag) out))))) + + (define (sldb-exception-handler connection condition k sldb-state) + (when (serious-condition? condition) + (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1)) + (out (connection-out-port connection))) + (write-event `(:debug 0 ,level ,@(debugger-info condition connection)) + out) + (dynamic-wind + (lambda () #f) + (lambda () + (sldb-loop connection + (make-sldb-state level condition k sldb-state))) + (lambda () (write-event `(:debug-return 0 ,level nil) out)))))) + + (define (sldb-loop connection state) + (apply emacs-rex connection state + (cdr (wait-for-event (connection-event-queue connection) + '(':emacs-rex . _)))) + (sldb-loop connection state)) + + (define (debugger-info condition connection) + (list `(,(call-with-string-output-port + (lambda (port) (print-condition condition port))) + ,(format " [type ~s]" (if (record? condition) + (record-type-name (record-rtd condition)) + )) + ()) + (map (lambda (r) + (list (format "~a" (restart-name r)) + (call-with-string-output-port + (lambda (port) + (write-restart-report r port))))) + (compute-restarts)) + '() + '())) + + (define (print-condition obj port) + (cond ((condition? obj) + (let ((list (simple-conditions obj))) + (case (length list) + ((0) + (display "Compuond condition with zero components" port)) + ((1) + (assert (eq? obj (car list))) + (print-simple-condition (car list) port)) + (else + (display "Compound condition:\n" port) + (for-each (lambda (c) + (display " " port) + (print-simple-condition c port) + (newline port)) + list))))) + (#t + (fprintf port "Non-condition object: ~s" obj)))) + + (define (print-simple-condition condition port) + (fprintf port "~a" (record-type-name (record-rtd condition))) + (case (count-record-fields condition) + ((0) #f) + ((1) + (fprintf port ": ") + (do-record-fields condition (lambda (name value) (write value port)))) + (else + (fprintf port ":") + (do-record-fields condition (lambda (name value) + (fprintf port "\n~a: ~s" name value)))))) + + ;; Call FUN with RECORD's rtd and parent rtds. + (define (do-record-rtds record fun) + (do ((rtd (record-rtd record) (record-type-parent rtd))) + ((not rtd)) + (fun rtd))) + + ;; Call FUN with RECORD's field names and values. + (define (do-record-fields record fun) + (do-record-rtds + record + (lambda (rtd) + (let* ((names (record-type-field-names rtd)) + (len (vector-length names))) + (do ((i 0 (+ 1 i))) + ((= i len)) + (fun (vector-ref names i) ((record-accessor rtd i) record))))))) + + ;; Return the number of fields in RECORD + (define (count-record-fields record) + (let ((i 0)) + (do-record-rtds + record (lambda (rtd) + (set! i (+ i (vector-length (record-type-field-names rtd)))))) + i)) + + ) diff --git a/elpa/slime-20200319.1939/contrib/swank-repl.lisp b/elpa/slime-20200319.1939/contrib/swank-repl.lisp new file mode 100644 index 00000000..259c9ea3 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-repl.lisp @@ -0,0 +1,441 @@ +;;; swank-repl.lisp --- Server side part of the Lisp listener. +;; +;; License: public domain +(in-package swank) + +(defpackage swank-repl + (:use cl swank/backend) + (:export *send-repl-results-function*) + (:import-from + swank + + *default-worker-thread-bindings* + + *loopback-interface* + + add-hook + *connection-closed-hook* + + eval-region + with-buffer-syntax + + connection + connection.socket-io + connection.repl-results + connection.user-input + connection.user-output + connection.user-io + connection.trace-output + connection.dedicated-output + connection.env + + multithreaded-connection + mconn.active-threads + mconn.repl-thread + mconn.auto-flush-thread + use-threads-p + + *emacs-connection* + default-connection + with-connection + + send-to-emacs + *communication-style* + handle-requests + wait-for-event + make-tag + thread-for-evaluation + socket-quest + + authenticate-client + encode-message + + auto-flush-loop + clear-user-input + + current-thread-id + cat + with-struct* + with-retry-restart + with-bindings + + package-string-for-prompt + find-external-format-or-lose + + defslimefun + + ;; FIXME: those should be exported from swank-repl only, but how to + ;; do that whithout breaking init files? + *use-dedicated-output-stream* + *dedicated-output-stream-port* + *globally-redirect-io*)) + +(in-package swank-repl) + +(defvar *use-dedicated-output-stream* nil + "When T swank will attempt to create a second connection to Emacs +which is used just to send output.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *dedicated-output-stream-buffering* + (if (eq *communication-style* :spawn) t nil) + "The buffering scheme that should be used for the output stream. +Valid values are nil, t, :line") + +(defvar *globally-redirect-io* :started-from-emacs + "When T globally redirect all standard streams to Emacs. +When :STARTED-FROM-EMACS redirect when launched by M-x slime") + +(defun globally-redirect-io-p () + (case *globally-redirect-io* + ((t) t) + (:started-from-emacs swank-loader:*started-from-emacs*))) + +(defun open-streams (connection properties) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (let* ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs))))) + (dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + connection + (getf properties :coding-system)))) + (in (make-input-stream input-fn)) + (out (or dedicated-output + (make-output-stream (make-output-function connection)))) + (io (make-two-way-stream in out)) + (repl-results (swank:make-output-stream-for-target connection + :repl-result))) + (typecase connection + (multithreaded-connection + (setf (mconn.auto-flush-thread connection) + (make-auto-flush-thread out)))) + (values dedicated-output in out io repl-results))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs." + (lambda (string) + (with-connection (connection) + (send-to-emacs `(:write-string ,string))))) + +(defun open-dedicated-output-stream (connection coding-system) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + (let ((socket (socket-quest *dedicated-output-stream-port* nil)) + (ef (find-external-format-or-lose coding-system))) + (unwind-protect + (let ((port (local-port socket))) + (encode-message `(:open-dedicated-output-stream ,port + ,coding-system) + (connection.socket-io connection)) + (let ((dedicated (accept-connection + socket + :external-format ef + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (authenticate-client dedicated) + (close-socket socket) + (setf socket nil) + dedicated)) + (when socket + (close-socket socket))))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :find-existing))) + (or (car (mconn.active-threads connection)) + (find-repl-thread connection))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :repl-thread))) + (find-repl-thread connection)) + +(defun find-repl-thread (connection) + (cond ((not (use-threads-p)) + (current-thread)) + (t + (let ((thread (mconn.repl-thread connection))) + (cond ((not thread) nil) + ((thread-alive-p thread) thread) + (t + (setf (mconn.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))))) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun repl-loop (connection) + (handle-requests connection)) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defslimefun create-repl (target &key coding-system) + (assert (eq target nil)) + (let ((conn *emacs-connection*)) + (initialize-streams-for-connection conn `(:coding-system ,coding-system)) + (with-struct* (connection. @ conn) + (setf (@ env) + `((*standard-input* . ,(@ user-input)) + ,@(unless (globally-redirect-io-p) + `((*standard-output* . ,(@ user-output)) + (*trace-output* . ,(or (@ trace-output) (@ user-output))) + (*error-output* . ,(@ user-output)) + (*debug-io* . ,(@ user-io)) + (*query-io* . ,(@ user-io)) + (*terminal-io* . ,(@ user-io)))))) + (maybe-redirect-global-io conn) + (add-hook *connection-closed-hook* 'update-redirection-after-close) + (typecase conn + (multithreaded-connection + (setf (mconn.repl-thread conn) + (spawn-repl-thread conn "repl-thread")))) + (list (package-name *package*) + (package-string-for-prompt *package*))))) + +(defun initialize-streams-for-connection (connection properties) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection properties) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun read-user-input-from-emacs () + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) + (let ((ok nil)) + (unwind-protect + (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defvar *listener-saved-value* nil) + +(defslimefun listener-save-value (slimefun &rest args) + "Apply SLIMEFUN to ARGS and save the value. +The saved value should be visible to all threads and retrieved via +LISTENER-GET-VALUE." + (setq *listener-saved-value* (apply slimefun args)) + t) + +(defslimefun listener-get-value () + "Get the last value saved by LISTENER-SAVE-VALUE. +The value should be produced as if it were requested through +LISTENER-EVAL directly, so that spacial variables *, etc are set." + (listener-eval (let ((*package* (find-package :keyword))) + (write-to-string '*listener-saved-value*)))) + +(defslimefun listener-eval (string &key (window-width nil window-width-p)) + (if window-width-p + (let ((*print-right-margin* window-width)) + (funcall *listener-eval-function* string)) + (funcall *listener-eval-function* string))) + +(defslimefun clear-repl-variables () + (let ((variables '(*** ** * /// // / +++ ++ +))) + (loop for variable in variables + do (setf (symbol-value variable) nil)))) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values)))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (swank:make-output-stream-for-target *emacs-connection* target)) + nil) + + + +;;;; IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (let ((stream (make-synonym-stream current-stream-var))) + (set stream-var stream) + (set-default-initial-binding stream-var `(quote ,stream))))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when (globally-redirect-io-p) + (cond (*saved-global-streams* + (warn "Streams already redirected.")) + (t + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)))))) + +(defun globally-redirect-io-to-connection (connection) + "Set the standard I/O streams to redirect to CONNECTION. +Assigns *CURRENT-* for all standard streams." + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-* to *REAL-* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to CONNECTION." + (when (and (globally-redirect-io-p) (null *global-stdio-connection*) + (connection.user-io connection)) + (unless *saved-global-streams* + (init-global-stream-redirection)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) (globally-redirect-io-p)) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(provide :swank-repl) diff --git a/elpa/slime-20200319.1939/contrib/swank-sbcl-exts.lisp b/elpa/slime-20200319.1939/contrib/swank-sbcl-exts.lisp new file mode 100644 index 00000000..6cbe09d9 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-sbcl-exts.lisp @@ -0,0 +1,67 @@ +;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL +;; +;; Authors: Tobias C. Rittweiler +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-arglists)) + +;; We need to do this so users can place `slime-sbcl-exts' into their +;; ~/.emacs, and still use any implementation they want. +#+sbcl +(progn + +;;; Display arglist of instructions. +;;; +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst)) + argument-forms) + (flet ((decode-instruction-arglist (instr-name instr-arglist) + (let ((decoded-arglist (decode-arglist instr-arglist))) + ;; The arglist of INST is (instruction ...INSTR-ARGLIST...). + (push 'sb-assem::instruction (arglist.required-args decoded-arglist)) + (values decoded-arglist + (list instr-name) + t)))) + (if (null argument-forms) + (call-next-method) + (destructuring-bind (instruction &rest args) argument-forms + (declare (ignore args)) + (let* ((instr-name + (typecase instruction + (arglist-dummy + (string-upcase (arglist-dummy.string-representation instruction))) + (symbol + (string-downcase instruction)))) + (instr-fn + #+#.(swank/backend:with-symbol 'op-encoder-name 'sb-assem) + (or (sb-assem::op-encoder-name instr-name) + (sb-assem::op-encoder-name (string-upcase instr-name))) + #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem) + (sb-assem::inst-emitter-symbol instr-name) + #+(and + (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)) + #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem)) + (gethash instr-name sb-assem:*assem-instructions*))) + (cond ((functionp instr-fn) + (with-available-arglist (arglist) (arglist instr-fn) + (decode-instruction-arglist instr-name arglist))) + ((fboundp instr-fn) + (with-available-arglist (arglist) (arglist instr-fn) + ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with + ;; current segment and current vop implicitly. + (decode-instruction-arglist instr-name + (if (or (get instr-fn :macro) + (macro-function instr-fn)) + arglist + (cddr arglist))))) + (t + (call-next-method)))))))) + + +) ; PROGN + +(provide :swank-sbcl-exts) diff --git a/elpa/slime-20200319.1939/contrib/swank-snapshot.lisp b/elpa/slime-20200319.1939/contrib/swank-snapshot.lisp new file mode 100644 index 00000000..52a87ed0 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-snapshot.lisp @@ -0,0 +1,67 @@ + +(defpackage swank-snapshot + (:use cl) + (:export restore-snapshot save-snapshot background-save-snapshot) + (:import-from swank defslimefun)) +(in-package swank-snapshot) + +(defslimefun save-snapshot (image-file) + (swank/backend:save-image image-file + (let ((c swank::*emacs-connection*)) + (lambda () (resurrect c)))) + (format nil "Dumped lisp to ~A" image-file)) + +(defslimefun restore-snapshot (image-file) + (let* ((conn swank::*emacs-connection*) + (stream (swank::connection.socket-io conn)) + (clone (swank/backend:dup (swank/backend:socket-fd stream))) + (style (swank::connection.communication-style conn)) + (repl (if (swank::connection.user-io conn) t)) + (args (list "--swank-fd" (format nil "~d" clone) + "--swank-style" (format nil "~s" style) + "--swank-repl" (format nil "~s" repl)))) + (swank::close-connection conn nil nil) + (swank/backend:exec-image image-file args))) + +(defslimefun background-save-snapshot (image-file) + (let ((connection swank::*emacs-connection*)) + (flet ((complete (success) + (let ((swank::*emacs-connection* connection)) + (swank::background-message + "Dumping lisp image ~A ~:[failed!~;succeeded.~]" + image-file success))) + (awaken () + (resurrect connection))) + (swank/backend:background-save-image image-file + :restart-function #'awaken + :completion-function #'complete) + (format nil "Started dumping lisp to ~A..." image-file)))) + +(in-package :swank) + +(defun swank-snapshot::resurrect (old-connection) + (setq *log-output* nil) + (init-log-output) + (clear-event-history) + (setq *connections* (delete old-connection *connections*)) + (format *error-output* "args: ~s~%" (command-line-args)) + (let* ((fd (read-command-line-arg "--swank-fd")) + (style (read-command-line-arg "--swank-style")) + (repl (read-command-line-arg "--swank-repl")) + (* (format *error-output* "fd=~s style=~s~%" fd style)) + (stream (make-fd-stream fd nil)) + (connection (make-connection nil stream style))) + (let ((*emacs-connection* connection)) + (when repl (swank-repl:create-repl nil)) + (background-message "~A" "Lisp image restored")) + (serve-requests connection) + (simple-repl))) + +(defun read-command-line-arg (name) + (let* ((args (command-line-args)) + (pos (position name args :test #'equal))) + (read-from-string (elt args (1+ pos))))) + +(in-package :swank-snapshot) + +(provide :swank-snapshot) diff --git a/elpa/slime-20200319.1939/contrib/swank-sprof.lisp b/elpa/slime-20200319.1939/contrib/swank-sprof.lisp new file mode 100644 index 00000000..675240ff --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-sprof.lisp @@ -0,0 +1,154 @@ +;;; swank-sprof.lisp +;; +;; Authors: Juho Snellman +;; +;; License: MIT +;; + +(in-package :swank) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-sprof)) + +#+sbcl(progn + +(defvar *call-graph* nil) +(defvar *node-numbers* nil) +(defvar *number-nodes* nil) + +(defun frame-name (name) + (if (consp name) + (case (first name) + ((sb-c::xep sb-c::tl-xep + sb-c::&more-processor + sb-c::top-level-form + sb-c::&optional-processor) + (second name)) + (sb-pcl::fast-method + (cdr name)) + ((flet labels lambda) + (let* ((in (member :in name))) + (if (stringp (cadr in)) + (append (ldiff name in) (cddr in)) + name))) + (t + name)) + name)) + +(defun pretty-name (name) + (let ((*package* (find-package :common-lisp-user)) + (*print-right-margin* most-positive-fixnum)) + (format nil "~S" (frame-name name)))) + +(defun samples-percent (count) + (sb-sprof::samples-percent *call-graph* count)) + +(defun node-values (node) + (values (pretty-name (sb-sprof::node-name node)) + (samples-percent (sb-sprof::node-count node)) + (samples-percent (sb-sprof::node-accrued-count node)))) + +(defun filter-swank-nodes (nodes) + (let ((swank-packages (load-time-value + (mapcar #'find-package + '(swank swank/rpc swank/mop + swank/match swank/backend))))) + (remove-if (lambda (node) + (let ((name (sb-sprof::node-name node))) + (and (symbolp name) + (member (symbol-package name) swank-packages + :test #'eq)))) + nodes))) + +(defun serialize-call-graph (&key exclude-swank) + (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*))) + (when exclude-swank + (setf nodes (filter-swank-nodes nodes))) + (setf nodes (sort (copy-list nodes) #'> + ;; :key #'sb-sprof::node-count))) + :key #'sb-sprof::node-accrued-count)) + (setf *number-nodes* (make-hash-table)) + (setf *node-numbers* (make-hash-table)) + (loop for node in nodes + for i from 1 + with total = 0 + collect (multiple-value-bind (name self cumulative) + (node-values node) + (setf (gethash node *node-numbers*) i + (gethash i *number-nodes*) node) + (incf total self) + (list i name self cumulative total)) into list + finally (return + (let ((rest (- 100 total))) + (return (append list + `((nil "Elsewhere" ,rest nil nil))))))))) + +(defslimefun swank-sprof-get-call-graph (&key exclude-swank) + (when (setf *call-graph* (sb-sprof:report :type nil)) + (serialize-call-graph :exclude-swank exclude-swank))) + +(defslimefun swank-sprof-expand-node (index) + (let* ((node (gethash index *number-nodes*))) + (labels ((caller-count (v) + (loop for e in (sb-sprof::vertex-edges v) do + (when (eq (sb-sprof::edge-vertex e) node) + (return-from caller-count (sb-sprof::call-count e)))) + 0) + (serialize-node (node count) + (etypecase node + (sb-sprof::cycle + (list (sb-sprof::cycle-index node) + (sb-sprof::cycle-name node) + (samples-percent count))) + (sb-sprof::node + (let ((name (node-values node))) + (list (gethash node *node-numbers*) + name + (samples-percent count))))))) + (list :callers (loop for node in + (sort (copy-list (sb-sprof::node-callers node)) #'> + :key #'caller-count) + collect (serialize-node node + (caller-count node))) + :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node)) + #'> + :key #'sb-sprof::call-count))) + (loop for edge in edges + collect + (serialize-node (sb-sprof::edge-vertex edge) + (sb-sprof::call-count edge)))))))) + +(defslimefun swank-sprof-disassemble (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (with-output-to-string (s) + (typecase debug-info + (sb-impl::code-component + (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info) + (sb-vm::%code-code-size debug-info) + :stream s)) + (sb-di::compiled-debug-fun + (let ((component (sb-di::compiled-debug-fun-component debug-info))) + (sb-disassem::disassemble-code-component component :stream s))) + (t `(:error "No disassembly available")))))) + +(defslimefun swank-sprof-source-location (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (or (when (typep debug-info 'sb-di::compiled-debug-fun) + (let* ((component (sb-di::compiled-debug-fun-component debug-info)) + (function (sb-kernel::%code-entry-points component))) + (when function + (find-source-location function)))) + `(:error "No source location available")))) + +(defslimefun swank-sprof-start (&key (mode :cpu)) + (sb-sprof:start-profiling :mode mode)) + +(defslimefun swank-sprof-stop () + (sb-sprof:stop-profiling)) + +) + +(provide :swank-sprof) diff --git a/elpa/slime-20200319.1939/contrib/swank-trace-dialog.lisp b/elpa/slime-20200319.1939/contrib/swank-trace-dialog.lisp new file mode 100644 index 00000000..5cf95fd1 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-trace-dialog.lisp @@ -0,0 +1,264 @@ +(defpackage :swank-trace-dialog + (:use :cl) + (:import-from :swank :defslimefun :from-string :to-string) + (:export #:clear-trace-tree + #:dialog-toggle-trace + #:dialog-trace + #:dialog-traced-p + #:dialog-untrace + #:dialog-untrace-all + #:inspect-trace-part + #:report-partial-tree + #:report-specs + #:report-total + #:report-trace-detail + #:report-specs + #:trace-format + #:still-inside + #:exited-non-locally + #:*record-backtrace* + #:*traces-per-report* + #:*dialog-trace-follows-trace* + #:find-trace-part + #:find-trace)) + +(in-package :swank-trace-dialog) + +(defparameter *record-backtrace* nil + "Record a backtrace of the last 20 calls for each trace. + +Beware that this may have a drastic performance impact on your +program.") + +(defparameter *traces-per-report* 150 + "Number of traces to report to emacs in each batch.") + + +;;;; `trace-entry' model +;;;; +(defvar *traces* (make-array 1000 :fill-pointer 0 + :adjustable t)) + +(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock")) + +(defvar *current-trace-by-thread* (make-hash-table)) + +(defclass trace-entry () + ((id :reader id-of) + (children :accessor children-of :initform nil) + (backtrace :accessor backtrace-of :initform (when *record-backtrace* + (useful-backtrace))) + + (spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (args :initarg :args :accessor args-of + :initform (error "must provide args")) + (parent :initarg :parent :reader parent-of + :initform (error "must provide a parent, even if nil")) + (retlist :initarg :retlist :accessor retlist-of + :initform 'still-inside))) + +(defmethod initialize-instance :after ((entry trace-entry) &rest initargs) + (declare (ignore initargs)) + (if (parent-of entry) + (nconc (children-of (parent-of entry)) (list entry))) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () + (setf (slot-value entry 'id) (fill-pointer *traces*)) + (vector-push-extend entry *traces*)))) + +(defmethod print-object ((entry trace-entry) stream) + (print-unreadable-object (entry stream) + (format stream "~a: ~a" (id-of entry) (spec-of entry)))) + +(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) + +(defun find-trace (id) + (when (<= 0 id (1- (length *traces*))) + (aref *traces* id))) + +(defun find-trace-part (id part-id type) + (let* ((trace (find-trace id)) + (l (and trace + (ecase type + (:arg (args-of trace)) + (:retval (swank::ensure-list (retlist-of trace))))))) + (values (nth part-id l) + (< part-id (length l))))) + +(defun useful-backtrace () + (swank/backend:call-with-debugging-environment + #'(lambda () + (loop for i from 0 + for frame in (swank/backend:compute-backtrace 0 20) + collect (list i (swank::frame-to-string frame)))))) + +(defun current-trace () + (gethash (swank/backend:current-thread) *current-trace-by-thread*)) + +(defun (setf current-trace) (trace) + (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*) + trace)) + + +;;;; Control of traced specs +;;; +(defvar *traced-specs* '()) + +(defslimefun dialog-trace (spec) + (flet ((before-hook (args) + (setf (current-trace) (make-instance 'trace-entry + :spec spec + :args args + :parent (current-trace)))) + (after-hook (retlist) + (let ((trace (current-trace))) + (when trace + ;; the current trace might have been wiped away if the + ;; user cleared the tree in the meantime. no biggie, + ;; don't do anything. + ;; + (setf (retlist-of trace) retlist + (current-trace) (parent-of trace)))))) + (when (dialog-traced-p spec) + (warn "~a is apparently already traced! Untracing and retracing." spec) + (dialog-untrace spec)) + (swank/backend:wrap spec 'trace-dialog + :before #'before-hook + :after #'after-hook) + (pushnew spec *traced-specs*) + (format nil "~a is now traced for trace dialog" spec))) + +(defslimefun dialog-untrace (spec) + (swank/backend:unwrap spec 'trace-dialog) + (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) + (format nil "~a is now untraced for trace dialog" spec)) + +(defslimefun dialog-toggle-trace (spec) + (if (dialog-traced-p spec) + (dialog-untrace spec) + (dialog-trace spec))) + +(defslimefun dialog-traced-p (spec) + (find spec *traced-specs* :test #'equal)) + +(defslimefun dialog-untrace-all () + (untrace) + (mapcar #'dialog-untrace *traced-specs*)) + +(defparameter *dialog-trace-follows-trace* nil) + +(setq swank:*after-toggle-trace-hook* + #'(lambda (spec traced-p) + (when *dialog-trace-follows-trace* + (cond (traced-p + (dialog-trace spec) + "traced for trace dialog as well") + (t + (dialog-untrace spec) + "untraced for the trace dialog as well"))))) + + +;;;; A special kind of trace call +;;; +(defun trace-format (format-spec &rest format-args) + "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." + (let* ((line (apply #'format nil format-spec format-args))) + (make-instance 'trace-entry :spec line + :args format-args + :parent (current-trace) + :retlist nil))) + + +;;;; Reporting to emacs +;;; +(defparameter *visitor-idx* 0) + +(defparameter *visitor-key* nil) + +(defvar *unfinished-traces* '()) + +(defun describe-trace-for-emacs (trace) + `(,(id-of trace) + ,(and (parent-of trace) (id-of (parent-of trace))) + ,(spec-of trace) + ,(loop for arg in (args-of trace) + for i from 0 + collect (list i (swank::to-line arg))) + ,(loop for retval in (swank::ensure-list (retlist-of trace)) + for i from 0 + collect (list i (swank::to-line retval))))) + +(defslimefun report-partial-tree (key) + (unless (equal key *visitor-key*) + (setq *visitor-idx* 0 + *visitor-key* key)) + (let* ((recently-finished + (loop with i = 0 + for trace in *unfinished-traces* + while (< i *traces-per-report*) + when (completed-p trace) + collect trace + and do + (incf i) + (setq *unfinished-traces* + (remove trace *unfinished-traces*)))) + (new (loop for i + from (length recently-finished) + below *traces-per-report* + while (< *visitor-idx* (length *traces*)) + for trace = (aref *traces* *visitor-idx*) + collect trace + unless (completed-p trace) + do (push trace *unfinished-traces*) + do (incf *visitor-idx*)))) + (list + (mapcar #'describe-trace-for-emacs + (append recently-finished new)) + (- (length *traces*) *visitor-idx*) + key))) + +(defslimefun report-trace-detail (trace-id) + (swank::call-with-bindings + swank::*inspector-printer-bindings* + #'(lambda () + (let ((trace (find-trace trace-id))) + (when trace + (append + (describe-trace-for-emacs trace) + (list (backtrace-of trace) + (swank::to-line trace)))))))) + +(defslimefun report-specs () + (sort (copy-list *traced-specs*) + #'string< + :key #'princ-to-string)) + +(defslimefun report-total () + (length *traces*)) + +(defslimefun clear-trace-tree () + (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) + *visitor-key* nil + *unfinished-traces* nil) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () (setf (fill-pointer *traces*) 0))) + nil) + +;; HACK: `swank::*inspector-history*' is unbound by default and needs +;; a reset in that case so that it won't error `swank::inspect-object' +;; before any other object is inspected in the slime session. +;; +(unless (boundp 'swank::*inspector-history*) + (swank::reset-inspector)) + +(defslimefun inspect-trace-part (trace-id part-id type) + (multiple-value-bind (obj found) + (find-trace-part trace-id part-id type) + (if found + (swank::inspect-object obj) + (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) + +(provide :swank-trace-dialog) diff --git a/elpa/slime-20200319.1939/contrib/swank-util.lisp b/elpa/slime-20200319.1939/contrib/swank-util.lisp new file mode 100644 index 00000000..72743ba1 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank-util.lisp @@ -0,0 +1,63 @@ +;;; swank-util.lisp --- stuff of questionable utility +;; +;; License: public domain + +(in-package :swank) + +(defmacro do-symbols* ((var &optional (package '*package*) result-form) + &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + (tagbody ,@body)))))) + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according to its +underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special +variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, +:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (flet ((type-specifier-p (s) + (or (documentation s 'type) + (not (eq (type-specifier-arglist s) :not-available))))) + (let (result) + (when (boundp symbol) (push (if (constantp symbol) + :constant :boundp) result)) + (when (fboundp symbol) (push :fboundp result)) + (when (type-specifier-p symbol) (push :typespec result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (and (fboundp symbol) + (typep (ignore-errors (fdefinition symbol)) + 'generic-function)) + (push :generic-function result)) + result))) + +(defun symbol-classification-string (symbol) + "Return a string in the form -f-c---- where each letter stands for +boundp fboundp generic-function class macro special-operator package" + (let ((letters "bfgctmsp") + (result (copy-seq "--------"))) + (flet ((flip (letter) + (setf (char result (position letter letters)) + letter))) + (when (boundp symbol) (flip #\b)) + (when (fboundp symbol) + (flip #\f) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (flip #\g))) + (when (type-specifier-p symbol) (flip #\t)) + (when (find-class symbol nil) (flip #\c) ) + (when (macro-function symbol) (flip #\m)) + (when (special-operator-p symbol) (flip #\s)) + (when (find-package symbol) (flip #\p)) + result))) + +(provide :swank-util) diff --git a/elpa/slime-20200319.1939/contrib/swank.rb b/elpa/slime-20200319.1939/contrib/swank.rb new file mode 100644 index 00000000..69936495 --- /dev/null +++ b/elpa/slime-20200319.1939/contrib/swank.rb @@ -0,0 +1,385 @@ +# swank.rb --- swank server for Ruby. +# +# This is my first Ruby program and looks probably rather strange. Some +# people write Scheme interpreters when learning new languages, I +# write swank backends. +# +# Only a few things work. +# 1. Start the server with something like: ruby -r swank -e swank +# 2. Use M-x slime-connect to establish a connection + +require "socket" + +def swank(port=4005) + accept_connections port, false +end + +def start_swank(port_file) + accept_connections false, port_file +end + +def accept_connections(port, port_file) + server = TCPServer.new("localhost", port || 0) + puts "Listening on #{server.addr.inspect}\n" + if port_file + write_port_file server.addr[1], port_file + end + socket = begin server.accept ensure server.close end + begin + serve socket.to_io + ensure + socket.close + end +end + +def write_port_file(port, filename) + File.open(filename, File::CREAT|File::EXCL|File::WRONLY) do |f| + f.puts port + end +end + +def serve(io) + main_loop(io) +end + +def main_loop(io) + c = Connection.new(io) + while true + catch :swank_top_level do + c.dispatch(read_packet(io)) + end + end +end + +class Connection + + def initialize(io) + @io = io + end + + def dispatch(event) + puts "dispatch: %s\n" % event.inspect + case event[0] + when :":emacs-rex" + emacs_rex *event[1..4] + else raise "Unhandled event: #{event.inspect}" + end + end + + def send_to_emacs(obj) + payload = write_sexp_to_string(obj) + @io.write("%06x" % payload.length) + @io.write payload + @io.flush + end + + def emacs_rex(form, pkg, thread, id) + proc = $rpc_entries[form[0]] + args = form[1..-1]; + begin + raise "Undefined function: #{form[0]}" unless proc + value = proc[*args] + rescue Exception => exc + begin + pseudo_debug exc + ensure + send_to_emacs [:":return", [:":abort"], id] + end + else + send_to_emacs [:":return", [:":ok", value], id] + end + end + + def pseudo_debug(exc) + level = 1 + send_to_emacs [:":debug", 0, level] + sldb_info(exc, 0, 20) + begin + sldb_loop exc + ensure + send_to_emacs [:":debug-return", 0, level, :nil] + end + end + + def sldb_loop(exc) + $sldb_context = [self,exc] + while true + dispatch(read_packet(@io)) + end + end + + def sldb_info(exc, start, _end) + [[exc.to_s, + " [%s]" % exc.class.name, + :nil], + sldb_restarts(exc), + sldb_backtrace(exc, start, _end), + []] + end + + def sldb_restarts(exc) + [["Quit", "SLIME top-level."]] + end + + def sldb_backtrace(exc, start, _end) + bt = [] + exc.backtrace[start.._end].each_with_index do |frame, i| + bt << [i, frame] + end + bt + end + + def frame_src_loc(exc, frame) + string = exc.backtrace[frame] + match = /([^:]+):([0-9]+)/.match(string) + if match + file,line = match[1..2] + [:":location", [:":file", file], [:":line", line.to_i], :nil] + else + [:":error", "no src-loc for frame: #{string}"] + end + end + +end + +$rpc_entries = Hash.new + +$rpc_entries[:"swank:connection-info"] = lambda do || + [:":pid", $$, + :":package", [:":name", "ruby", :":prompt", "ruby> "], + :":lisp-implementation", [:":type", "Ruby", + :":name", "ruby", + :":version", RUBY_VERSION]] +end + +def swank_interactive_eval(string) + eval(string,TOPLEVEL_BINDING).inspect +end + +$rpc_entries[:"swank:interactive-eval"] = \ +$rpc_entries[:"swank:interactive-eval-region"] = \ +$rpc_entries[:"swank:pprint-eval"] = lambda { |string| + swank_interactive_eval string +} + +$rpc_entries[:"swank:throw-to-toplevel"] = lambda { + throw :swank_top_level +} + +$rpc_entries[:"swank:backtrace"] = lambda do |from, to| + conn, exc = $sldb_context + conn.sldb_backtrace(exc, from, to) +end + +$rpc_entries[:"swank:frame-source-location"] = lambda do |frame| + conn, exc = $sldb_context + conn.frame_src_loc(exc, frame) +end + +#ignored +$rpc_entries[:"swank:buffer-first-change"] = \ +$rpc_entries[:"swank:operator-arglist"] = lambda do + :nil +end + +$rpc_entries[:"swank:simple-completions"] = lambda do |prefix, pkg| + swank_simple_completions prefix, pkg +end + +# def swank_simple_completions(prefix, pkg) + +def read_packet(io) + header = read_chunk(io, 6) + len = header.hex + payload = read_chunk(io, len) + #$deferr.puts payload.inspect + read_sexp_from_string(payload) +end + +def read_chunk(io, len) + buffer = io.read(len) + raise "short read" if buffer.length != len + buffer +end + +def write_sexp_to_string(obj) + string = "" + write_sexp_to_string_loop obj, string + string +end + +def write_sexp_to_string_loop(obj, string) + if obj.is_a? String + string << "\"" + string << obj.gsub(/(["\\])/,'\\\\\1') + string << "\"" + elsif obj.is_a? Array + string << "(" + max = obj.length-1 + obj.each_with_index do |e,i| + write_sexp_to_string_loop e, string + string << " " unless i == max + end + string << ")" + elsif obj.is_a? Symbol or obj.is_a? Numeric + string << obj.to_s + elsif obj == false + string << "nil" + elsif obj == true + string << "t" + else raise "Can't write: #{obj.inspect}" + end +end + +def read_sexp_from_string(string) + stream = StringInputStream.new(string) + reader = LispReader.new(stream) + reader.read +end + +class LispReader + def initialize(io) + @io = io + end + + def read(allow_consing_dot=false) + skip_whitespace + c = @io.getc + case c + when ?( then read_list(true) + when ?" then read_string + when ?' then read_quote + when nil then raise EOFError.new("EOF during read") + else + @io.ungetc(c) + obj = read_number_or_symbol + if obj == :"." and not allow_consing_dot + raise "Consing-dot in invalid context" + end + obj + end + end + + def read_list(head) + list = [] + loop do + skip_whitespace + c = @io.readchar + if c == ?) + break + else + @io.ungetc(c) + obj = read(!head) + if obj == :"." + error "Consing-dot not implemented" # would need real conses + end + head = false + list << obj + end + end + list + end + + def read_string + string = "" + loop do + c = @io.getc + case c + when ?" + break + when ?\\ + c = @io.getc + case c + when ?\\, ?" then string << c + else raise "Invalid escape char: \\%c" % c + end + else + string << c + end + end + string + end + + def read_quote + [:quote, read] + end + + def read_number_or_symbol + token = read_token + if token.empty? + raise EOFError.new + elsif /^[0-9]+$/.match(token) + token.to_i + elsif /^[0-9]+\.[0-9]+$/.match(token) + token.to_f + else + token.intern + end + end + + def read_token + token = "" + loop do + c = @io.getc + if c.nil? + break + elsif terminating?(c) + @io.ungetc(c) + break + else + token << c + end + end + token + end + + def skip_whitespace + loop do + c = @io.getc + case c + when ?\s, ?\n, ?\t then next + when nil then break + else @io.ungetc(c); break + end + end + end + + def terminating?(char) + " \n\t()\"'".include?(char) + end + +end + + +class StringInputStream + def initialize(string) + @string = string + @pos = 0 + @max = string.length + end + + def pos() @pos end + + def getc + if @pos == @max + nil + else + c = @string[@pos] + @pos += 1 + c + end + end + + def readchar + getc or raise EOFError.new + end + + def ungetc(c) + if @pos > 0 && @string[@pos-1] == c + @pos -= 1 + else + raise "Invalid argument: %c [at %d]" % [c, @pos] + end + end + +end + diff --git a/elpa/slime-20200319.1939/dir b/elpa/slime-20200319.1939/dir new file mode 100644 index 00000000..2b9c3d62 --- /dev/null +++ b/elpa/slime-20200319.1939/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* SLIME: (slime). Superior Lisp Interaction Mode for Emacs. diff --git a/elpa/slime-20200319.1939/lib/hyperspec.el b/elpa/slime-20200319.1939/lib/hyperspec.el new file mode 100644 index 00000000..45c33281 --- /dev/null +++ b/elpa/slime-20200319.1939/lib/hyperspec.el @@ -0,0 +1,2511 @@ +;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec + +;; Copyright 1997 Naggum Software + +;; Author: Erik Naggum +;; Keywords: lisp + +;; This file is not part of GNU Emacs, but distributed under the same +;; conditions as GNU Emacs, and is useless without 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 2, 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; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Kent Pitman and Xanalys Inc. have made the text of American National +;; Standard for Information Technology -- Programming Language -- Common +;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common +;; Lisp HyperSpec. This package makes it convenient to peruse this +;; documentation from within Emacs. + +;;; Code: + +(require 'cl-lib nil t) +(require 'cl-lib "lib/cl-lib") +(require 'browse-url) ;you need the Emacs 20 version +(require 'thingatpt) + +(defvar common-lisp-hyperspec-root + "http://www.lispworks.com/reference/HyperSpec/" + "The root of the Common Lisp HyperSpec URL. +If you copy the HyperSpec to your local system, set this variable to +something like \"file://usr/local/doc/HyperSpec/\".") + +;;; Added variable for CLHS symbol table. See details below. +;;; +;;; 20011201 Edi Weitz + +(defvar common-lisp-hyperspec-symbol-table nil + "The HyperSpec symbol table file. +If you copy the HyperSpec to your local system, set this variable to +the location of the symbol table which is usually \"Map_Sym.txt\" +or \"Symbol-Table.text\".") + +(defvar common-lisp-hyperspec-history nil + "History of symbols looked up in the Common Lisp HyperSpec.") + +(defvar common-lisp-hyperspec--symbols (make-hash-table :test 'equal) + "Map a symbol name to its list of relative URLs.") + +;; Lookup NAME in 'common-lisp-hyperspec--symbols´ +(defun common-lisp-hyperspec--find (name) + "Get the relative url of a Common Lisp symbol NAME." + (gethash name common-lisp-hyperspec--symbols)) + +(defun common-lisp-hyperspec--insert (name relative-url) + "Insert CL symbol NAME and RELATIVE-URL into master table." + (cl-pushnew relative-url + (gethash name common-lisp-hyperspec--symbols) + :test #'equal)) + +(defun common-lisp-hyperspec--strip-cl-package (name) + (if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name) + (let ((package-name (match-string 1 name)) + (symbol-name (match-string 2 name))) + (if (member (downcase package-name) + '("cl" "common-lisp")) + symbol-name + name)) + name)) + +;; Choose the symbol at point or read symbol-name from the minibuffer. +(defun common-lisp-hyperspec-read-symbol-name (&optional symbol-at-point) + (let* ((symbol-at-point (or symbol-at-point (thing-at-point 'symbol))) + (stripped-symbol (and symbol-at-point + (common-lisp-hyperspec--strip-cl-package + (downcase symbol-at-point))))) + (cond ((and stripped-symbol + (common-lisp-hyperspec--find stripped-symbol)) + stripped-symbol) + (t + (completing-read "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec--symbols nil t + stripped-symbol + 'common-lisp-hyperspec-history))))) + +;; FIXME: is the (sleep-for 1.5) a actually needed? +(defun common-lisp-hyperspec (symbol-name) + "View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec. +If SYMBOL-NAME has more than one definition, all of them are displayed with +your favorite browser in sequence. The browser should have a \"back\" +function to view the separate definitions. + +The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided +by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is +visited to retrieve the information. Xanalys Inc. allows you to transfer +the entire Common Lisp HyperSpec to your own site under certain conditions. +Visit http://www.lispworks.com/reference/HyperSpec/ for more information. +If you copy the HyperSpec to another location, customize the variable +`common-lisp-hyperspec-root' to point to that location." + (interactive (list (common-lisp-hyperspec-read-symbol-name))) + (let ((name (common-lisp-hyperspec--strip-cl-package + (downcase symbol-name)))) + (cl-maplist (lambda (entry) + (browse-url (concat common-lisp-hyperspec-root "Body/" + (car entry))) + (when (cdr entry) + (sleep-for 1.5))) + (or (common-lisp-hyperspec--find name) + (error "The symbol `%s' is not defined in Common Lisp" + symbol-name))))) + +;;; Added dynamic lookup of symbol in CLHS symbol table +;;; +;;; 20011202 Edi Weitz + +;;; Replaced symbol table for v 4.0 with the one for v 6.0 +;;; (which is now online at Xanalys' site) +;;; +;;; 20020213 Edi Weitz + +(defun common-lisp-hyperspec--get-one-line () + (prog1 + (cl-delete ?\n (thing-at-point 'line)) + (forward-line))) + +(defun common-lisp-hyperspec--parse-map-file (file) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (let ((result '())) + (while (< (point) (point-max)) + (let* ((symbol-name (downcase (common-lisp-hyperspec--get-one-line))) + (relative-url (common-lisp-hyperspec--get-one-line)) + (file (file-name-nondirectory relative-url))) + (push (list symbol-name file) + result))) + (reverse result)))) + +(mapc (lambda (entry) + (common-lisp-hyperspec--insert (car entry) (cadr entry))) + (if common-lisp-hyperspec-symbol-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-symbol-table) + '(("&allow-other-keys" "03_da.htm") + ("&aux" "03_da.htm") + ("&body" "03_dd.htm") + ("&environment" "03_dd.htm") + ("&key" "03_da.htm") + ("&optional" "03_da.htm") + ("&rest" "03_da.htm") + ("&whole" "03_dd.htm") + ("*" "a_st.htm") + ("**" "v__stst_.htm") + ("***" "v__stst_.htm") + ("*break-on-signals*" "v_break_.htm") + ("*compile-file-pathname*" "v_cmp_fi.htm") + ("*compile-file-truename*" "v_cmp_fi.htm") + ("*compile-print*" "v_cmp_pr.htm") + ("*compile-verbose*" "v_cmp_pr.htm") + ("*debug-io*" "v_debug_.htm") + ("*debugger-hook*" "v_debugg.htm") + ("*default-pathname-defaults*" "v_defaul.htm") + ("*error-output*" "v_debug_.htm") + ("*features*" "v_featur.htm") + ("*gensym-counter*" "v_gensym.htm") + ("*load-pathname*" "v_ld_pns.htm") + ("*load-print*" "v_ld_prs.htm") + ("*load-truename*" "v_ld_pns.htm") + ("*load-verbose*" "v_ld_prs.htm") + ("*macroexpand-hook*" "v_mexp_h.htm") + ("*modules*" "v_module.htm") + ("*package*" "v_pkg.htm") + ("*print-array*" "v_pr_ar.htm") + ("*print-base*" "v_pr_bas.htm") + ("*print-case*" "v_pr_cas.htm") + ("*print-circle*" "v_pr_cir.htm") + ("*print-escape*" "v_pr_esc.htm") + ("*print-gensym*" "v_pr_gen.htm") + ("*print-length*" "v_pr_lev.htm") + ("*print-level*" "v_pr_lev.htm") + ("*print-lines*" "v_pr_lin.htm") + ("*print-miser-width*" "v_pr_mis.htm") + ("*print-pprint-dispatch*" "v_pr_ppr.htm") + ("*print-pretty*" "v_pr_pre.htm") + ("*print-radix*" "v_pr_bas.htm") + ("*print-readably*" "v_pr_rda.htm") + ("*print-right-margin*" "v_pr_rig.htm") + ("*query-io*" "v_debug_.htm") + ("*random-state*" "v_rnd_st.htm") + ("*read-base*" "v_rd_bas.htm") + ("*read-default-float-format*" "v_rd_def.htm") + ("*read-eval*" "v_rd_eva.htm") + ("*read-suppress*" "v_rd_sup.htm") + ("*readtable*" "v_rdtabl.htm") + ("*standard-input*" "v_debug_.htm") + ("*standard-output*" "v_debug_.htm") + ("*terminal-io*" "v_termin.htm") + ("*trace-output*" "v_debug_.htm") + ("+" "a_pl.htm") + ("++" "v_pl_plp.htm") + ("+++" "v_pl_plp.htm") + ("-" "a__.htm") + ("/" "a_sl.htm") + ("//" "v_sl_sls.htm") + ("///" "v_sl_sls.htm") + ("/=" "f_eq_sle.htm") + ("1+" "f_1pl_1_.htm") + ("1-" "f_1pl_1_.htm") + ("<" "f_eq_sle.htm") + ("<=" "f_eq_sle.htm") + ("=" "f_eq_sle.htm") + (">" "f_eq_sle.htm") + (">=" "f_eq_sle.htm") + ("abort" "a_abort.htm") + ("abs" "f_abs.htm") + ("acons" "f_acons.htm") + ("acos" "f_asin_.htm") + ("acosh" "f_sinh_.htm") + ("add-method" "f_add_me.htm") + ("adjoin" "f_adjoin.htm") + ("adjust-array" "f_adjust.htm") + ("adjustable-array-p" "f_adju_1.htm") + ("allocate-instance" "f_alloca.htm") + ("alpha-char-p" "f_alpha_.htm") + ("alphanumericp" "f_alphan.htm") + ("and" "a_and.htm") + ("append" "f_append.htm") + ("apply" "f_apply.htm") + ("apropos" "f_apropo.htm") + ("apropos-list" "f_apropo.htm") + ("aref" "f_aref.htm") + ("arithmetic-error" "e_arithm.htm") + ("arithmetic-error-operands" "f_arithm.htm") + ("arithmetic-error-operation" "f_arithm.htm") + ("array" "t_array.htm") + ("array-dimension" "f_ar_dim.htm") + ("array-dimension-limit" "v_ar_dim.htm") + ("array-dimensions" "f_ar_d_1.htm") + ("array-displacement" "f_ar_dis.htm") + ("array-element-type" "f_ar_ele.htm") + ("array-has-fill-pointer-p" "f_ar_has.htm") + ("array-in-bounds-p" "f_ar_in_.htm") + ("array-rank" "f_ar_ran.htm") + ("array-rank-limit" "v_ar_ran.htm") + ("array-row-major-index" "f_ar_row.htm") + ("array-total-size" "f_ar_tot.htm") + ("array-total-size-limit" "v_ar_tot.htm") + ("arrayp" "f_arrayp.htm") + ("ash" "f_ash.htm") + ("asin" "f_asin_.htm") + ("asinh" "f_sinh_.htm") + ("assert" "m_assert.htm") + ("assoc" "f_assocc.htm") + ("assoc-if" "f_assocc.htm") + ("assoc-if-not" "f_assocc.htm") + ("atan" "f_asin_.htm") + ("atanh" "f_sinh_.htm") + ("atom" "a_atom.htm") + ("base-char" "t_base_c.htm") + ("base-string" "t_base_s.htm") + ("bignum" "t_bignum.htm") + ("bit" "a_bit.htm") + ("bit-and" "f_bt_and.htm") + ("bit-andc1" "f_bt_and.htm") + ("bit-andc2" "f_bt_and.htm") + ("bit-eqv" "f_bt_and.htm") + ("bit-ior" "f_bt_and.htm") + ("bit-nand" "f_bt_and.htm") + ("bit-nor" "f_bt_and.htm") + ("bit-not" "f_bt_and.htm") + ("bit-orc1" "f_bt_and.htm") + ("bit-orc2" "f_bt_and.htm") + ("bit-vector" "t_bt_vec.htm") + ("bit-vector-p" "f_bt_vec.htm") + ("bit-xor" "f_bt_and.htm") + ("block" "s_block.htm") + ("boole" "f_boole.htm") + ("boole-1" "v_b_1_b.htm") + ("boole-2" "v_b_1_b.htm") + ("boole-and" "v_b_1_b.htm") + ("boole-andc1" "v_b_1_b.htm") + ("boole-andc2" "v_b_1_b.htm") + ("boole-c1" "v_b_1_b.htm") + ("boole-c2" "v_b_1_b.htm") + ("boole-clr" "v_b_1_b.htm") + ("boole-eqv" "v_b_1_b.htm") + ("boole-ior" "v_b_1_b.htm") + ("boole-nand" "v_b_1_b.htm") + ("boole-nor" "v_b_1_b.htm") + ("boole-orc1" "v_b_1_b.htm") + ("boole-orc2" "v_b_1_b.htm") + ("boole-set" "v_b_1_b.htm") + ("boole-xor" "v_b_1_b.htm") + ("boolean" "t_ban.htm") + ("both-case-p" "f_upper_.htm") + ("boundp" "f_boundp.htm") + ("break" "f_break.htm") + ("broadcast-stream" "t_broadc.htm") + ("broadcast-stream-streams" "f_broadc.htm") + ("built-in-class" "t_built_.htm") + ("butlast" "f_butlas.htm") + ("byte" "f_by_by.htm") + ("byte-position" "f_by_by.htm") + ("byte-size" "f_by_by.htm") + ("caaaar" "f_car_c.htm") + ("caaadr" "f_car_c.htm") + ("caaar" "f_car_c.htm") + ("caadar" "f_car_c.htm") + ("caaddr" "f_car_c.htm") + ("caadr" "f_car_c.htm") + ("caar" "f_car_c.htm") + ("cadaar" "f_car_c.htm") + ("cadadr" "f_car_c.htm") + ("cadar" "f_car_c.htm") + ("caddar" "f_car_c.htm") + ("cadddr" "f_car_c.htm") + ("caddr" "f_car_c.htm") + ("cadr" "f_car_c.htm") + ("call-arguments-limit" "v_call_a.htm") + ("call-method" "m_call_m.htm") + ("call-next-method" "f_call_n.htm") + ("car" "f_car_c.htm") + ("case" "m_case_.htm") + ("catch" "s_catch.htm") + ("ccase" "m_case_.htm") + ("cdaaar" "f_car_c.htm") + ("cdaadr" "f_car_c.htm") + ("cdaar" "f_car_c.htm") + ("cdadar" "f_car_c.htm") + ("cdaddr" "f_car_c.htm") + ("cdadr" "f_car_c.htm") + ("cdar" "f_car_c.htm") + ("cddaar" "f_car_c.htm") + ("cddadr" "f_car_c.htm") + ("cddar" "f_car_c.htm") + ("cdddar" "f_car_c.htm") + ("cddddr" "f_car_c.htm") + ("cdddr" "f_car_c.htm") + ("cddr" "f_car_c.htm") + ("cdr" "f_car_c.htm") + ("ceiling" "f_floorc.htm") + ("cell-error" "e_cell_e.htm") + ("cell-error-name" "f_cell_e.htm") + ("cerror" "f_cerror.htm") + ("change-class" "f_chg_cl.htm") + ("char" "f_char_.htm") + ("char-code" "f_char_c.htm") + ("char-code-limit" "v_char_c.htm") + ("char-downcase" "f_char_u.htm") + ("char-equal" "f_chareq.htm") + ("char-greaterp" "f_chareq.htm") + ("char-int" "f_char_i.htm") + ("char-lessp" "f_chareq.htm") + ("char-name" "f_char_n.htm") + ("char-not-equal" "f_chareq.htm") + ("char-not-greaterp" "f_chareq.htm") + ("char-not-lessp" "f_chareq.htm") + ("char-upcase" "f_char_u.htm") + ("char/=" "f_chareq.htm") + ("char<" "f_chareq.htm") + ("char<=" "f_chareq.htm") + ("char=" "f_chareq.htm") + ("char>" "f_chareq.htm") + ("char>=" "f_chareq.htm") + ("character" "a_ch.htm") + ("characterp" "f_chp.htm") + ("check-type" "m_check_.htm") + ("cis" "f_cis.htm") + ("class" "t_class.htm") + ("class-name" "f_class_.htm") + ("class-of" "f_clas_1.htm") + ("clear-input" "f_clear_.htm") + ("clear-output" "f_finish.htm") + ("close" "f_close.htm") + ("clrhash" "f_clrhas.htm") + ("code-char" "f_code_c.htm") + ("coerce" "f_coerce.htm") + ("compilation-speed" "d_optimi.htm") + ("compile" "f_cmp.htm") + ("compile-file" "f_cmp_fi.htm") + ("compile-file-pathname" "f_cmp__1.htm") + ("compiled-function" "t_cmpd_f.htm") + ("compiled-function-p" "f_cmpd_f.htm") + ("compiler-macro" "f_docume.htm") + ("compiler-macro-function" "f_cmp_ma.htm") + ("complement" "f_comple.htm") + ("complex" "a_comple.htm") + ("complexp" "f_comp_3.htm") + ("compute-applicable-methods" "f_comput.htm") + ("compute-restarts" "f_comp_1.htm") + ("concatenate" "f_concat.htm") + ("concatenated-stream" "t_concat.htm") + ("concatenated-stream-streams" "f_conc_1.htm") + ("cond" "m_cond.htm") + ("condition" "e_cnd.htm") + ("conjugate" "f_conjug.htm") + ("cons" "a_cons.htm") + ("consp" "f_consp.htm") + ("constantly" "f_cons_1.htm") + ("constantp" "f_consta.htm") + ("continue" "a_contin.htm") + ("control-error" "e_contro.htm") + ("copy-alist" "f_cp_ali.htm") + ("copy-list" "f_cp_lis.htm") + ("copy-pprint-dispatch" "f_cp_ppr.htm") + ("copy-readtable" "f_cp_rdt.htm") + ("copy-seq" "f_cp_seq.htm") + ("copy-structure" "f_cp_stu.htm") + ("copy-symbol" "f_cp_sym.htm") + ("copy-tree" "f_cp_tre.htm") + ("cos" "f_sin_c.htm") + ("cosh" "f_sinh_.htm") + ("count" "f_countc.htm") + ("count-if" "f_countc.htm") + ("count-if-not" "f_countc.htm") + ("ctypecase" "m_tpcase.htm") + ("debug" "d_optimi.htm") + ("decf" "m_incf_.htm") + ("declaim" "m_declai.htm") + ("declaration" "d_declar.htm") + ("declare" "s_declar.htm") + ("decode-float" "f_dec_fl.htm") + ("decode-universal-time" "f_dec_un.htm") + ("defclass" "m_defcla.htm") + ("defconstant" "m_defcon.htm") + ("defgeneric" "m_defgen.htm") + ("define-compiler-macro" "m_define.htm") + ("define-condition" "m_defi_5.htm") + ("define-method-combination" "m_defi_4.htm") + ("define-modify-macro" "m_defi_2.htm") + ("define-setf-expander" "m_defi_3.htm") + ("define-symbol-macro" "m_defi_1.htm") + ("defmacro" "m_defmac.htm") + ("defmethod" "m_defmet.htm") + ("defpackage" "m_defpkg.htm") + ("defparameter" "m_defpar.htm") + ("defsetf" "m_defset.htm") + ("defstruct" "m_defstr.htm") + ("deftype" "m_deftp.htm") + ("defun" "m_defun.htm") + ("defvar" "m_defpar.htm") + ("delete" "f_rm_rm.htm") + ("delete-duplicates" "f_rm_dup.htm") + ("delete-file" "f_del_fi.htm") + ("delete-if" "f_rm_rm.htm") + ("delete-if-not" "f_rm_rm.htm") + ("delete-package" "f_del_pk.htm") + ("denominator" "f_numera.htm") + ("deposit-field" "f_deposi.htm") + ("describe" "f_descri.htm") + ("describe-object" "f_desc_1.htm") + ("destructuring-bind" "m_destru.htm") + ("digit-char" "f_digit_.htm") + ("digit-char-p" "f_digi_1.htm") + ("directory" "f_dir.htm") + ("directory-namestring" "f_namest.htm") + ("disassemble" "f_disass.htm") + ("division-by-zero" "e_divisi.htm") + ("do" "m_do_do.htm") + ("do*" "m_do_do.htm") + ("do-all-symbols" "m_do_sym.htm") + ("do-external-symbols" "m_do_sym.htm") + ("do-symbols" "m_do_sym.htm") + ("documentation" "f_docume.htm") + ("dolist" "m_dolist.htm") + ("dotimes" "m_dotime.htm") + ("double-float" "t_short_.htm") + ("double-float-epsilon" "v_short_.htm") + ("double-float-negative-epsilon" "v_short_.htm") + ("dpb" "f_dpb.htm") + ("dribble" "f_dribbl.htm") + ("dynamic-extent" "d_dynami.htm") + ("ecase" "m_case_.htm") + ("echo-stream" "t_echo_s.htm") + ("echo-stream-input-stream" "f_echo_s.htm") + ("echo-stream-output-stream" "f_echo_s.htm") + ("ed" "f_ed.htm") + ("eighth" "f_firstc.htm") + ("elt" "f_elt.htm") + ("encode-universal-time" "f_encode.htm") + ("end-of-file" "e_end_of.htm") + ("endp" "f_endp.htm") + ("enough-namestring" "f_namest.htm") + ("ensure-directories-exist" "f_ensu_1.htm") + ("ensure-generic-function" "f_ensure.htm") + ("eq" "f_eq.htm") + ("eql" "a_eql.htm") + ("equal" "f_equal.htm") + ("equalp" "f_equalp.htm") + ("error" "a_error.htm") + ("etypecase" "m_tpcase.htm") + ("eval" "f_eval.htm") + ("eval-when" "s_eval_w.htm") + ("evenp" "f_evenpc.htm") + ("every" "f_everyc.htm") + ("exp" "f_exp_e.htm") + ("export" "f_export.htm") + ("expt" "f_exp_e.htm") + ("extended-char" "t_extend.htm") + ("fboundp" "f_fbound.htm") + ("fceiling" "f_floorc.htm") + ("fdefinition" "f_fdefin.htm") + ("ffloor" "f_floorc.htm") + ("fifth" "f_firstc.htm") + ("file-author" "f_file_a.htm") + ("file-error" "e_file_e.htm") + ("file-error-pathname" "f_file_e.htm") + ("file-length" "f_file_l.htm") + ("file-namestring" "f_namest.htm") + ("file-position" "f_file_p.htm") + ("file-stream" "t_file_s.htm") + ("file-string-length" "f_file_s.htm") + ("file-write-date" "f_file_w.htm") + ("fill" "f_fill.htm") + ("fill-pointer" "f_fill_p.htm") + ("find" "f_find_.htm") + ("find-all-symbols" "f_find_a.htm") + ("find-class" "f_find_c.htm") + ("find-if" "f_find_.htm") + ("find-if-not" "f_find_.htm") + ("find-method" "f_find_m.htm") + ("find-package" "f_find_p.htm") + ("find-restart" "f_find_r.htm") + ("find-symbol" "f_find_s.htm") + ("finish-output" "f_finish.htm") + ("first" "f_firstc.htm") + ("fixnum" "t_fixnum.htm") + ("flet" "s_flet_.htm") + ("float" "a_float.htm") + ("float-digits" "f_dec_fl.htm") + ("float-precision" "f_dec_fl.htm") + ("float-radix" "f_dec_fl.htm") + ("float-sign" "f_dec_fl.htm") + ("floating-point-inexact" "e_floa_1.htm") + ("floating-point-invalid-operation" "e_floati.htm") + ("floating-point-overflow" "e_floa_2.htm") + ("floating-point-underflow" "e_floa_3.htm") + ("floatp" "f_floatp.htm") + ("floor" "f_floorc.htm") + ("fmakunbound" "f_fmakun.htm") + ("force-output" "f_finish.htm") + ("format" "f_format.htm") + ("formatter" "m_format.htm") + ("fourth" "f_firstc.htm") + ("fresh-line" "f_terpri.htm") + ("fround" "f_floorc.htm") + ("ftruncate" "f_floorc.htm") + ("ftype" "d_ftype.htm") + ("funcall" "f_funcal.htm") + ("function" "a_fn.htm") + ("function-keywords" "f_fn_kwd.htm") + ("function-lambda-expression" "f_fn_lam.htm") + ("functionp" "f_fnp.htm") + ("gcd" "f_gcd.htm") + ("generic-function" "t_generi.htm") + ("gensym" "f_gensym.htm") + ("gentemp" "f_gentem.htm") + ("get" "f_get.htm") + ("get-decoded-time" "f_get_un.htm") + ("get-dispatch-macro-character" "f_set__1.htm") + ("get-internal-real-time" "f_get_in.htm") + ("get-internal-run-time" "f_get__1.htm") + ("get-macro-character" "f_set_ma.htm") + ("get-output-stream-string" "f_get_ou.htm") + ("get-properties" "f_get_pr.htm") + ("get-setf-expansion" "f_get_se.htm") + ("get-universal-time" "f_get_un.htm") + ("getf" "f_getf.htm") + ("gethash" "f_gethas.htm") + ("go" "s_go.htm") + ("graphic-char-p" "f_graphi.htm") + ("handler-bind" "m_handle.htm") + ("handler-case" "m_hand_1.htm") + ("hash-table" "t_hash_t.htm") + ("hash-table-count" "f_hash_1.htm") + ("hash-table-p" "f_hash_t.htm") + ("hash-table-rehash-size" "f_hash_2.htm") + ("hash-table-rehash-threshold" "f_hash_3.htm") + ("hash-table-size" "f_hash_4.htm") + ("hash-table-test" "f_hash_5.htm") + ("host-namestring" "f_namest.htm") + ("identity" "f_identi.htm") + ("if" "s_if.htm") + ("ignorable" "d_ignore.htm") + ("ignore" "d_ignore.htm") + ("ignore-errors" "m_ignore.htm") + ("imagpart" "f_realpa.htm") + ("import" "f_import.htm") + ("in-package" "m_in_pkg.htm") + ("incf" "m_incf_.htm") + ("initialize-instance" "f_init_i.htm") + ("inline" "d_inline.htm") + ("input-stream-p" "f_in_stm.htm") + ("inspect" "f_inspec.htm") + ("integer" "t_intege.htm") + ("integer-decode-float" "f_dec_fl.htm") + ("integer-length" "f_intege.htm") + ("integerp" "f_inte_1.htm") + ("interactive-stream-p" "f_intera.htm") + ("intern" "f_intern.htm") + ("internal-time-units-per-second" "v_intern.htm") + ("intersection" "f_isec_.htm") + ("invalid-method-error" "f_invali.htm") + ("invoke-debugger" "f_invoke.htm") + ("invoke-restart" "f_invo_1.htm") + ("invoke-restart-interactively" "f_invo_2.htm") + ("isqrt" "f_sqrt_.htm") + ("keyword" "t_kwd.htm") + ("keywordp" "f_kwdp.htm") + ("labels" "s_flet_.htm") + ("lambda" "a_lambda.htm") + ("lambda-list-keywords" "v_lambda.htm") + ("lambda-parameters-limit" "v_lamb_1.htm") + ("last" "f_last.htm") + ("lcm" "f_lcm.htm") + ("ldb" "f_ldb.htm") + ("ldb-test" "f_ldb_te.htm") + ("ldiff" "f_ldiffc.htm") + ("least-negative-double-float" "v_most_1.htm") + ("least-negative-long-float" "v_most_1.htm") + ("least-negative-normalized-double-float" "v_most_1.htm") + ("least-negative-normalized-long-float" "v_most_1.htm") + ("least-negative-normalized-short-float" "v_most_1.htm") + ("least-negative-normalized-single-float" "v_most_1.htm") + ("least-negative-short-float" "v_most_1.htm") + ("least-negative-single-float" "v_most_1.htm") + ("least-positive-double-float" "v_most_1.htm") + ("least-positive-long-float" "v_most_1.htm") + ("least-positive-normalized-double-float" "v_most_1.htm") + ("least-positive-normalized-long-float" "v_most_1.htm") + ("least-positive-normalized-short-float" "v_most_1.htm") + ("least-positive-normalized-single-float" "v_most_1.htm") + ("least-positive-short-float" "v_most_1.htm") + ("least-positive-single-float" "v_most_1.htm") + ("length" "f_length.htm") + ("let" "s_let_l.htm") + ("let*" "s_let_l.htm") + ("lisp-implementation-type" "f_lisp_i.htm") + ("lisp-implementation-version" "f_lisp_i.htm") + ("list" "a_list.htm") + ("list*" "f_list_.htm") + ("list-all-packages" "f_list_a.htm") + ("list-length" "f_list_l.htm") + ("listen" "f_listen.htm") + ("listp" "f_listp.htm") + ("load" "f_load.htm") + ("load-logical-pathname-translations" "f_ld_log.htm") + ("load-time-value" "s_ld_tim.htm") + ("locally" "s_locall.htm") + ("log" "f_log.htm") + ("logand" "f_logand.htm") + ("logandc1" "f_logand.htm") + ("logandc2" "f_logand.htm") + ("logbitp" "f_logbtp.htm") + ("logcount" "f_logcou.htm") + ("logeqv" "f_logand.htm") + ("logical-pathname" "a_logica.htm") + ("logical-pathname-translations" "f_logica.htm") + ("logior" "f_logand.htm") + ("lognand" "f_logand.htm") + ("lognor" "f_logand.htm") + ("lognot" "f_logand.htm") + ("logorc1" "f_logand.htm") + ("logorc2" "f_logand.htm") + ("logtest" "f_logtes.htm") + ("logxor" "f_logand.htm") + ("long-float" "t_short_.htm") + ("long-float-epsilon" "v_short_.htm") + ("long-float-negative-epsilon" "v_short_.htm") + ("long-site-name" "f_short_.htm") + ("loop" "m_loop.htm") + ("loop-finish" "m_loop_f.htm") + ("lower-case-p" "f_upper_.htm") + ("machine-instance" "f_mach_i.htm") + ("machine-type" "f_mach_t.htm") + ("machine-version" "f_mach_v.htm") + ("macro-function" "f_macro_.htm") + ("macroexpand" "f_mexp_.htm") + ("macroexpand-1" "f_mexp_.htm") + ("macrolet" "s_flet_.htm") + ("make-array" "f_mk_ar.htm") + ("make-broadcast-stream" "f_mk_bro.htm") + ("make-concatenated-stream" "f_mk_con.htm") + ("make-condition" "f_mk_cnd.htm") + ("make-dispatch-macro-character" "f_mk_dis.htm") + ("make-echo-stream" "f_mk_ech.htm") + ("make-hash-table" "f_mk_has.htm") + ("make-instance" "f_mk_ins.htm") + ("make-instances-obsolete" "f_mk_i_1.htm") + ("make-list" "f_mk_lis.htm") + ("make-load-form" "f_mk_ld_.htm") + ("make-load-form-saving-slots" "f_mk_l_1.htm") + ("make-method" "m_call_m.htm") + ("make-package" "f_mk_pkg.htm") + ("make-pathname" "f_mk_pn.htm") + ("make-random-state" "f_mk_rnd.htm") + ("make-sequence" "f_mk_seq.htm") + ("make-string" "f_mk_stg.htm") + ("make-string-input-stream" "f_mk_s_1.htm") + ("make-string-output-stream" "f_mk_s_2.htm") + ("make-symbol" "f_mk_sym.htm") + ("make-synonym-stream" "f_mk_syn.htm") + ("make-two-way-stream" "f_mk_two.htm") + ("makunbound" "f_makunb.htm") + ("map" "f_map.htm") + ("map-into" "f_map_in.htm") + ("mapc" "f_mapc_.htm") + ("mapcan" "f_mapc_.htm") + ("mapcar" "f_mapc_.htm") + ("mapcon" "f_mapc_.htm") + ("maphash" "f_maphas.htm") + ("mapl" "f_mapc_.htm") + ("maplist" "f_mapc_.htm") + ("mask-field" "f_mask_f.htm") + ("max" "f_max_m.htm") + ("member" "a_member.htm") + ("member-if" "f_mem_m.htm") + ("member-if-not" "f_mem_m.htm") + ("merge" "f_merge.htm") + ("merge-pathnames" "f_merge_.htm") + ("method" "t_method.htm") + ("method-combination" "a_method.htm") + ("method-combination-error" "f_meth_1.htm") + ("method-qualifiers" "f_method.htm") + ("min" "f_max_m.htm") + ("minusp" "f_minusp.htm") + ("mismatch" "f_mismat.htm") + ("mod" "a_mod.htm") + ("most-negative-double-float" "v_most_1.htm") + ("most-negative-fixnum" "v_most_p.htm") + ("most-negative-long-float" "v_most_1.htm") + ("most-negative-short-float" "v_most_1.htm") + ("most-negative-single-float" "v_most_1.htm") + ("most-positive-double-float" "v_most_1.htm") + ("most-positive-fixnum" "v_most_p.htm") + ("most-positive-long-float" "v_most_1.htm") + ("most-positive-short-float" "v_most_1.htm") + ("most-positive-single-float" "v_most_1.htm") + ("muffle-warning" "a_muffle.htm") + ("multiple-value-bind" "m_multip.htm") + ("multiple-value-call" "s_multip.htm") + ("multiple-value-list" "m_mult_1.htm") + ("multiple-value-prog1" "s_mult_1.htm") + ("multiple-value-setq" "m_mult_2.htm") + ("multiple-values-limit" "v_multip.htm") + ("name-char" "f_name_c.htm") + ("namestring" "f_namest.htm") + ("nbutlast" "f_butlas.htm") + ("nconc" "f_nconc.htm") + ("next-method-p" "f_next_m.htm") + ("nil" "a_nil.htm") + ("nintersection" "f_isec_.htm") + ("ninth" "f_firstc.htm") + ("no-applicable-method" "f_no_app.htm") + ("no-next-method" "f_no_nex.htm") + ("not" "a_not.htm") + ("notany" "f_everyc.htm") + ("notevery" "f_everyc.htm") + ("notinline" "d_inline.htm") + ("nreconc" "f_revapp.htm") + ("nreverse" "f_revers.htm") + ("nset-difference" "f_set_di.htm") + ("nset-exclusive-or" "f_set_ex.htm") + ("nstring-capitalize" "f_stg_up.htm") + ("nstring-downcase" "f_stg_up.htm") + ("nstring-upcase" "f_stg_up.htm") + ("nsublis" "f_sublis.htm") + ("nsubst" "f_substc.htm") + ("nsubst-if" "f_substc.htm") + ("nsubst-if-not" "f_substc.htm") + ("nsubstitute" "f_sbs_s.htm") + ("nsubstitute-if" "f_sbs_s.htm") + ("nsubstitute-if-not" "f_sbs_s.htm") + ("nth" "f_nth.htm") + ("nth-value" "m_nth_va.htm") + ("nthcdr" "f_nthcdr.htm") + ("null" "a_null.htm") + ("number" "t_number.htm") + ("numberp" "f_nump.htm") + ("numerator" "f_numera.htm") + ("nunion" "f_unionc.htm") + ("oddp" "f_evenpc.htm") + ("open" "f_open.htm") + ("open-stream-p" "f_open_s.htm") + ("optimize" "d_optimi.htm") + ("or" "a_or.htm") + ("otherwise" "m_case_.htm") + ("output-stream-p" "f_in_stm.htm") + ("package" "t_pkg.htm") + ("package-error" "e_pkg_er.htm") + ("package-error-package" "f_pkg_er.htm") + ("package-name" "f_pkg_na.htm") + ("package-nicknames" "f_pkg_ni.htm") + ("package-shadowing-symbols" "f_pkg_sh.htm") + ("package-use-list" "f_pkg_us.htm") + ("package-used-by-list" "f_pkg__1.htm") + ("packagep" "f_pkgp.htm") + ("pairlis" "f_pairli.htm") + ("parse-error" "e_parse_.htm") + ("parse-integer" "f_parse_.htm") + ("parse-namestring" "f_pars_1.htm") + ("pathname" "a_pn.htm") + ("pathname-device" "f_pn_hos.htm") + ("pathname-directory" "f_pn_hos.htm") + ("pathname-host" "f_pn_hos.htm") + ("pathname-match-p" "f_pn_mat.htm") + ("pathname-name" "f_pn_hos.htm") + ("pathname-type" "f_pn_hos.htm") + ("pathname-version" "f_pn_hos.htm") + ("pathnamep" "f_pnp.htm") + ("peek-char" "f_peek_c.htm") + ("phase" "f_phase.htm") + ("pi" "v_pi.htm") + ("plusp" "f_minusp.htm") + ("pop" "m_pop.htm") + ("position" "f_pos_p.htm") + ("position-if" "f_pos_p.htm") + ("position-if-not" "f_pos_p.htm") + ("pprint" "f_wr_pr.htm") + ("pprint-dispatch" "f_ppr_di.htm") + ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm") + ("pprint-fill" "f_ppr_fi.htm") + ("pprint-indent" "f_ppr_in.htm") + ("pprint-linear" "f_ppr_fi.htm") + ("pprint-logical-block" "m_ppr_lo.htm") + ("pprint-newline" "f_ppr_nl.htm") + ("pprint-pop" "m_ppr_po.htm") + ("pprint-tab" "f_ppr_ta.htm") + ("pprint-tabular" "f_ppr_fi.htm") + ("prin1" "f_wr_pr.htm") + ("prin1-to-string" "f_wr_to_.htm") + ("princ" "f_wr_pr.htm") + ("princ-to-string" "f_wr_to_.htm") + ("print" "f_wr_pr.htm") + ("print-not-readable" "e_pr_not.htm") + ("print-not-readable-object" "f_pr_not.htm") + ("print-object" "f_pr_obj.htm") + ("print-unreadable-object" "m_pr_unr.htm") + ("probe-file" "f_probe_.htm") + ("proclaim" "f_procla.htm") + ("prog" "m_prog_.htm") + ("prog*" "m_prog_.htm") + ("prog1" "m_prog1c.htm") + ("prog2" "m_prog1c.htm") + ("progn" "s_progn.htm") + ("program-error" "e_progra.htm") + ("progv" "s_progv.htm") + ("provide" "f_provid.htm") + ("psetf" "m_setf_.htm") + ("psetq" "m_psetq.htm") + ("push" "m_push.htm") + ("pushnew" "m_pshnew.htm") + ("quote" "s_quote.htm") + ("random" "f_random.htm") + ("random-state" "t_rnd_st.htm") + ("random-state-p" "f_rnd_st.htm") + ("rassoc" "f_rassoc.htm") + ("rassoc-if" "f_rassoc.htm") + ("rassoc-if-not" "f_rassoc.htm") + ("ratio" "t_ratio.htm") + ("rational" "a_ration.htm") + ("rationalize" "f_ration.htm") + ("rationalp" "f_rati_1.htm") + ("read" "f_rd_rd.htm") + ("read-byte" "f_rd_by.htm") + ("read-char" "f_rd_cha.htm") + ("read-char-no-hang" "f_rd_c_1.htm") + ("read-delimited-list" "f_rd_del.htm") + ("read-from-string" "f_rd_fro.htm") + ("read-line" "f_rd_lin.htm") + ("read-preserving-whitespace" "f_rd_rd.htm") + ("read-sequence" "f_rd_seq.htm") + ("reader-error" "e_rder_e.htm") + ("readtable" "t_rdtabl.htm") + ("readtable-case" "f_rdtabl.htm") + ("readtablep" "f_rdta_1.htm") + ("real" "t_real.htm") + ("realp" "f_realp.htm") + ("realpart" "f_realpa.htm") + ("reduce" "f_reduce.htm") + ("reinitialize-instance" "f_reinit.htm") + ("rem" "f_mod_r.htm") + ("remf" "m_remf.htm") + ("remhash" "f_remhas.htm") + ("remove" "f_rm_rm.htm") + ("remove-duplicates" "f_rm_dup.htm") + ("remove-if" "f_rm_rm.htm") + ("remove-if-not" "f_rm_rm.htm") + ("remove-method" "f_rm_met.htm") + ("remprop" "f_rempro.htm") + ("rename-file" "f_rn_fil.htm") + ("rename-package" "f_rn_pkg.htm") + ("replace" "f_replac.htm") + ("require" "f_provid.htm") + ("rest" "f_rest.htm") + ("restart" "t_rst.htm") + ("restart-bind" "m_rst_bi.htm") + ("restart-case" "m_rst_ca.htm") + ("restart-name" "f_rst_na.htm") + ("return" "m_return.htm") + ("return-from" "s_ret_fr.htm") + ("revappend" "f_revapp.htm") + ("reverse" "f_revers.htm") + ("room" "f_room.htm") + ("rotatef" "m_rotate.htm") + ("round" "f_floorc.htm") + ("row-major-aref" "f_row_ma.htm") + ("rplaca" "f_rplaca.htm") + ("rplacd" "f_rplaca.htm") + ("safety" "d_optimi.htm") + ("satisfies" "t_satisf.htm") + ("sbit" "f_bt_sb.htm") + ("scale-float" "f_dec_fl.htm") + ("schar" "f_char_.htm") + ("search" "f_search.htm") + ("second" "f_firstc.htm") + ("sequence" "t_seq.htm") + ("serious-condition" "e_seriou.htm") + ("set" "f_set.htm") + ("set-difference" "f_set_di.htm") + ("set-dispatch-macro-character" "f_set__1.htm") + ("set-exclusive-or" "f_set_ex.htm") + ("set-macro-character" "f_set_ma.htm") + ("set-pprint-dispatch" "f_set_pp.htm") + ("set-syntax-from-char" "f_set_sy.htm") + ("setf" "a_setf.htm") + ("setq" "s_setq.htm") + ("seventh" "f_firstc.htm") + ("shadow" "f_shadow.htm") + ("shadowing-import" "f_shdw_i.htm") + ("shared-initialize" "f_shared.htm") + ("shiftf" "m_shiftf.htm") + ("short-float" "t_short_.htm") + ("short-float-epsilon" "v_short_.htm") + ("short-float-negative-epsilon" "v_short_.htm") + ("short-site-name" "f_short_.htm") + ("signal" "f_signal.htm") + ("signed-byte" "t_sgn_by.htm") + ("signum" "f_signum.htm") + ("simple-array" "t_smp_ar.htm") + ("simple-base-string" "t_smp_ba.htm") + ("simple-bit-vector" "t_smp_bt.htm") + ("simple-bit-vector-p" "f_smp_bt.htm") + ("simple-condition" "e_smp_cn.htm") + ("simple-condition-format-arguments" "f_smp_cn.htm") + ("simple-condition-format-control" "f_smp_cn.htm") + ("simple-error" "e_smp_er.htm") + ("simple-string" "t_smp_st.htm") + ("simple-string-p" "f_smp_st.htm") + ("simple-type-error" "e_smp_tp.htm") + ("simple-vector" "t_smp_ve.htm") + ("simple-vector-p" "f_smp_ve.htm") + ("simple-warning" "e_smp_wa.htm") + ("sin" "f_sin_c.htm") + ("single-float" "t_short_.htm") + ("single-float-epsilon" "v_short_.htm") + ("single-float-negative-epsilon" "v_short_.htm") + ("sinh" "f_sinh_.htm") + ("sixth" "f_firstc.htm") + ("sleep" "f_sleep.htm") + ("slot-boundp" "f_slt_bo.htm") + ("slot-exists-p" "f_slt_ex.htm") + ("slot-makunbound" "f_slt_ma.htm") + ("slot-missing" "f_slt_mi.htm") + ("slot-unbound" "f_slt_un.htm") + ("slot-value" "f_slt_va.htm") + ("software-type" "f_sw_tpc.htm") + ("software-version" "f_sw_tpc.htm") + ("some" "f_everyc.htm") + ("sort" "f_sort_.htm") + ("space" "d_optimi.htm") + ("special" "d_specia.htm") + ("special-operator-p" "f_specia.htm") + ("speed" "d_optimi.htm") + ("sqrt" "f_sqrt_.htm") + ("stable-sort" "f_sort_.htm") + ("standard" "07_ffb.htm") + ("standard-char" "t_std_ch.htm") + ("standard-char-p" "f_std_ch.htm") + ("standard-class" "t_std_cl.htm") + ("standard-generic-function" "t_std_ge.htm") + ("standard-method" "t_std_me.htm") + ("standard-object" "t_std_ob.htm") + ("step" "m_step.htm") + ("storage-condition" "e_storag.htm") + ("store-value" "a_store_.htm") + ("stream" "t_stream.htm") + ("stream-element-type" "f_stm_el.htm") + ("stream-error" "e_stm_er.htm") + ("stream-error-stream" "f_stm_er.htm") + ("stream-external-format" "f_stm_ex.htm") + ("streamp" "f_stmp.htm") + ("string" "a_string.htm") + ("string-capitalize" "f_stg_up.htm") + ("string-downcase" "f_stg_up.htm") + ("string-equal" "f_stgeq_.htm") + ("string-greaterp" "f_stgeq_.htm") + ("string-left-trim" "f_stg_tr.htm") + ("string-lessp" "f_stgeq_.htm") + ("string-not-equal" "f_stgeq_.htm") + ("string-not-greaterp" "f_stgeq_.htm") + ("string-not-lessp" "f_stgeq_.htm") + ("string-right-trim" "f_stg_tr.htm") + ("string-stream" "t_stg_st.htm") + ("string-trim" "f_stg_tr.htm") + ("string-upcase" "f_stg_up.htm") + ("string/=" "f_stgeq_.htm") + ("string<" "f_stgeq_.htm") + ("string<=" "f_stgeq_.htm") + ("string=" "f_stgeq_.htm") + ("string>" "f_stgeq_.htm") + ("string>=" "f_stgeq_.htm") + ("stringp" "f_stgp.htm") + ("structure" "f_docume.htm") + ("structure-class" "t_stu_cl.htm") + ("structure-object" "t_stu_ob.htm") + ("style-warning" "e_style_.htm") + ("sublis" "f_sublis.htm") + ("subseq" "f_subseq.htm") + ("subsetp" "f_subset.htm") + ("subst" "f_substc.htm") + ("subst-if" "f_substc.htm") + ("subst-if-not" "f_substc.htm") + ("substitute" "f_sbs_s.htm") + ("substitute-if" "f_sbs_s.htm") + ("substitute-if-not" "f_sbs_s.htm") + ("subtypep" "f_subtpp.htm") + ("svref" "f_svref.htm") + ("sxhash" "f_sxhash.htm") + ("symbol" "t_symbol.htm") + ("symbol-function" "f_symb_1.htm") + ("symbol-macrolet" "s_symbol.htm") + ("symbol-name" "f_symb_2.htm") + ("symbol-package" "f_symb_3.htm") + ("symbol-plist" "f_symb_4.htm") + ("symbol-value" "f_symb_5.htm") + ("symbolp" "f_symbol.htm") + ("synonym-stream" "t_syn_st.htm") + ("synonym-stream-symbol" "f_syn_st.htm") + ("t" "a_t.htm") + ("tagbody" "s_tagbod.htm") + ("tailp" "f_ldiffc.htm") + ("tan" "f_sin_c.htm") + ("tanh" "f_sinh_.htm") + ("tenth" "f_firstc.htm") + ("terpri" "f_terpri.htm") + ("the" "s_the.htm") + ("third" "f_firstc.htm") + ("throw" "s_throw.htm") + ("time" "m_time.htm") + ("trace" "m_tracec.htm") + ("translate-logical-pathname" "f_tr_log.htm") + ("translate-pathname" "f_tr_pn.htm") + ("tree-equal" "f_tree_e.htm") + ("truename" "f_tn.htm") + ("truncate" "f_floorc.htm") + ("two-way-stream" "t_two_wa.htm") + ("two-way-stream-input-stream" "f_two_wa.htm") + ("two-way-stream-output-stream" "f_two_wa.htm") + ("type" "a_type.htm") + ("type-error" "e_tp_err.htm") + ("type-error-datum" "f_tp_err.htm") + ("type-error-expected-type" "f_tp_err.htm") + ("type-of" "f_tp_of.htm") + ("typecase" "m_tpcase.htm") + ("typep" "f_typep.htm") + ("unbound-slot" "e_unboun.htm") + ("unbound-slot-instance" "f_unboun.htm") + ("unbound-variable" "e_unbo_1.htm") + ("undefined-function" "e_undefi.htm") + ("unexport" "f_unexpo.htm") + ("unintern" "f_uninte.htm") + ("union" "f_unionc.htm") + ("unless" "m_when_.htm") + ("unread-char" "f_unrd_c.htm") + ("unsigned-byte" "t_unsgn_.htm") + ("untrace" "m_tracec.htm") + ("unuse-package" "f_unuse_.htm") + ("unwind-protect" "s_unwind.htm") + ("update-instance-for-different-class" "f_update.htm") + ("update-instance-for-redefined-class" "f_upda_1.htm") + ("upgraded-array-element-type" "f_upgr_1.htm") + ("upgraded-complex-part-type" "f_upgrad.htm") + ("upper-case-p" "f_upper_.htm") + ("use-package" "f_use_pk.htm") + ("use-value" "a_use_va.htm") + ("user-homedir-pathname" "f_user_h.htm") + ("values" "a_values.htm") + ("values-list" "f_vals_l.htm") + ("variable" "f_docume.htm") + ("vector" "a_vector.htm") + ("vector-pop" "f_vec_po.htm") + ("vector-push" "f_vec_ps.htm") + ("vector-push-extend" "f_vec_ps.htm") + ("vectorp" "f_vecp.htm") + ("warn" "f_warn.htm") + ("warning" "e_warnin.htm") + ("when" "m_when_.htm") + ("wild-pathname-p" "f_wild_p.htm") + ("with-accessors" "m_w_acce.htm") + ("with-compilation-unit" "m_w_comp.htm") + ("with-condition-restarts" "m_w_cnd_.htm") + ("with-hash-table-iterator" "m_w_hash.htm") + ("with-input-from-string" "m_w_in_f.htm") + ("with-open-file" "m_w_open.htm") + ("with-open-stream" "m_w_op_1.htm") + ("with-output-to-string" "m_w_out_.htm") + ("with-package-iterator" "m_w_pkg_.htm") + ("with-simple-restart" "m_w_smp_.htm") + ("with-slots" "m_w_slts.htm") + ("with-standard-io-syntax" "m_w_std_.htm") + ("write" "f_wr_pr.htm") + ("write-byte" "f_wr_by.htm") + ("write-char" "f_wr_cha.htm") + ("write-line" "f_wr_stg.htm") + ("write-sequence" "f_wr_seq.htm") + ("write-string" "f_wr_stg.htm") + ("write-to-string" "f_wr_to_.htm") + ("y-or-n-p" "f_y_or_n.htm") + ("yes-or-no-p" "f_y_or_n.htm") + ("zerop" "f_zerop.htm")))) + +;;; Added entries for reader macros. +;;; +;;; 20090302 Tobias C Rittweiler, and Stas Boukarev + +(defvar common-lisp-hyperspec--reader-macros (make-hash-table :test #'equal)) + +;;; Data/Map_Sym.txt in does not contain entries for the reader +;;; macros. So we have to enumerate these explicitly. +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--reader-macros)) + '(("#" "02_dh.htm") + ("##" "02_dhp.htm") + ("#'" "02_dhb.htm") + ("#(" "02_dhc.htm") + ("#*" "02_dhd.htm") + ("#:" "02_dhe.htm") + ("#." "02_dhf.htm") + ("#=" "02_dho.htm") + ("#+" "02_dhq.htm") + ("#-" "02_dhr.htm") + ("#<" "02_dht.htm") + ("#A" "02_dhl.htm") + ("#B" "02_dhg.htm") + ("#C" "02_dhk.htm") + ("#O" "02_dhh.htm") + ("#P" "02_dhn.htm") + ("#R" "02_dhj.htm") + ("#S" "02_dhm.htm") + ("#X" "02_dhi.htm") + ("#\\" "02_dha.htm") + ("#|" "02_dhs.htm") + ("\"" "02_de.htm") + ("'" "02_dc.htm") + ("`" "02_df.htm") + ("," "02_dg.htm") + ("(" "02_da.htm") + (")" "02_db.htm") + (";" "02_dd.htm"))) + +(defun common-lisp-hyperspec-lookup-reader-macro (macro) + "Browse the CLHS entry for the reader-macro MACRO." + (interactive + (list + (let ((completion-ignore-case t)) + (completing-read "Look up reader-macro: " + common-lisp-hyperspec--reader-macros nil t + (common-lisp-hyperspec-reader-macro-at-point))))) + (browse-url + (concat common-lisp-hyperspec-root "Body/" + (gethash macro common-lisp-hyperspec--reader-macros)))) + +(defun common-lisp-hyperspec-reader-macro-at-point () + (let ((regexp "\\(#.?\\)\\|\\([\"',`';()]\\)")) + (when (looking-back regexp nil t) + (match-string-no-properties 0)))) + +;;; FORMAT character lookup by Frode Vatvedt Fjeld 20030902 +;;; +;;; adjusted for ILISP by Nikodemus Siivola 20030903 + +(defvar common-lisp-hyperspec-format-history nil + "History of format characters looked up in the Common Lisp HyperSpec.") + +(defun common-lisp-hyperspec-section-6.0 (indices) + (let ((string (format "%sBody/%s_" + common-lisp-hyperspec-root + (let ((base (pop indices))) + (if (< base 10) + (format "0%s" base) + base))))) + (concat string + (mapconcat (lambda (n) + (make-string 1 (+ ?a (- n 1)))) + indices + "") + ".htm"))) + +(defun common-lisp-hyperspec-section-4.0 (indices) + (let ((string (format "%sBody/sec_" + common-lisp-hyperspec-root))) + (concat string + (mapconcat (lambda (n) + (format "%d" n)) + indices + "-") + ".html"))) + +(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0) + +(defun common-lisp-hyperspec-section (indices) + (funcall common-lisp-hyperspec-section-fun indices)) + +(defvar common-lisp-hyperspec--format-characters + (make-hash-table :test 'equal)) + +(defun common-lisp-hyperspec--read-format-character () + (let ((char-at-point + (ignore-errors (char-to-string (char-after (point)))))) + (if (and char-at-point + (gethash (upcase char-at-point) + common-lisp-hyperspec--format-characters)) + char-at-point + (completing-read + "Look up format control character in Common Lisp HyperSpec: " + common-lisp-hyperspec--format-characters nil t nil + 'common-lisp-hyperspec-format-history)))) + +(defun common-lisp-hyperspec-format (character-name) + (interactive (list (common-lisp-hyperspec--read-format-character))) + (cl-maplist (lambda (entry) + (browse-url (common-lisp-hyperspec-section (car entry)))) + (or (gethash character-name + common-lisp-hyperspec--format-characters) + (error "The symbol `%s' is not defined in Common Lisp" + character-name)))) + +;;; Previously there were entries for "C" and "C: Character", +;;; which unpleasingly crowded the completion buffer, so I made +;;; it show one entry ("C - Character") only. +;;; +;;; 20100131 Tobias C Rittweiler + +(defun common-lisp-hyperspec--insert-format-directive (char section + &optional summary) + (let* ((designator (if summary (format "%s - %s" char summary) char))) + (cl-pushnew section (gethash designator + common-lisp-hyperspec--format-characters) + :test #'equal))) + +(mapc (lambda (entry) + (cl-destructuring-bind (char section &optional summary) entry + (common-lisp-hyperspec--insert-format-directive char section summary) + (when (and (= 1 (length char)) + (not (string-equal char (upcase char)))) + (common-lisp-hyperspec--insert-format-directive + (upcase char) section summary)))) + '(("c" (22 3 1 1) "Character") + ("%" (22 3 1 2) "Newline") + ("&" (22 3 1 3) "Fresh-line") + ("|" (22 3 1 4) "Page") + ("~" (22 3 1 5) "Tilde") + ("r" (22 3 2 1) "Radix") + ("d" (22 3 2 2) "Decimal") + ("b" (22 3 2 3) "Binary") + ("o" (22 3 2 4) "Octal") + ("x" (22 3 2 5) "Hexadecimal") + ("f" (22 3 3 1) "Fixed-Format Floating-Point") + ("e" (22 3 3 2) "Exponential Floating-Point") + ("g" (22 3 3 3) "General Floating-Point") + ("$" (22 3 3 4) "Monetary Floating-Point") + ("a" (22 3 4 1) "Aesthetic") + ("s" (22 3 4 2) "Standard") + ("w" (22 3 4 3) "Write") + ("_" (22 3 5 1) "Conditional Newline") + ("<" (22 3 5 2) "Logical Block") + ("i" (22 3 5 3) "Indent") + ("/" (22 3 5 4) "Call Function") + ("t" (22 3 6 1) "Tabulate") + ("<" (22 3 6 2) "Justification") + (">" (22 3 6 3) "End of Justification") + ("*" (22 3 7 1) "Go-To") + ("[" (22 3 7 2) "Conditional Expression") + ("]" (22 3 7 3) "End of Conditional Expression") + ("{" (22 3 7 4) "Iteration") + ("}" (22 3 7 5) "End of Iteration") + ("?" (22 3 7 6) "Recursive Processing") + ("(" (22 3 8 1) "Case Conversion") + (")" (22 3 8 2) "End of Case Conversion") + ("p" (22 3 8 3) "Plural") + (";" (22 3 9 1) "Clause Separator") + ("^" (22 3 9 2) "Escape Upward") + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) + + +;;;; Glossary + +(defvar common-lisp-hyperspec-glossary-function 'common-lisp-glossary-6.0 + "Function that creates a URL for a glossary term.") + +(define-obsolete-variable-alias 'common-lisp-glossary-fun + 'common-lisp-hyperspec-glossary-function) + +(defvar common-lisp-hyperspec--glossary-terms (make-hash-table :test #'equal) + "Collection of glossary terms and relative URLs.") + +;;; Functions + +;;; The functions below are used to collect glossary terms and page anchors +;;; from CLHS. They are commented out because they are not needed unless the +;;; list of terms/anchors need to be updated. + +;; (defun common-lisp-hyperspec-glossary-pages () +;; "List of CLHS glossary pages." +;; (mapcar (lambda (end) +;; (format "%sBody/26_glo_%s.htm" +;; common-lisp-hyperspec-root +;; end)) +;; (cons "9" (mapcar #'char-to-string +;; (number-sequence ?a ?z))))) + +;; (defun common-lisp-hyperspec-glossary-download () +;; "Download CLHS glossary pages to temporary files and return a +;; list of file names." +;; (mapcar (lambda (url) +;; (url-file-local-copy url)) +;; (common-lisp-hyperspec-glossary-pages))) + +;; (defun common-lisp-hyperspec-glossary-entries (file) +;; "Given a CLHS glossary file FILE, return a list of +;; term-anchor pairs. + +;; Term is the glossary term and anchor is the term's anchor on the +;; page." +;; (let (entries) +;; (save-excursion +;; (set-buffer (find-file-noselect file)) +;; (goto-char (point-min)) +;; (while (search-forward-regexp "\\(.*?\\)" nil t) +;; (setq entries (cons (list (match-string-no-properties 2) +;; (match-string-no-properties 1)) +;; entries)))) +;; (sort entries (lambda (a b) +;; (string< (car a) (car b)))))) + +;; ;; Add glossary terms by downloading and parsing glossary pages from CLHS +;; (mapc (lambda (entry) +;; (puthash (car entry) (cadr entry) +;; common-lisp-hyperspec--glossary-terms)) +;; (cl-reduce (lambda (a b) +;; (append a b)) +;; (mapcar #'common-lisp-hyperspec-glossary-entries +;; (common-lisp-hyperspec-glossary-download)))) + +;; Add glossary entries to the master hash table +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--glossary-terms)) + '(("()" "OPCP") + ("absolute" "absolute") + ("access" "access") + ("accessibility" "accessibility") + ("accessible" "accessible") + ("accessor" "accessor") + ("active" "active") + ("actual adjustability" "actual_adjustability") + ("actual argument" "actual_argument") + ("actual array element type" "actual_array_element_type") + ("actual complex part type" "actual_complex_part_type") + ("actual parameter" "actual_parameter") + ("actually adjustable" "actually_adjustable") + ("adjustability" "adjustability") + ("adjustable" "adjustable") + ("after method" "after_method") + ("alist" "alist") + ("alphabetic" "alphabetic") + ("alphanumeric" "alphanumeric") + ("ampersand" "ampersand") + ("anonymous" "anonymous") + ("apparently uninterned" "apparently_uninterned") + ("applicable" "applicable") + ("applicable handler" "applicable_handler") + ("applicable method" "applicable_method") + ("applicable restart" "applicable_restart") + ("apply" "apply") + ("argument" "argument") + ("argument evaluation order" "argument_evaluation_order") + ("argument precedence order" "argument_precedence_order") + ("around method" "around_method") + ("array" "array") + ("array element type" "array_element_type") + ("array total size" "array_total_size") + ("assign" "assign") + ("association list" "association_list") + ("asterisk" "asterisk") + ("at-sign" "at-sign") + ("atom" "atom") + ("atomic" "atomic") + ("atomic type specifier" "atomic_type_specifier") + ("attribute" "attribute") + ("aux variable" "aux_variable") + ("auxiliary method" "auxiliary_method") + ("backquote" "backquote") + ("backslash" "backslash") + ("base character" "base_character") + ("base string" "base_string") + ("before method" "before_method") + ("bidirectional" "bidirectional") + ("binary" "binary") + ("bind" "bind") + ("binding" "binding") + ("bit" "bit") + ("bit array" "bit_array") + ("bit vector" "bit_vector") + ("bit-wise logical operation specifier" "bit-wise_logical_operation_specifier") + ("block" "block") + ("block tag" "block_tag") + ("boa lambda list" "boa_lambda_list") + ("body parameter" "body_parameter") + ("boolean" "boolean") + ("boolean equivalent" "boolean_equivalent") + ("bound" "bound") + ("bound declaration" "bound_declaration") + ("bounded" "bounded") + ("bounding index" "bounding_index") + ("bounding index designator" "bounding_index_designator") + ("break loop" "break_loop") + ("broadcast stream" "broadcast_stream") + ("built-in class" "built-in_class") + ("built-in type" "built-in_type") + ("byte" "byte") + ("byte specifier" "byte_specifier") + ("cadr" "cadr") + ("call" "call") + ("captured initialization form" "captured_initialization_form") + ("car" "car") + ("case" "case") + ("case sensitivity mode" "case_sensitivity_mode") + ("catch" "catch") + ("catch tag" "catch_tag") + ("cddr" "cddr") + ("cdr" "cdr") + ("cell" "cell") + ("character" "character") + ("character code" "character_code") + ("character designator" "character_designator") + ("circular" "circular") + ("circular list" "circular_list") + ("class" "class") + ("class designator" "class_designator") + ("class precedence list" "class_precedence_list") + ("close" "close") + ("closed" "closed") + ("closure" "closure") + ("coalesce" "coalesce") + ("code" "code") + ("coerce" "coerce") + ("colon" "colon") + ("comma" "comma") + ("compilation" "compilation") + ("compilation environment" "compilation_environment") + ("compilation unit" "compilation_unit") + ("compile" "compile") + ("compile time" "compile_time") + ("compile-time definition" "compile-time_definition") + ("compiled code" "compiled_code") + ("compiled file" "compiled_file") + ("compiled function" "compiled_function") + ("compiler" "compiler") + ("compiler macro" "compiler_macro") + ("compiler macro expansion" "compiler_macro_expansion") + ("compiler macro form" "compiler_macro_form") + ("compiler macro function" "compiler_macro_function") + ("complex" "complex") + ("complex float" "complex_float") + ("complex part type" "complex_part_type") + ("complex rational" "complex_rational") + ("complex single float" "complex_single_float") + ("composite stream" "composite_stream") + ("compound form" "compound_form") + ("compound type specifier" "compound_type_specifier") + ("concatenated stream" "concatenated_stream") + ("condition" "condition") + ("condition designator" "condition_designator") + ("condition handler" "condition_handler") + ("condition reporter" "condition_reporter") + ("conditional newline" "conditional_newline") + ("conformance" "conformance") + ("conforming code" "conforming_code") + ("conforming implementation" "conforming_implementation") + ("conforming processor" "conforming_processor") + ("conforming program" "conforming_program") + ("congruent" "congruent") + ("cons" "cons") + ("constant" "constant") + ("constant form" "constant_form") + ("constant object" "constant_object") + ("constant variable" "constant_variable") + ("constituent" "constituent") + ("constituent trait" "constituent_trait") + ("constructed stream" "constructed_stream") + ("contagion" "contagion") + ("continuable" "continuable") + ("control form" "control_form") + ("copy" "copy") + ("correctable" "correctable") + ("current input base" "current_input_base") + ("current logical block" "current_logical_block") + ("current output base" "current_output_base") + ("current package" "current_package") + ("current pprint dispatch table" "current_pprint_dispatch_table") + ("current random state" "current_random_state") + ("current readtable" "current_readtable") + ("data type" "data_type") + ("debug I/O" "debug_iSLo") + ("debugger" "debugger") + ("declaration" "declaration") + ("declaration identifier" "declaration_identifier") + ("declaration specifier" "declaration_specifier") + ("declare" "declare") + ("decline" "decline") + ("decoded time" "decoded_time") + ("default method" "default_method") + ("defaulted initialization argument list" "defaulted_initialization_argument_list") + ("define-method-combination arguments lambda list" "define-method-combination_arguments_lambda_list") + ("define-modify-macro lambda list" "define-modify-macro_lambda_list") + ("defined name" "defined_name") + ("defining form" "defining_form") + ("defsetf lambda list" "defsetf_lambda_list") + ("deftype lambda list" "deftype_lambda_list") + ("denormalized" "denormalized") + ("derived type" "derived_type") + ("derived type specifier" "derived_type_specifier") + ("designator" "designator") + ("destructive" "destructive") + ("destructuring lambda list" "destructuring_lambda_list") + ("different" "different") + ("digit" "digit") + ("dimension" "dimension") + ("direct instance" "direct_instance") + ("direct subclass" "direct_subclass") + ("direct superclass" "direct_superclass") + ("disestablish" "disestablish") + ("disjoint" "disjoint") + ("dispatching macro character" "dispatching_macro_character") + ("displaced array" "displaced_array") + ("distinct" "distinct") + ("documentation string" "documentation_string") + ("dot" "dot") + ("dotted list" "dotted_list") + ("dotted pair" "dotted_pair") + ("double float" "double_float") + ("double-quote" "double-quote") + ("dynamic binding" "dynamic_binding") + ("dynamic environment" "dynamic_environment") + ("dynamic extent" "dynamic_extent") + ("dynamic scope" "dynamic_scope") + ("dynamic variable" "dynamic_variable") + ("echo stream" "echo_stream") + ("effective method" "effective_method") + ("element" "element") + ("element type" "element_type") + ("em" "em") + ("empty list" "empty_list") + ("empty type" "empty_type") + ("end of file" "end_of_file") + ("environment" "environment") + ("environment object" "environment_object") + ("environment parameter" "environment_parameter") + ("error" "error") + ("error output" "error_output") + ("escape" "escape") + ("establish" "establish") + ("evaluate" "evaluate") + ("evaluation" "evaluation") + ("evaluation environment" "evaluation_environment") + ("execute" "execute") + ("execution time" "execution_time") + ("exhaustive partition" "exhaustive_partition") + ("exhaustive union" "exhaustive_union") + ("exit point" "exit_point") + ("explicit return" "explicit_return") + ("explicit use" "explicit_use") + ("exponent marker" "exponent_marker") + ("export" "export") + ("exported" "exported") + ("expressed adjustability" "expressed_adjustability") + ("expressed array element type" "expressed_array_element_type") + ("expressed complex part type" "expressed_complex_part_type") + ("expression" "expression") + ("expressly adjustable" "expressly_adjustable") + ("extended character" "extended_character") + ("extended function designator" "extended_function_designator") + ("extended lambda list" "extended_lambda_list") + ("extension" "extension") + ("extent" "extent") + ("external file format" "external_file_format") + ("external file format designator" "external_file_format_designator") + ("external symbol" "external_symbol") + ("externalizable object" "externalizable_object") + ("false" "false") + ("fbound" "fbound") + ("feature" "feature") + ("feature expression" "feature_expression") + ("features list" "features_list") + ("file" "file") + ("file compiler" "file_compiler") + ("file position" "file_position") + ("file position designator" "file_position_designator") + ("file stream" "file_stream") + ("file system" "file_system") + ("filename" "filename") + ("fill pointer" "fill_pointer") + ("finite" "finite") + ("fixnum" "fixnum") + ("float" "float") + ("for-value" "for-value") + ("form" "form") + ("formal argument" "formal_argument") + ("formal parameter" "formal_parameter") + ("format" "format") + ("format argument" "format_argument") + ("format control" "format_control") + ("format directive" "format_directive") + ("format string" "format_string") + ("free declaration" "free_declaration") + ("fresh" "fresh") + ("freshline" "freshline") + ("funbound" "funbound") + ("function" "function") + ("function block name" "function_block_name") + ("function cell" "function_cell") + ("function designator" "function_designator") + ("function form" "function_form") + ("function name" "function_name") + ("functional evaluation" "functional_evaluation") + ("functional value" "functional_value") + ("further compilation" "further_compilation") + ("general" "general") + ("generalized boolean" "generalized_boolean") + ("generalized instance" "generalized_instance") + ("generalized reference" "generalized_reference") + ("generalized synonym stream" "generalized_synonym_stream") + ("generic function" "generic_function") + ("generic function lambda list" "generic_function_lambda_list") + ("gensym" "gensym") + ("global declaration" "global_declaration") + ("global environment" "global_environment") + ("global variable" "global_variable") + ("glyph" "glyph") + ("go" "go") + ("go point" "go_point") + ("go tag" "go_tag") + ("graphic" "graphic") + ("handle" "handle") + ("handler" "handler") + ("hash table" "hash_table") + ("home package" "home_package") + ("I/O customization variable" "iSLo_customization_variable") + ("identical" "identical") + ("identifier" "identifier") + ("immutable" "immutable") + ("implementation" "implementation") + ("implementation limit" "implementation_limit") + ("implementation-defined" "implementation-defined") + ("implementation-dependent" "implementation-dependent") + ("implementation-independent" "implementation-independent") + ("implicit block" "implicit_block") + ("implicit compilation" "implicit_compilation") + ("implicit progn" "implicit_progn") + ("implicit tagbody" "implicit_tagbody") + ("import" "import") + ("improper list" "improper_list") + ("inaccessible" "inaccessible") + ("indefinite extent" "indefinite_extent") + ("indefinite scope" "indefinite_scope") + ("indicator" "indicator") + ("indirect instance" "indirect_instance") + ("inherit" "inherit") + ("initial pprint dispatch table" "initial_pprint_dispatch_table") + ("initial readtable" "initial_readtable") + ("initialization argument list" "initialization_argument_list") + ("initialization form" "initialization_form") + ("input" "input") + ("instance" "instance") + ("integer" "integer") + ("interactive stream" "interactive_stream") + ("intern" "intern") + ("internal symbol" "internal_symbol") + ("internal time" "internal_time") + ("internal time unit" "internal_time_unit") + ("interned" "interned") + ("interpreted function" "interpreted_function") + ("interpreted implementation" "interpreted_implementation") + ("interval designator" "interval_designator") + ("invalid" "invalid") + ("iteration form" "iteration_form") + ("iteration variable" "iteration_variable") + ("key" "key") + ("keyword" "keyword") + ("keyword parameter" "keyword_parameter") + ("keyword/value pair" "keywordSLvalue_pair") + ("Lisp image" "lisp_image") + ("Lisp printer" "lisp_printer") + ("Lisp read-eval-print loop" "lisp_read-eval-print_loop") + ("Lisp reader" "lisp_reader") + ("lambda combination" "lambda_combination") + ("lambda expression" "lambda_expression") + ("lambda form" "lambda_form") + ("lambda list" "lambda_list") + ("lambda list keyword" "lambda_list_keyword") + ("lambda variable" "lambda_variable") + ("leaf" "leaf") + ("leap seconds" "leap_seconds") + ("left-parenthesis" "left-parenthesis") + ("length" "length") + ("lexical binding" "lexical_binding") + ("lexical closure" "lexical_closure") + ("lexical environment" "lexical_environment") + ("lexical scope" "lexical_scope") + ("lexical variable" "lexical_variable") + ("list" "list") + ("list designator" "list_designator") + ("list structure" "list_structure") + ("literal" "literal") + ("load" "load") + ("load time" "load_time") + ("load time value" "load_time_value") + ("loader" "loader") + ("local declaration" "local_declaration") + ("local precedence order" "local_precedence_order") + ("local slot" "local_slot") + ("logical block" "logical_block") + ("logical host" "logical_host") + ("logical host designator" "logical_host_designator") + ("logical pathname" "logical_pathname") + ("long float" "long_float") + ("loop keyword" "loop_keyword") + ("lowercase" "lowercase") + ("Metaobject Protocol" "metaobject_protocol") + ("macro" "macro") + ("macro character" "macro_character") + ("macro expansion" "macro_expansion") + ("macro form" "macro_form") + ("macro function" "macro_function") + ("macro lambda list" "macro_lambda_list") + ("macro name" "macro_name") + ("macroexpand hook" "macroexpand_hook") + ("mapping" "mapping") + ("metaclass" "metaclass") + ("method" "method") + ("method combination" "method_combination") + ("method-defining form" "method-defining_form") + ("method-defining operator" "method-defining_operator") + ("minimal compilation" "minimal_compilation") + ("modified lambda list" "modified_lambda_list") + ("most recent" "most_recent") + ("multiple escape" "multiple_escape") + ("multiple values" "multiple_values") + ("name" "name") + ("named constant" "named_constant") + ("namespace" "namespace") + ("namestring" "namestring") + ("newline" "newline") + ("next method" "next_method") + ("nickname" "nickname") + ("nil" "nil") + ("non-atomic" "non-atomic") + ("non-constant variable" "non-constant_variable") + ("non-correctable" "non-correctable") + ("non-empty" "non-empty") + ("non-generic function" "non-generic_function") + ("non-graphic" "non-graphic") + ("non-list" "non-list") + ("non-local exit" "non-local_exit") + ("non-nil" "non-nil") + ("non-null lexical environment" "non-null_lexical_environment") + ("non-simple" "non-simple") + ("non-terminating" "non-terminating") + ("non-top-level form" "non-top-level_form") + ("normal return" "normal_return") + ("normalized" "normalized") + ("null" "null") + ("null lexical environment" "null_lexical_environment") + ("number" "number") + ("numeric" "numeric") + ("object" "object") + ("object-traversing" "object-traversing") + ("open" "open") + ("operator" "operator") + ("optimize quality" "optimize_quality") + ("optional parameter" "optional_parameter") + ("ordinary function" "ordinary_function") + ("ordinary lambda list" "ordinary_lambda_list") + ("otherwise inaccessible part" "otherwise_inaccessible_part") + ("output" "output") + ("package" "package") + ("package cell" "package_cell") + ("package designator" "package_designator") + ("package marker" "package_marker") + ("package prefix" "package_prefix") + ("package registry" "package_registry") + ("pairwise" "pairwise") + ("parallel" "parallel") + ("parameter" "parameter") + ("parameter specializer" "parameter_specializer") + ("parameter specializer name" "parameter_specializer_name") + ("pathname" "pathname") + ("pathname designator" "pathname_designator") + ("physical pathname" "physical_pathname") + ("place" "place") + ("plist" "plist") + ("portable" "portable") + ("potential copy" "potential_copy") + ("potential number" "potential_number") + ("pprint dispatch table" "pprint_dispatch_table") + ("predicate" "predicate") + ("present" "present") + ("pretty print" "pretty_print") + ("pretty printer" "pretty_printer") + ("pretty printing stream" "pretty_printing_stream") + ("primary method" "primary_method") + ("primary value" "primary_value") + ("principal" "principal") + ("print name" "print_name") + ("printer control variable" "printer_control_variable") + ("printer escaping" "printer_escaping") + ("printing" "printing") + ("process" "process") + ("processor" "processor") + ("proclaim" "proclaim") + ("proclamation" "proclamation") + ("prog tag" "prog_tag") + ("program" "program") + ("programmer" "programmer") + ("programmer code" "programmer_code") + ("proper list" "proper_list") + ("proper name" "proper_name") + ("proper sequence" "proper_sequence") + ("proper subtype" "proper_subtype") + ("property" "property") + ("property indicator" "property_indicator") + ("property list" "property_list") + ("property value" "property_value") + ("purports to conform" "purports_to_conform") + ("qualified method" "qualified_method") + ("qualifier" "qualifier") + ("query I/O" "query_iSLo") + ("quoted object" "quoted_object") + ("radix" "radix") + ("random state" "random_state") + ("rank" "rank") + ("ratio" "ratio") + ("ratio marker" "ratio_marker") + ("rational" "rational") + ("read" "read") + ("readably" "readably") + ("reader" "reader") + ("reader macro" "reader_macro") + ("reader macro function" "reader_macro_function") + ("readtable" "readtable") + ("readtable case" "readtable_case") + ("readtable designator" "readtable_designator") + ("recognizable subtype" "recognizable_subtype") + ("reference" "reference") + ("registered package" "registered_package") + ("relative" "relative") + ("repertoire" "repertoire") + ("report" "report") + ("report message" "report_message") + ("required parameter" "required_parameter") + ("rest list" "rest_list") + ("rest parameter" "rest_parameter") + ("restart" "restart") + ("restart designator" "restart_designator") + ("restart function" "restart_function") + ("return" "return") + ("return value" "return_value") + ("right-parenthesis" "right-parenthesis") + ("run time" "run_time") + ("run-time compiler" "run-time_compiler") + ("run-time definition" "run-time_definition") + ("run-time environment" "run-time_environment") + ("safe" "safe") + ("safe call" "safe_call") + ("same" "same") + ("satisfy the test" "satisfy_the_test") + ("scope" "scope") + ("script" "script") + ("secondary value" "secondary_value") + ("section" "section") + ("self-evaluating object" "self-evaluating_object") + ("semi-standard" "semi-standard") + ("semicolon" "semicolon") + ("sequence" "sequence") + ("sequence function" "sequence_function") + ("sequential" "sequential") + ("sequentially" "sequentially") + ("serious condition" "serious_condition") + ("session" "session") + ("set" "set") + ("setf expander" "setf_expander") + ("setf expansion" "setf_expansion") + ("setf function" "setf_function") + ("setf function name" "setf_function_name") + ("shadow" "shadow") + ("shadowing symbol" "shadowing_symbol") + ("shadowing symbols list" "shadowing_symbols_list") + ("shared slot" "shared_slot") + ("sharpsign" "sharpsign") + ("short float" "short_float") + ("sign" "sign") + ("signal" "signal") + ("signature" "signature") + ("similar" "similar") + ("similarity" "similarity") + ("simple" "simple") + ("simple array" "simple_array") + ("simple bit array" "simple_bit_array") + ("simple bit vector" "simple_bit_vector") + ("simple condition" "simple_condition") + ("simple general vector" "simple_general_vector") + ("simple string" "simple_string") + ("simple vector" "simple_vector") + ("single escape" "single_escape") + ("single float" "single_float") + ("single-quote" "single-quote") + ("singleton" "singleton") + ("situation" "situation") + ("slash" "slash") + ("slot" "slot") + ("slot specifier" "slot_specifier") + ("source code" "source_code") + ("source file" "source_file") + ("space" "space") + ("special form" "special_form") + ("special operator" "special_operator") + ("special variable" "special_variable") + ("specialize" "specialize") + ("specialized" "specialized") + ("specialized lambda list" "specialized_lambda_list") + ("spreadable argument list designator" "spreadable_argument_list_designator") + ("stack allocate" "stack_allocate") + ("stack-allocated" "stack-allocated") + ("standard character" "standard_character") + ("standard class" "standard_class") + ("standard generic function" "standard_generic_function") + ("standard input" "standard_input") + ("standard method combination" "standard_method_combination") + ("standard object" "standard_object") + ("standard output" "standard_output") + ("standard pprint dispatch table" "standard_pprint_dispatch_table") + ("standard readtable" "standard_readtable") + ("standard syntax" "standard_syntax") + ("standardized" "standardized") + ("startup environment" "startup_environment") + ("step" "step") + ("stream" "stream") + ("stream associated with a file" "stream_associated_with_a_file") + ("stream designator" "stream_designator") + ("stream element type" "stream_element_type") + ("stream variable" "stream_variable") + ("stream variable designator" "stream_variable_designator") + ("string" "string") + ("string designator" "string_designator") + ("string equal" "string_equal") + ("string stream" "string_stream") + ("structure" "structure") + ("structure class" "structure_class") + ("structure name" "structure_name") + ("style warning" "style_warning") + ("subclass" "subclass") + ("subexpression" "subexpression") + ("subform" "subform") + ("subrepertoire" "subrepertoire") + ("subtype" "subtype") + ("superclass" "superclass") + ("supertype" "supertype") + ("supplied-p parameter" "supplied-p_parameter") + ("symbol" "symbol") + ("symbol macro" "symbol_macro") + ("synonym stream" "synonym_stream") + ("synonym stream symbol" "synonym_stream_symbol") + ("syntax type" "syntax_type") + ("system class" "system_class") + ("system code" "system_code") + ("t" "t") + ("tag" "tag") + ("tail" "tail") + ("target" "target") + ("terminal I/O" "terminal_iSLo") + ("terminating" "terminating") + ("tertiary value" "tertiary_value") + ("throw" "throw") + ("tilde" "tilde") + ("time" "time") + ("time zone" "time_zone") + ("token" "token") + ("top level form" "top_level_form") + ("trace output" "trace_output") + ("tree" "tree") + ("tree structure" "tree_structure") + ("true" "true") + ("truename" "truename") + ("two-way stream" "two-way_stream") + ("type" "type") + ("type declaration" "type_declaration") + ("type equivalent" "type_equivalent") + ("type expand" "type_expand") + ("type specifier" "type_specifier") + ("unbound" "unbound") + ("unbound variable" "unbound_variable") + ("undefined function" "undefined_function") + ("unintern" "unintern") + ("uninterned" "uninterned") + ("universal time" "universal_time") + ("unqualified method" "unqualified_method") + ("unregistered package" "unregistered_package") + ("unsafe" "unsafe") + ("unsafe call" "unsafe_call") + ("upgrade" "upgrade") + ("upgraded array element type" "upgraded_array_element_type") + ("upgraded complex part type" "upgraded_complex_part_type") + ("uppercase" "uppercase") + ("use" "use") + ("use list" "use_list") + ("user" "user") + ("valid array dimension" "valid_array_dimension") + ("valid array index" "valid_array_index") + ("valid array row-major index" "valid_array_row-major_index") + ("valid fill pointer" "valid_fill_pointer") + ("valid logical pathname host" "valid_logical_pathname_host") + ("valid pathname device" "valid_pathname_device") + ("valid pathname directory" "valid_pathname_directory") + ("valid pathname host" "valid_pathname_host") + ("valid pathname name" "valid_pathname_name") + ("valid pathname type" "valid_pathname_type") + ("valid pathname version" "valid_pathname_version") + ("valid physical pathname host" "valid_physical_pathname_host") + ("valid sequence index" "valid_sequence_index") + ("value" "value") + ("value cell" "value_cell") + ("variable" "variable") + ("vector" "vector") + ("vertical-bar" "vertical-bar") + ("whitespace" "whitespace") + ("wild" "wild") + ("write" "write") + ("writer" "writer") + ("yield" "yield"))) + +(defun common-lisp-hyperspec-glossary-term (term) + "View the definition of TERM on the Common Lisp Hyperspec." + (interactive + (list + (completing-read "Look up glossary term: " + common-lisp-hyperspec--glossary-terms nil t))) + (browse-url (funcall common-lisp-hyperspec-glossary-function term))) + +(defun common-lisp-glossary-6.0 (term) + "Get a URL for a glossary term TERM." + (let ((anchor (gethash term common-lisp-hyperspec--glossary-terms))) + (if (not anchor) + (message "Unknown glossary term: %s" term) + (format "%sBody/26_glo_%s.htm#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char term))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + anchor)))) + +;; Tianxiang Xiong 20151229 +;; Is this function necessary? The link does created does not work. +(defun common-lisp-glossary-4.0 (string) + (format "%sBody/glo_%s.html#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + + +;;;; Issuex + +;; FIXME: the issuex stuff is not used +(defvar common-lisp-hyperspec-issuex-table nil + "The HyperSpec IssueX table file. If you copy the HyperSpec to your +local system, set this variable to the location of the Issue +cross-references table which is usually \"Map_IssX.txt\" or +\"Issue-Cross-Refs.text\".") + +(defvar common-lisp-hyperspec--issuex-symbols + (make-hash-table :test 'equal)) + +(mapc + (lambda (entry) + (puthash (car entry) (cadr entry) common-lisp-hyperspec--issuex-symbols)) + (if common-lisp-hyperspec-issuex-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-issuex-table) + '(("&environment-binding-order:first" "iss001.htm") + ("access-error-name" "iss002.htm") + ("adjust-array-displacement" "iss003.htm") + ("adjust-array-fill-pointer" "iss004.htm") + ("adjust-array-not-adjustable:implicit-copy" "iss005.htm") + ("allocate-instance:add" "iss006.htm") + ("allow-local-inline:inline-notinline" "iss007.htm") + ("allow-other-keys-nil:permit" "iss008.htm") + ("aref-1d" "iss009.htm") + ("argument-mismatch-error-again:consistent" "iss010.htm") + ("argument-mismatch-error-moon:fix" "iss011.htm") + ("argument-mismatch-error:more-clarifications" "iss012.htm") + ("arguments-underspecified:specify" "iss013.htm") + ("array-dimension-limit-implications:all-fixnum" "iss014.htm") + ("array-type-element-type-semantics:unify-upgrading" "iss015.htm") + ("assert-error-type:error" "iss016.htm") + ("assoc-rassoc-if-key" "iss017.htm") + ("assoc-rassoc-if-key:yes" "iss018.htm") + ("boa-aux-initialization:error-on-read" "iss019.htm") + ("break-on-warnings-obsolete:remove" "iss020.htm") + ("broadcast-stream-return-values:clarify-minimally" "iss021.htm") + ("butlast-negative:should-signal" "iss022.htm") + ("change-class-initargs:permit" "iss023.htm") + ("char-name-case:x3j13-mar-91" "iss024.htm") + ("character-loose-ends:fix" "iss025.htm") + ("character-proposal:2" "iss026.htm") + ("character-proposal:2-1-1" "iss027.htm") + ("character-proposal:2-1-2" "iss028.htm") + ("character-proposal:2-2-1" "iss029.htm") + ("character-proposal:2-3-1" "iss030.htm") + ("character-proposal:2-3-2" "iss031.htm") + ("character-proposal:2-3-3" "iss032.htm") + ("character-proposal:2-3-4" "iss033.htm") + ("character-proposal:2-3-5" "iss034.htm") + ("character-proposal:2-3-6" "iss035.htm") + ("character-proposal:2-4-1" "iss036.htm") + ("character-proposal:2-4-2" "iss037.htm") + ("character-proposal:2-4-3" "iss038.htm") + ("character-proposal:2-5-2" "iss039.htm") + ("character-proposal:2-5-6" "iss040.htm") + ("character-proposal:2-5-7" "iss041.htm") + ("character-proposal:2-6-1" "iss042.htm") + ("character-proposal:2-6-2" "iss043.htm") + ("character-proposal:2-6-3" "iss044.htm") + ("character-proposal:2-6-5" "iss045.htm") + ("character-vs-char:less-inconsistent-short" "iss046.htm") + ("class-object-specializer:affirm" "iss047.htm") + ("clos-conditions-again:allow-subset" "iss048.htm") + ("clos-conditions:integrate" "iss049.htm") + ("clos-error-checking-order:no-applicable-method-first" "iss050.htm") + ("clos-macro-compilation:minimal" "iss051.htm") + ("close-constructed-stream:argument-stream-only" "iss052.htm") + ("closed-stream-operations:allow-inquiry" "iss053.htm") + ("coercing-setf-name-to-function:all-function-names" "iss054.htm") + ("colon-number" "iss055.htm") + ("common-features:specify" "iss056.htm") + ("common-type:remove" "iss057.htm") + ("compile-argument-problems-again:fix" "iss058.htm") + ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm") + ("compile-file-output-file-defaults:input-file" "iss060.htm") + ("compile-file-package" "iss061.htm") + ("compile-file-pathname-arguments:make-consistent" "iss062.htm") + ("compile-file-symbol-handling:new-require-consistency" "iss063.htm") + ("compiled-function-requirements:tighten" "iss064.htm") + ("compiler-diagnostics:use-handler" "iss065.htm") + ("compiler-let-confusion:eliminate" "iss066.htm") + ("compiler-verbosity:like-load" "iss067.htm") + ("compiler-warning-stream" "iss068.htm") + ("complex-atan-branch-cut:tweak" "iss069.htm") + ("complex-atanh-bogus-formula:tweak-more" "iss070.htm") + ("complex-rational-result:extend" "iss071.htm") + ("compute-applicable-methods:generic" "iss072.htm") + ("concatenate-sequence:signal-error" "iss073.htm") + ("condition-accessors-setfable:no" "iss074.htm") + ("condition-restarts:buggy" "iss075.htm") + ("condition-restarts:permit-association" "iss076.htm") + ("condition-slots:hidden" "iss077.htm") + ("cons-type-specifier:add" "iss078.htm") + ("constant-circular-compilation:yes" "iss079.htm") + ("constant-collapsing:generalize" "iss080.htm") + ("constant-compilable-types:specify" "iss081.htm") + ("constant-function-compilation:no" "iss082.htm") + ("constant-modification:disallow" "iss083.htm") + ("constantp-definition:intentional" "iss084.htm") + ("constantp-environment:add-arg" "iss085.htm") + ("contagion-on-numerical-comparisons:transitive" "iss086.htm") + ("copy-symbol-copy-plist:copy-list" "iss087.htm") + ("copy-symbol-print-name:equal" "iss088.htm") + ("data-io:add-support" "iss089.htm") + ("data-types-hierarchy-underspecified" "iss090.htm") + ("debugger-hook-vs-break:clarify" "iss091.htm") + ("declaration-scope:no-hoisting" "iss092.htm") + ("declare-array-type-element-references:restrictive" "iss093.htm") + ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm") + ("declare-macros:flush" "iss095.htm") + ("declare-type-free:lexical" "iss096.htm") + ("decls-and-doc" "iss097.htm") + ("decode-universal-time-daylight:like-encode" "iss098.htm") + ("defconstant-special:no" "iss099.htm") + ("defgeneric-declare:allow-multiple" "iss100.htm") + ("define-compiler-macro:x3j13-nov89" "iss101.htm") + ("define-condition-syntax:\ +incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") + ("define-method-combination-behavior:clarify" "iss103.htm") + ("defining-macros-non-top-level:allow" "iss104.htm") + ("defmacro-block-scope:excludes-bindings" "iss105.htm") + ("defmacro-lambda-list:tighten-description" "iss106.htm") + ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm") + ("defpackage:addition" "iss108.htm") + ("defstruct-constructor-key-mixture:allow-key" "iss109.htm") + ("defstruct-constructor-options:explicit" "iss110.htm") + ("defstruct-constructor-slot-variables:not-bound" "iss111.htm") + ("defstruct-copier-argument-type:restrict" "iss112.htm") + ("defstruct-copier:argument-type" "iss113.htm") + ("defstruct-default-value-evaluation:iff-needed" "iss114.htm") + ("defstruct-include-deftype:explicitly-undefined" "iss115.htm") + ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm") + ("defstruct-print-function-inheritance:yes" "iss117.htm") + ("defstruct-redefinition:error" "iss118.htm") + ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm") + ("defstruct-slots-constraints-number" "iss120.htm") + ("deftype-destructuring:yes" "iss121.htm") + ("deftype-key:allow" "iss122.htm") + ("defvar-documentation:unevaluated" "iss123.htm") + ("defvar-init-time:not-delayed" "iss124.htm") + ("defvar-initialization:conservative" "iss125.htm") + ("deprecation-position:limited" "iss126.htm") + ("describe-interactive:no" "iss127.htm") + ("describe-underspecified:describe-object" "iss128.htm") + ("destructive-operations:specify" "iss129.htm") + ("destructuring-bind:new-macro" "iss130.htm") + ("disassemble-side-effect:do-not-install" "iss131.htm") + ("displaced-array-predicate:add" "iss132.htm") + ("do-symbols-block-scope:entire-form" "iss133.htm") + ("do-symbols-duplicates" "iss134.htm") + ("documentation-function-bugs:fix" "iss135.htm") + ("documentation-function-tangled:require-argument" "iss136.htm") + ("dotimes-ignore:x3j13-mar91" "iss137.htm") + ("dotted-list-arguments:clarify" "iss138.htm") + ("dotted-macro-forms:allow" "iss139.htm") + ("dribble-technique" "iss140.htm") + ("dynamic-extent-function:extend" "iss141.htm") + ("dynamic-extent:new-declaration" "iss142.htm") + ("equal-structure:maybe-status-quo" "iss143.htm") + ("error-terminology-warning:might" "iss144.htm") + ("eval-other:self-evaluate" "iss145.htm") + ("eval-top-level:load-like-compile-file" "iss146.htm") + ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm") + ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm") + ("evalhook-step-confusion:fix" "iss149.htm") + ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm") + ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm") + ("exit-extent:minimal" "iss152.htm") + ("expt-ratio:p.211" "iss153.htm") + ("extensions-position:documentation" "iss154.htm") + ("external-format-for-every-file-connection:minimum" "iss155.htm") + ("extra-return-values:no" "iss156.htm") + ("file-open-error:signal-file-error" "iss157.htm") + ("fixnum-non-portable:tighten-definition" "iss158.htm") + ("flet-declarations" "iss159.htm") + ("flet-declarations:allow" "iss160.htm") + ("flet-implicit-block:yes" "iss161.htm") + ("float-underflow:add-variables" "iss162.htm") + ("floating-point-condition-names:x3j13-nov-89" "iss163.htm") + ("format-atsign-colon" "iss164.htm") + ("format-colon-uparrow-scope" "iss165.htm") + ("format-comma-interval" "iss166.htm") + ("format-e-exponent-sign:force-sign" "iss167.htm") + ("format-op-c" "iss168.htm") + ("format-pretty-print:yes" "iss169.htm") + ("format-string-arguments:specify" "iss170.htm") + ("function-call-evaluation-order:more-unspecified" "iss171.htm") + ("function-composition:jan89-x3j13" "iss172.htm") + ("function-definition:jan89-x3j13" "iss173.htm") + ("function-name:large" "iss174.htm") + ("function-type" "iss175.htm") + ("function-type-argument-type-semantics:restrictive" "iss176.htm") + ("function-type-key-name:specify-keyword" "iss177.htm") + ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm") + ("function-type:x3j13-march-88" "iss179.htm") + ("generalize-pretty-printer:unify" "iss180.htm") + ("generic-flet-poorly-designed:delete" "iss181.htm") + ("gensym-name-stickiness:like-teflon" "iss182.htm") + ("gentemp-bad-idea:deprecate" "iss183.htm") + ("get-macro-character-readtable:nil-standard" "iss184.htm") + ("get-setf-method-environment:add-arg" "iss185.htm") + ("hash-table-access:x3j13-mar-89" "iss186.htm") + ("hash-table-key-modification:specify" "iss187.htm") + ("hash-table-package-generators:add-with-wrapper" "iss188.htm") + ("hash-table-rehash-size-integer" "iss189.htm") + ("hash-table-size:intended-entries" "iss190.htm") + ("hash-table-tests:add-equalp" "iss191.htm") + ("ieee-atan-branch-cut:split" "iss192.htm") + ("ignore-use-terminology:value-only" "iss193.htm") + ("import-setf-symbol-package" "iss194.htm") + ("in-package-functionality:mar89-x3j13" "iss195.htm") + ("in-syntax:minimal" "iss196.htm") + ("initialization-function-keyword-checking" "iss197.htm") + ("iso-compatibility:add-substrate" "iss198.htm") + ("jun90-trivial-issues:11" "iss199.htm") + ("jun90-trivial-issues:14" "iss200.htm") + ("jun90-trivial-issues:24" "iss201.htm") + ("jun90-trivial-issues:25" "iss202.htm") + ("jun90-trivial-issues:27" "iss203.htm") + ("jun90-trivial-issues:3" "iss204.htm") + ("jun90-trivial-issues:4" "iss205.htm") + ("jun90-trivial-issues:5" "iss206.htm") + ("jun90-trivial-issues:9" "iss207.htm") + ("keyword-argument-name-package:any" "iss208.htm") + ("last-n" "iss209.htm") + ("lcm-no-arguments:1" "iss210.htm") + ("lexical-construct-global-definition:undefined" "iss211.htm") + ("lisp-package-name:common-lisp" "iss212.htm") + ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm") + ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm") + ("load-objects:make-load-form" "iss215.htm") + ("load-time-eval:r**2-new-special-form" "iss216.htm") + ("load-time-eval:r**3-new-special-form" "iss217.htm") + ("load-truename:new-pathname-variables" "iss218.htm") + ("locally-top-level:special-form" "iss219.htm") + ("loop-and-discrepancy:no-reiteration" "iss220.htm") + ("loop-for-as-on-typo:fix-typo" "iss221.htm") + ("loop-initform-environment:partial-interleaving-vague" "iss222.htm") + ("loop-miscellaneous-repairs:fix" "iss223.htm") + ("loop-named-block-nil:override" "iss224.htm") + ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm") + ("loop-syntax-overhaul:repair" "iss226.htm") + ("macro-as-function:disallow" "iss227.htm") + ("macro-declarations:make-explicit" "iss228.htm") + ("macro-environment-extent:dynamic" "iss229.htm") + ("macro-function-environment" "iss230.htm") + ("macro-function-environment:yes" "iss231.htm") + ("macro-subforms-top-level-p:add-constraints" "iss232.htm") + ("macroexpand-hook-default:explicitly-vague" "iss233.htm") + ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm") + ("macroexpand-return-value:true" "iss235.htm") + ("make-load-form-confusion:rewrite" "iss236.htm") + ("make-load-form-saving-slots:no-initforms" "iss237.htm") + ("make-package-use-default:implementation-dependent" "iss238.htm") + ("map-into:add-function" "iss239.htm") + ("mapping-destructive-interaction:explicitly-vague" "iss240.htm") + ("metaclass-of-system-class:unspecified" "iss241.htm") + ("method-combination-arguments:clarify" "iss242.htm") + ("method-initform:forbid-call-next-method" "iss243.htm") + ("muffle-warning-condition-argument" "iss244.htm") + ("multiple-value-setq-order:like-setf-of-values" "iss245.htm") + ("multiple-values-limit-on-variables:undefined" "iss246.htm") + ("nintersection-destruction" "iss247.htm") + ("nintersection-destruction:revert" "iss248.htm") + ("not-and-null-return-value:x3j13-mar-93" "iss249.htm") + ("nth-value:add" "iss250.htm") + ("optimize-debug-info:new-quality" "iss251.htm") + ("package-clutter:reduce" "iss252.htm") + ("package-deletion:new-function" "iss253.htm") + ("package-function-consistency:more-permissive" "iss254.htm") + ("parse-error-stream:split-types" "iss255.htm") + ("pathname-component-case:keyword-argument" "iss256.htm") + ("pathname-component-value:specify" "iss257.htm") + ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm") + ("pathname-logical:add" "iss259.htm") + ("pathname-print-read:sharpsign-p" "iss260.htm") + ("pathname-stream" "iss261.htm") + ("pathname-stream:files-or-synonym" "iss262.htm") + ("pathname-subdirectory-list:new-representation" "iss263.htm") + ("pathname-symbol" "iss264.htm") + ("pathname-syntax-error-time:explicitly-vague" "iss265.htm") + ("pathname-unspecific-component:new-token" "iss266.htm") + ("pathname-wild:new-functions" "iss267.htm") + ("peek-char-read-char-echo:first-read-char" "iss268.htm") + ("plist-duplicates:allow" "iss269.htm") + ("pretty-print-interface" "iss270.htm") + ("princ-readably:x3j13-dec-91" "iss271.htm") + ("print-case-behavior:clarify" "iss272.htm") + ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" + "iss273.htm") + ("print-circle-shared:respect-print-circle" "iss274.htm") + ("print-circle-structure:user-functions-work" "iss275.htm") + ("print-readably-behavior:clarify" "iss276.htm") + ("printer-whitespace:just-one-space" "iss277.htm") + ("proclaim-etc-in-compile-file:new-macro" "iss278.htm") + ("push-evaluation-order:first-item" "iss279.htm") + ("push-evaluation-order:item-first" "iss280.htm") + ("pushnew-store-required:unspecified" "iss281.htm") + ("quote-semantics:no-copying" "iss282.htm") + ("range-of-count-keyword:nil-or-integer" "iss283.htm") + ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm") + ("read-and-write-bytes:new-functions" "iss285.htm") + ("read-case-sensitivity:readtable-keywords" "iss286.htm") + ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm") + ("read-suppress-confusing:generalize" "iss288.htm") + ("reader-error:new-type" "iss289.htm") + ("real-number-type:x3j13-mar-89" "iss290.htm") + ("recursive-deftype:explicitly-vague" "iss291.htm") + ("reduce-argument-extraction" "iss292.htm") + ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm") + ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm") + ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm") + ("require-pathname-defaults:eliminate" "iss296.htm") + ("rest-list-allocation:may-share" "iss297.htm") + ("result-lists-shared:specify" "iss298.htm") + ("return-values-unspecified:specify" "iss299.htm") + ("room-default-argument:new-value" "iss300.htm") + ("self-modifying-code:forbid" "iss301.htm") + ("sequence-type-length:must-match" "iss302.htm") + ("setf-apply-expansion:ignore-expander" "iss303.htm") + ("setf-find-class:allow-nil" "iss304.htm") + ("setf-functions-again:minimal-changes" "iss305.htm") + ("setf-get-default:evaluated-but-ignored" "iss306.htm") + ("setf-macro-expansion:last" "iss307.htm") + ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm") + ("setf-multiple-store-variables:allow" "iss309.htm") + ("setf-of-apply:only-aref-and-friends" "iss310.htm") + ("setf-of-values:add" "iss311.htm") + ("setf-sub-methods:delayed-access-stores" "iss312.htm") + ("shadow-already-present" "iss313.htm") + ("shadow-already-present:works" "iss314.htm") + ("sharp-comma-confusion:remove" "iss315.htm") + ("sharp-o-foobar:consequences-undefined" "iss316.htm") + ("sharp-star-delimiter:normal-delimiter" "iss317.htm") + ("sharpsign-plus-minus-package:keyword" "iss318.htm") + ("slot-missing-values:specify" "iss319.htm") + ("slot-value-metaclasses:less-minimal" "iss320.htm") + ("special-form-p-misnomer:rename" "iss321.htm") + ("special-type-shadowing:clarify" "iss322.htm") + ("standard-input-initial-binding:defined-contracts" "iss323.htm") + ("standard-repertoire-gratuitous:rename" "iss324.htm") + ("step-environment:current" "iss325.htm") + ("step-minimal:permit-progn" "iss326.htm") + ("stream-access:add-types-accessors" "iss327.htm") + ("stream-capabilities:interactive-stream-p" "iss328.htm") + ("string-coercion:make-consistent" "iss329.htm") + ("string-output-stream-bashing:undefined" "iss330.htm") + ("structure-read-print-syntax:keywords" "iss331.htm") + ("subseq-out-of-bounds" "iss332.htm") + ("subseq-out-of-bounds:is-an-error" "iss333.htm") + ("subsetting-position:none" "iss334.htm") + ("subtypep-environment:add-arg" "iss335.htm") + ("subtypep-too-vague:clarify-more" "iss336.htm") + ("sxhash-definition:similar-for-sxhash" "iss337.htm") + ("symbol-macrolet-declare:allow" "iss338.htm") + ("symbol-macrolet-semantics:special-form" "iss339.htm") + ("symbol-macrolet-type-declaration:no" "iss340.htm") + ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm") + ("symbol-print-escape-behavior:clarify" "iss342.htm") + ("syntactic-environment-access:retracted-mar91" "iss343.htm") + ("tagbody-tag-expansion:no" "iss344.htm") + ("tailp-nil:t" "iss345.htm") + ("test-not-if-not:flush-all" "iss346.htm") + ("the-ambiguity:for-declaration" "iss347.htm") + ("the-values:return-number-received" "iss348.htm") + ("time-zone-non-integer:allow" "iss349.htm") + ("type-declaration-abbreviation:allow-all" "iss350.htm") + ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm") + ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm") + ("type-of-underconstrained:add-constraints" "iss353.htm") + ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm") + ("undefined-variables-and-functions:compromise" "iss355.htm") + ("uninitialized-elements:consequences-undefined" "iss356.htm") + ("unread-char-after-peek-char:dont-allow" "iss357.htm") + ("unsolicited-messages:not-to-system-user-streams" "iss358.htm") + ("variable-list-asymmetry:symmetrize" "iss359.htm") + ("with-added-methods:delete" "iss360.htm") + ("with-compilation-unit:new-macro" "iss361.htm") + ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm") + ("with-open-file-setq:explicitly-vague" "iss363.htm") + ("with-open-file-stream-extent:dynamic-extent" "iss364.htm") + ("with-output-to-string-append-style:vector-push-extend" "iss365.htm") + ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm")))) + +(defun common-lisp-issuex (issue-name) + (let ((entry (gethash (downcase issue-name) + common-lisp-hyperspec--issuex-symbols))) + (concat common-lisp-hyperspec-root "Issues/" entry))) + +(defun common-lisp-special-operator (name) + (format "%sBody/s_%s.htm" common-lisp-hyperspec-root name)) + +;;; Added the following just to provide a common entry point according +;;; to the various 'hyperspec' implementations. +;;; +;;; 19990820 Marco Antoniotti + +(defalias 'hyperspec-lookup 'common-lisp-hyperspec) +(defalias 'hyperspec-lookup-reader-macro + 'common-lisp-hyperspec-lookup-reader-macro) +(defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format) + +(provide 'hyperspec) + +;;; hyperspec.el ends here diff --git a/elpa/slime-20200319.1939/lib/hyperspec.elc b/elpa/slime-20200319.1939/lib/hyperspec.elc new file mode 100644 index 00000000..e3e93e3a Binary files /dev/null and b/elpa/slime-20200319.1939/lib/hyperspec.elc differ diff --git a/elpa/slime-20200319.1939/metering.lisp b/elpa/slime-20200319.1939/metering.lisp new file mode 100644 index 00000000..b87d2806 --- /dev/null +++ b/elpa/slime-20200319.1939/metering.lisp @@ -0,0 +1,1213 @@ +;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLIME. +;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. +;;; 07-Aug-12 heller Break lines at 80 columns +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (swank-monitor:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (swank-monitor:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function SWANK-MONITOR::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "SWANK-MONITOR" (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "SWANK-MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +#+openmcl +(progn + (deftype time-type () 'unsigned-byte) + (deftype consing-type () 'unsigned-byte)) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific ~ +Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) + (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA ~ +Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA ~ +Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable swank-monitor::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + + diff --git a/elpa/slime-20200319.1939/nregex.lisp b/elpa/slime-20200319.1939/nregex.lisp new file mode 100644 index 00000000..43586efe --- /dev/null +++ b/elpa/slime-20200319.1939/nregex.lisp @@ -0,0 +1,523 @@ +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then taken in turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. +;;;; +;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz) +;;;; to get working with Corman Lisp 1.42, add package statement and export +;;;; relevant functions. +;;;; + +(in-package :cl-user) + +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + +;;;; CND - 6/3/2001 +(defpackage slime-nregex + (:use #:common-lisp) + (:export + #:regex + #:regex-compile + )) + +;;;; CND - 6/3/2001 +(in-package :slime-nregex) + +;;; +;;; First we create a copy of macros to help debug the beast +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *regex-debug* nil) ; Set to nil for no debugging code +) + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message ,@args))) + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +(defun regex (expression string) + "Usage: (regex &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (result (char char-string 0)) + (used-length 1)) + (cond ((eql first #\n) + (setf result #\NewLine)) + ((eql first #\c) + (setf result #\Return)) + ((eql first #\t) + (setf result #\Tab)) + ((eql first #\d) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\D) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\w) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\W) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\b) + (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\B) + (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\s) + (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\S) + (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((and (>= (char-code first) (char-code #\0)) + (<= (char-code first) (char-code #\9))) + (if (and (> (length char-string) 2) + (and (>= (char-code (char char-string 1)) (char-code #\0)) + (<= (char-code (char char-string 1)) (char-code #\9)) + (>= (char-code (char char-string 2)) (char-code #\0)) + (<= (char-code (char char-string 2)) (char-code #\9)))) + ;; + ;; It is a single character specified in octal + ;; + (progn + (setf result (do ((x 0 (1+ x)) + (return 0)) + ((= x 2) return) + (setf return (+ (* return 8) + (- (char-code (char char-string x)) + (char-code #\0)))))) + (setf used-length 3)) + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) + (cadr (aref *regex-groups* ,group))))) + (if (< length (+ index (length nstring))) + (return-from compare nil)) + (if (not (string= string nstring + :start1 index + :end1 (+ index (length nstring)))) + (return-from compare nil) + (incf index (length nstring))))))))) + (t + (setf result first))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +;;; +;;; Now for the main regex compiler routine. +;;; +(defun regex-compile (source &key (anchored nil)) + "Usage: (regex-compile [ :anchored (t/nil) ]) + This function take a regular expression (supplied as source) and + compiles this into a lambda list that a string argument can then + be applied to. It is also possible to compile this lambda list + for better performance or to save it as a named function for later + use" + (info "Now entering regex-compile with \"~A\"~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression '()) ; holder for expressions + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + (fast-first nil)) ; holder for quick unanchored scan + ;; + ;; If the expression was an empty string then it alway + ;; matches (so lets leave early) + ;; + (if (= (length source) 0) + (return-from regex-compile + '(lambda (&rest args) + (declare (ignore args)) + t))) + ;; + ;; If the first character is a caret then set the anchored + ;; flags and remove if from the expression string. + ;; + (cond ((eql (char source 0) #\^) + (setf source (subseq source 1)) + (setf anchored t))) + ;; + ;; If the first sequence is .* then also set the anchored flags. + ;; (This is purely for optimization, it will work without this). + ;; + (if (>= (length source) 2) + (if (string= source ".*" :start1 0 :end1 2) + (setf anchored t))) + ;; + ;; Also, If this is not an anchored search and the first character is + ;; a literal, then do a quick scan to see if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + (if (and (not anchored) + (not (position (char source 0) *regex-special-chars*)) + (not (and (> (length source) 1) + (position (char source 1) *regex-special-chars*)))) + (setf fast-first `((if (not (dotimes (i length nil) + (if (eql (char string i) + ,(char source 0)) + (return (setf start i))))) + (return-from final-return nil))))) + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (add-exp '((setf (aref *regex-groups* 0) + (list index nil)))) + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex (length source))) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + ((#\.) + ;; + ;; Generate code for a single wild character + ;; + (add-exp '((if (>= index length) + (return-from compare nil) + (incf index))))) + ((#\$) + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- (length source))) + (add-exp '((if (not (= index length)) + (return-from compare nil)))) + (add-exp '((if (not (and (< index length) + (eql (char string index) #\$))) + (return-from compare nil) + (incf index)))))) + ((#\*) + (add-exp '(ASTRISK))) + + ((#\+) + (add-exp '(PLUS))) + + ((#\?) + (add-exp '(QUESTION))) + + ((#\() + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp `((setf (aref *regex-groups* ,(1- group)) + (list index nil)))) + (add-exp `(,group))) + ((#\)) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) + index))) + (add-exp `(,(- group))))) + ((#\[) + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #\^)) + (bitstring (make-array 256 :element-type 'bit + :initial-element + (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (do ((x (1+ eindex) (1+ x))) + ((eql (char source x) #\]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (cond ((and (eql (char source (1+ x)) #\-) + (not (eql (char source (+ x 2)) #\]))) + (if (>= (char-code (char source x)) + (char-code (char source (+ 2 x)))) + (error "Invalid range \"~A-~A\". Ranges must be in acending order" + (char source x) (char source (+ 2 x)))) + (do ((j (char-code (char source x)) (1+ j))) + ((> j (char-code (char source (+ 2 x)))) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (t + (cond ((not (eql (char source x) #\])) + (let ((char (char source x))) + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (if (eql (char source x) #\\ ) + (let ((length)) + (multiple-value-setq (char length) + (regex-quoted (subseq source x) invert)) + (incf x length))) + (info "Setting bit for char ~A code ~A~%" char (char-code char)) + (if (not (vectorp char)) + (setf (sbit bitstring (char-code (char source x))) set-char) + (bit-ior bitstring char t)))))))) + (add-exp `((let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + ((#\\ ) + ;; + ;; Intreprete the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (let ((length) + (value)) + (multiple-value-setq (value length) + (regex-quoted (subseq source (1+ eindex)) nil)) + (cond ((listp value) + (add-exp value)) + ((characterp value) + (add-exp `((if (not (and (< index length) + (eql (char string index) + ,value))) + (return-from compare nil) + (incf index))))) + ((vectorp value) + (add-exp `((let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- (length source) eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A index ~A to lit~%" litchar + litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + (if (= (length lit) 1) + (add-exp `((if (not (and (< index length) + (eql (char string index) ,current))) + (return-from compare nil) + (incf index)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an astrisk or a plus or a question mark. If so then we must not use this + ;; character in the big literal. + (progn + (if (or (eql term #\*) + (eql term #\+) + (eql term #\?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (add-exp `((if (< length (+ index ,(length lit))) + (return-from compare nil)) + (if (not (string= string ,lit :start1 index + :end1 (+ index ,(length lit)))) + (return-from compare nil) + (incf index ,(length lit))))))) + (incf eindex (1- (length lit)))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp '((setf (cadr (aref *regex-groups* 0)) + index))) + (add-exp '((return-from final-return t))) + ;; +;;; (print expression) + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replace by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTRISK I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that does a return t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + (setf result (copy-tree nil)) + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nexting of expressions when + ;; and astrisk has been encountered. + (setf expression (reverse expression)) + (do ((elt 0 (1+ elt))) + ((>= elt (length expression))) + (let ((piece (nth elt expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTRISK below handle the rest. + ;; + (cond ((eql piece 'PLUS) + (cond ((listp (nth (1+ elt) expression)) + (setf result (append (list (nth (1+ elt) expression)) + result))) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t + (error "GROUP repeat hasn't been implemented yet~%"))))) + (cond ((listp piece) ;Just append the list + (setf result (append (list piece) result))) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp (nth (1+ elt) expression)) + (setf result + (append `((progn (block compare + ,(nth (1+ elt) + expression)) + t)) + result)) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (error "Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTRISK) ; Do the wild thing! + (eql piece 'PLUS)) + (cond ((listp (nth (1+ elt) expression)) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do () + (nil) + ,(nth (1+ elt) expression))) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + ,@result)))))) + (incf elt)) + (t + ;; + ;; This is a subgroup repeated so I must build + ;; the loop using several values. + ;; + )) + ) + (t t)))) ; Just ignore everything else. + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (if anchored + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + ,@result))))) + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (let ((length end)) + ,@fast-first + (do ((marker start (1+ marker))) + ((> marker end) nil) + (let ((index marker)) + (if (block compare + ,@result) + (return t))))))))))) + +;; (provide 'nregex) diff --git a/elpa/slime-20200319.1939/packages.lisp b/elpa/slime-20200319.1939/packages.lisp new file mode 100644 index 00000000..b4b159fb --- /dev/null +++ b/elpa/slime-20200319.1939/packages.lisp @@ -0,0 +1,202 @@ +(defpackage swank/backend + (:use cl) + (:nicknames swank-backend) + (:export *debug-swank-backend* + *log-output* + sldb-condition + compiler-condition + original-condition + message + source-context + condition + severity + with-compilation-hooks + make-location + location + location-p + location-buffer + location-position + location-hints + position-p + position-pos + print-output-to-string + quit-lisp + references + unbound-slot-filler + declaration-arglist + type-specifier-arglist + with-struct + when-let + defimplementation + converting-errors-to-error-location + make-error-location + deinit-log-output + ;; interrupt macro for the backend + *pending-slime-interrupts* + check-slime-interrupts + *interrupt-queued-handler* + ;; inspector related symbols + emacs-inspect + label-value-line + label-value-line* + boolean-to-feature-expression + with-symbol + choose-symbol + ;; package helper for backend + import-to-swank-mop + import-swank-mop-symbols + ;; + default-directory + set-default-directory + frame-source-location + restart-frame + gdb-initial-commands + sldb-break-on-return + buffer-first-change + + profiled-functions + unprofile-all + profile-report + profile-reset + profile-package + + with-collected-macro-forms + auto-flush-loop + *auto-flush-interval*)) + +(defpackage swank/rpc + (:use :cl) + (:export + read-message + read-packet + swank-reader-error + swank-reader-error.packet + swank-reader-error.cause + write-message)) + +(defpackage swank/match + (:use cl) + (:export match)) + +;; FIXME: rename to sawnk/mop +(defpackage swank-mop + (:use) + (:export + ;; classes + standard-generic-function + standard-slot-definition + standard-method + standard-class + eql-specializer + eql-specializer-object + ;; standard-class readers + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-name + class-precedence-list + class-prototype + class-slots + specializer-direct-methods + ;; generic function readers + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-methods + generic-function-method-class + generic-function-method-combination + generic-function-name + ;; method readers + method-generic-function + method-function + method-lambda-list + method-specializers + method-qualifiers + ;; slot readers + slot-definition-allocation + slot-definition-documentation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-boundp-using-class + slot-value-using-class + slot-makunbound-using-class + ;; generic function protocol + compute-applicable-methods-using-classes + finalize-inheritance)) + +(defpackage swank + (:use cl swank/backend swank/match swank/rpc) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:stop-server + #:restart-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:invoke-slime-debugger + #:swank-debugger-hook + #:emacs-inspect + ;;#:inspect-slot-for-emacs + ;; These are user-configurable variables: + #:*communication-style* + #:*dont-close* + #:*fasl-pathname-function* + #:*log-events* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*configure-emacs-indentation* + #:*readtable-alist* + #:*globally-redirect-io* + #:*global-debugger* + #:*sldb-quit-restart* + #:*backtrace-printer-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*swank-pprint-bindings* + #:*record-repl-results* + #:*inspector-verbose* + ;; This is SETFable. + #:debug-on-swank-error + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location + #:gdb-initial-commands + #:restart-frame + #:sldb-step + #:sldb-break + #:sldb-break-on-return + #:profiled-functions + #:profile-report + #:profile-reset + #:unprofile-all + #:profile-package + #:default-directory + #:set-default-directory + #:quit-lisp + #:eval-for-emacs + #:eval-in-emacs + #:ed-rpc + #:ed-rpc-no-wait + #:y-or-n-p-in-emacs + #:*find-definitions-right-trim* + #:*find-definitions-left-trim* + #:*after-toggle-trace-hook* + #:unreadable-result + #:unreadable-result-p + #:unreadable-result-string + #:parse-string + #:from-string + #:to-string + #:*swank-debugger-condition* + #:run-hook-with-args-until-success + #:make-output-function-for-target + #:make-output-stream-for-target)) diff --git a/elpa/slime-20200319.1939/sbcl-pprint-patch.lisp b/elpa/slime-20200319.1939/sbcl-pprint-patch.lisp new file mode 100644 index 00000000..dfdc0bb8 --- /dev/null +++ b/elpa/slime-20200319.1939/sbcl-pprint-patch.lisp @@ -0,0 +1,332 @@ +;; Pretty printer patch for SBCL, which adds the "annotations" feature +;; required for sending presentations through pretty-printing streams. +;; +;; The section marked "Changed functions" and the DEFSTRUCT +;; PRETTY-STREAM are based on SBCL's pprint.lisp. +;; +;; Public domain. + +(in-package "SB!PRETTY") + +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + + +(defstruct (pretty-stream (:include sb!kernel:ansi-stream + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) + (:constructor make-pretty-stream (target)) + (:copier nil)) + ;; Where the output is going to finally go. + (target (missing-arg) :type stream) + ;; Line length we should format to. Cached here so we don't have to keep + ;; extracting it from the target stream. + (line-length (or *print-right-margin* + (sb!impl::line-length target) + default-line-length) + :type column) + ;; A simple string holding all the text that has been output but not yet + ;; printed. + (buffer (make-string initial-buffer-size) :type (simple-array character (*))) + ;; The index into BUFFER where more text should be put. + (buffer-fill-pointer 0 :type index) + ;; Whenever we output stuff from the buffer, we shift the remaining noise + ;; over. This makes it difficult to keep references to locations in + ;; the buffer. Therefore, we have to keep track of the total amount of + ;; stuff that has been shifted out of the buffer. + (buffer-offset 0 :type posn) + ;; The column the first character in the buffer will appear in. Normally + ;; zero, but if we end up with a very long line with no breaks in it we + ;; might have to output part of it. Then this will no longer be zero. + (buffer-start-column (or (sb!impl::charpos target) 0) :type column) + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. + (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) + ;; Stack of logical blocks in effect at the buffer start. + (blocks (list (make-logical-block)) :type list) + ;; Buffer holding the per-line prefix active at the buffer start. + ;; Indentation is included in this. The length of this is stored + ;; in the logical block stack. + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Buffer holding the total remaining suffix active at the buffer start. + ;; The characters are right-justified in the buffer to make it easier + ;; to output the buffer. The length is stored in the logical block + ;; stack. + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, + ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) + ;; cons. Adding things to the queue is basically (setf (cdr head) (list + ;; new)) and removing them is basically (pop tail) [except that care must + ;; be taken to handle the empty queue case correctly.] + (queue-tail nil :type list) + (queue-head nil :type list) + ;; Block-start queue entries in effect at the queue head. + (pending-blocks nil :type list) + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list)) + + +(defmacro enqueue (stream type &rest args) + (let ((constructor (intern (concatenate 'string + "MAKE-" + (symbol-name type)) + "SB-PRETTY"))) + (once-only ((stream stream) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + ,stream) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head ,stream))) + `(progn + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail ,stream) ,op)) + (setf (pretty-stream-queue-head ,stream) ,op) + ,entry)))) + +;;; +;;; New helper functions +;;; + +(defun enqueue-annotation (stream handler record) + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons) + nil)) + +(defun re-enqueue-annotations (stream end) + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (when (> annotation-index start) + (write-string buffer target :start start + :end annotation-index) + (setf start annotation-index)) + (invoke-annotation stream annotation nil))) + (when (> end start) + (write-string buffer target :start start :end end)))) + +(defun flush-annotations (stream end truncatep) + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + +;;; +;;; Changed functions +;;; + +(defun maybe-output (stream force-newlines-p) + (declare (type pretty-stream stream)) + (let ((tail (pretty-stream-queue-tail stream)) + (output-anything nil)) + (loop + (unless tail + (setf (pretty-stream-queue-head stream) nil) + (return)) + (let ((next (pop tail))) + (etypecase next + (newline + (when (ecase (newline-kind next) + ((:literal :mandatory :linear) t) + (:miser (misering-p stream)) + (:fill + (or (misering-p stream) + (> (pretty-stream-line-number stream) + (logical-block-section-start-line + (first (pretty-stream-blocks stream)))) + (ecase (fits-on-line-p stream + (newline-section-end next) + force-newlines-p) + ((t) nil) + ((nil) t) + (:dont-know + (return)))))) + (setf output-anything t) + (output-line stream next))) + (indentation + (unless (misering-p stream) + (set-indentation stream + (+ (ecase (indentation-kind next) + (:block + (logical-block-start-column + (car (pretty-stream-blocks stream)))) + (:current + (posn-column + (indentation-posn next) + stream))) + (indentation-amount next))))) + (block-start + (ecase (fits-on-line-p stream (block-start-section-end next) + force-newlines-p) + ((t) + ;; Just nuke the whole logical block and make it look like one + ;; nice long literal. (But don't nuke annotations.) + (let ((end (block-start-block-end next))) + (expand-tabs stream end) + (re-enqueue-annotations stream end) + (setf tail (cdr (member end tail))))) + ((nil) + (really-start-logical-block + stream + (posn-column (block-start-posn next) stream) + (block-start-prefix next) + (block-start-suffix next))) + (:dont-know + (return)))) + (block-end + (really-end-logical-block stream)) + (tab + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) + (setf (pretty-stream-queue-tail stream) tail)) + output-anything)) + +(defun output-line (stream until) + (declare (type pretty-stream stream) + (type newline until)) + (let* ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (kind (newline-kind until)) + (literal-p (eq kind :literal)) + (amount-to-consume (posn-index (newline-posn until) stream)) + (amount-to-print + (if literal-p + amount-to-consume + (let ((last-non-blank + (position #\space buffer :end amount-to-consume + :from-end t :test #'char/=))) + (if last-non-blank + (1+ last-non-blank) + 0))))) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) + (let ((line-number (pretty-stream-line-number stream))) + (incf line-number) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) + (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) + (let ((suffix-length (logical-block-suffix-length + (car (pretty-stream-blocks stream))))) + (unless (zerop suffix-length) + (let* ((suffix (pretty-stream-suffix stream)) + (len (length suffix))) + (write-string suffix target + :start (- len suffix-length) + :end len)))) + (throw 'line-limit-abbreviation-happened t)) + (setf (pretty-stream-line-number stream) line-number) + (write-char #\newline target) + (setf (pretty-stream-buffer-start-column stream) 0) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (block (first (pretty-stream-blocks stream))) + (prefix-len + (if literal-p + (logical-block-per-line-prefix-end block) + (logical-block-prefix-length block))) + (shift (- amount-to-consume prefix-len)) + (new-fill-ptr (- fill-ptr shift)) + (new-buffer buffer) + (buffer-length (length buffer))) + (when (> new-fill-ptr buffer-length) + (setf new-buffer + (make-string (max (* buffer-length 2) + (+ buffer-length + (floor (* (- new-fill-ptr buffer-length) + 5) + 4))))) + (setf (pretty-stream-buffer stream) new-buffer)) + (replace new-buffer buffer + :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) + (replace new-buffer (pretty-stream-prefix stream) + :end1 prefix-len) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) shift) + (unless literal-p + (setf (logical-block-section-column block) prefix-len) + (setf (logical-block-section-start-line block) line-number)))))) + +(defun output-partial-line (stream) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (tail (pretty-stream-queue-tail stream)) + (count + (if tail + (posn-index (queued-op-posn (car tail)) stream) + fill-ptr)) + (new-fill-ptr (- fill-ptr count)) + (buffer (pretty-stream-buffer stream))) + (when (zerop count) + (error "Output-partial-line called when nothing can be output.")) + (output-buffer-with-annotations stream count) + (incf (pretty-stream-buffer-start-column stream) count) + (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) count))) + +(defun force-pretty-output (stream) + (maybe-output stream nil) + (expand-tabs stream nil) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) + \ No newline at end of file diff --git a/elpa/slime-20200319.1939/slime-autoloads.el b/elpa/slime-20200319.1939/slime-autoloads.el new file mode 100644 index 00000000..45a00f85 --- /dev/null +++ b/elpa/slime-20200319.1939/slime-autoloads.el @@ -0,0 +1,69 @@ +;;; slime-autoloads.el --- autoload definitions for SLIME -*- no-byte-compile: t -*- + +;; Copyright (C) 2007 Helmut Eller + +;; This file is protected by the GNU GPLv2 (or later), as distributed +;; with GNU Emacs. + +;;; Commentary: + +;; This code defines the necessary autoloads, so that we don't need to +;; load everything from .emacs. +;; +;; JT@14/01/09: FIXME: This file should be auto-generated with autoload cookies. + +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + +(autoload 'slime "slime" + "Start a Lisp subprocess and connect to its Swank server." t) + +(autoload 'slime-mode "slime" + "SLIME: The Superior Lisp Interaction (Minor) Mode for Emacs." t) + +(autoload 'slime-connect "slime" + "Connect to a running Swank server." t) + +(autoload 'slime-selector "slime" + "Select a new by type, indicated by a single character." t) + +(autoload 'hyperspec-lookup "lib/hyperspec" nil t) + +(autoload 'slime-lisp-mode-hook "slime") + +(autoload 'slime-scheme-mode-hook "slime") + +(defvar slime-contribs nil + "A list of contrib packages to load with SLIME.") + +(autoload 'slime-setup "slime" + "Setup some SLIME contribs.") + +(define-obsolete-variable-alias 'slime-setup-contribs + 'slime-contribs "2.3.2") + +(add-hook 'lisp-mode-hook 'slime-lisp-mode-hook) + +(provide 'slime-autoloads) + +;;; slime-autoloads.el ends here + +;;;### (autoloads nil "slime" "slime.el" (0 0 0 0)) +;;; Generated autoloads from slime.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "slime" '("sldb-" "slime" "defslimefun" "def-slime-selector-method" "define-sl" "??" "?q" "?i" "?v" "?l" "?d" "?e" "?c" "?n" "?p" "?t" "make-slime-" "inferior-lisp-program"))) + +;;;*** + +;;;### (autoloads nil nil ("slime-pkg.el") (0 0 0 0)) + +;;;*** + +;;;### (autoloads nil "slime-tests" "slime-tests.el" (0 0 0 0)) +;;; Generated autoloads from slime-tests.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "slime-tests" '("symbol-at-point." "sexp-at-point.1" "sbcl-world-lock" "report-condition-with-circular-list" "read" "traditional-recipe" "def-slime-test" "dis" "find-definition" "flow-control" "inspector" "indentation" "inter" "end-of-file" "loop-interrupt-" "locally-bound-debugger-hook" "break" "macroexpand" "utf-8-source" "unwind-to-previous-sldb-level" "arglist" "async-eval-debugging" "comp" "narrowing"))) + +;;;*** diff --git a/elpa/slime-20200319.1939/slime-pkg.el b/elpa/slime-20200319.1939/slime-pkg.el new file mode 100644 index 00000000..9c3fd780 --- /dev/null +++ b/elpa/slime-20200319.1939/slime-pkg.el @@ -0,0 +1,9 @@ +(define-package "slime" "20200319.1939" "Superior Lisp Interaction Mode for Emacs" + '((cl-lib "0.5") + (macrostep "0.9")) + :keywords + '("languages" "lisp" "slime") + :url "https://github.com/slime/slime") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/slime-20200319.1939/slime-tests.el b/elpa/slime-20200319.1939/slime-tests.el new file mode 100644 index 00000000..87f81f13 --- /dev/null +++ b/elpa/slime-20200319.1939/slime-tests.el @@ -0,0 +1,1459 @@ +;;; slime-tests.el --- Automated tests for slime.el +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2013 +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program 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 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + + +;;;; Tests +(require 'slime) +(require 'ert nil t) +(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 +(require 'cl-lib) +(require 'bytecomp) ; byte-compile-current-file +(eval-when-compile + (require 'cl)) ; lexical-let + +(defun slime-shuffle-list (list) + (let* ((len (length list)) + (taken (make-vector len nil)) + (result (make-vector len nil))) + (dolist (e list) + (while (let ((i (random len))) + (cond ((aref taken i)) + (t (aset taken i t) + (aset result i e) + nil))))) + (append result '()))) + +(defun slime-batch-test (&optional test-name randomize) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (interactive) + (let ((ert-debug-on-error nil) + (timeout 30) + (slime-background-message-function #'ignore)) + (slime) + ;; Block until we are up and running. + (lexical-let (timed-out) + (run-with-timer timeout nil + (lambda () (setq timed-out t))) + (while (not (slime-connected-p)) + (sit-for 1) + (when timed-out + (when noninteractive + (kill-emacs 252))))) + (slime-sync-to-top-level 5) + (let* ((selector (if randomize + `(member ,@(slime-shuffle-list + (ert-select-tests (or test-name t) t))) + (or test-name t))) + (ert-fun (if noninteractive + 'ert-run-tests-batch + 'ert))) + (let ((stats (funcall ert-fun selector))) + (if noninteractive + (kill-emacs (ert-stats-completed-unexpected stats))))))) + +(defun slime-skip-test (message) + ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' + (if (fboundp 'ert-skip) + (ert-skip message) + (message (concat "SKIPPING: " message)) + (ert-pass))) + +(defun slime-tests--undefine-all () + (dolist (test (ert-select-tests t t)) + (let* ((sym (ert-test-name test))) + (cl-assert (eq (get sym 'ert--test) test)) + (cl-remprop sym 'ert--test)))) + +(slime-tests--undefine-all) + +(eval-and-compile + (defun slime-tests-auto-tags () + (append '(slime) + (let ((file-name (or load-file-name + byte-compile-current-file))) + (if (and file-name + (string-match "contrib/test/slime-\\(.*\\)\.elc?$" + file-name)) + (list 'contrib (intern (match-string 1 file-name))) + '(core))))) + + (defmacro define-slime-ert-test (name &rest args) + "Like `ert-deftest', but set tags automatically. +Also don't error if `ert.el' is missing." + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + (let* ((docstring (and (stringp (second args)) + (second args))) + (args (if docstring + (cddr args) + (cdr args))) + (tags (slime-tests-auto-tags))) + `(ert-deftest ,name () ,(or docstring "No docstring for this test.") + :tags ',tags + ,@args)))) + + (defun slime-test-ert-test-for (name input i doc body fails-for style fname) + `(define-slime-ert-test + ,(intern (format "%s-%d" name i)) () + ,(format "For input %s, %s" (truncate-string-to-width + (format "%s" input) + 15 nil nil 'ellipsis) + (replace-regexp-in-string "^.??\\(\\w+\\)" + (lambda (s) (downcase s)) + doc + t)) + ,@(if fails-for + `(:expected-result '(satisfies + (lambda (result) + (ert-test-result-type-p + result + (if (member + (slime-lisp-implementation-name) + ',fails-for) + :failed + :passed)))))) + + ,@(when style + `((let ((style (slime-communication-style))) + (when (not (member style ',style)) + (slime-skip-test (format "test not applicable for style %s" + style)))))) + (apply #',fname ',input)))) + +(defmacro def-slime-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. +OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `slime-check' to test +conditions (assertions)." + (declare (debug (&define name sexp sexp sexp &rest def-form))) + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + `(progn + ,@(cl-destructuring-bind (name &rest options) + (if (listp name) name (list name)) + (let ((fname (intern (format "slime-test-%s" name)))) + (cons `(defun ,fname ,args + (slime-sync-to-top-level 0.3) + ,@body + (slime-sync-to-top-level 0.3)) + (cl-loop for input in (eval inputs) + for i from 1 + with fails-for = (cdr (assoc :fails-for options)) + with style = (cdr (assoc :style options)) + collect (slime-test-ert-test-for name + input + i + doc + body + fails-for + style + fname)))))))) + +(put 'def-slime-test 'lisp-indent-function 4) + +(defmacro slime-check (check &rest body) + (declare (indent defun)) + `(unless (progn ,@body) + (ert-fail ,(cl-etypecase check + (cons `(concat "Ooops, " ,(cons 'format check))) + (string `(concat "Check failed: " ,check)) + (symbol `(concat "Check failed: " ,(symbol-name check))))))) + + +;;;;; Test case definitions +(defun slime-check-top-level () ;(&optional _test-name) + (accept-process-output nil 0.001) + (slime-check "At the top level (no debugging or pending RPCs)" + (slime-at-top-level-p))) + +(defun slime-at-top-level-p () + (and (not (sldb-get-default-buffer)) + (null (slime-rex-continuations)))) + +(defun slime-wait-condition (name predicate timeout) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (let ((now (current-time))) + (message "waiting for condition: %s [%s.%06d]" name + (format-time-string "%H:%M:%S" now) (third now))) + (cond ((time-less-p end (current-time)) + (error "Timeout waiting for condition: %S" name)) + (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (accept-process-output nil 0.1)))))) + +(defun slime-sync-to-top-level (timeout) + (slime-wait-condition "top-level" #'slime-at-top-level-p timeout)) + +;; XXX: unused function +(defun slime-check-sldb-level (expected) + (let ((sldb-level (let ((sldb (sldb-get-default-buffer))) + (if sldb + (with-current-buffer sldb + sldb-level))))) + (slime-check ("SLDB level (%S) is %S" expected sldb-level) + (equal expected sldb-level)))) + +(defun slime-test-expect (_name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (if test + (should (funcall test expected actual)) + (should (equal expected actual)))) + +(defun sldb-level () + (let ((sldb (sldb-get-default-buffer))) + (if sldb + (with-current-buffer sldb + sldb-level)))) + +(defun slime-sldb-level= (level) + (equal level (sldb-level))) + +(eval-when-compile + (defvar slime-test-symbols + '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") + ("|asdf||foo||bar|") + ("\\#") + ("\\(setf\\ car\\)")))) + +(defun slime-check-symbol-at-point (prefix symbol suffix) + ;; We test that `slime-symbol-at-point' works at every + ;; character of the symbol name. + (with-temp-buffer + (lisp-mode) + (insert prefix) + (let ((start (point))) + (insert symbol suffix) + (dotimes (i (length symbol)) + (goto-char (+ start i)) + (slime-test-expect (format "Check `%s' (at %d)..." + (buffer-string) (point)) + symbol + (slime-symbol-at-point) + #'equal))))) + + + +(def-slime-test symbol-at-point.2 (sym) + "fancy symbol-name _not_ at BOB/EOB" + slime-test-symbols + (slime-check-symbol-at-point "(foo " sym " bar)")) + +(def-slime-test symbol-at-point.3 (sym) + "fancy symbol-name with leading ," + (remove-if (lambda (s) (eq (aref (car s) 0) ?@)) slime-test-symbols) + (slime-check-symbol-at-point "," sym "")) + +(def-slime-test symbol-at-point.4 (sym) + "fancy symbol-name with leading ,@" + slime-test-symbols + (slime-check-symbol-at-point ",@" sym "")) + +(def-slime-test symbol-at-point.5 (sym) + "fancy symbol-name with leading `" + slime-test-symbols + (slime-check-symbol-at-point "`" sym "")) + +(def-slime-test symbol-at-point.6 (sym) + "fancy symbol-name wrapped in ()" + slime-test-symbols + (slime-check-symbol-at-point "(" sym ")")) + +(def-slime-test symbol-at-point.7 (sym) + "fancy symbol-name wrapped in #< {DEADBEEF}>" + slime-test-symbols + (slime-check-symbol-at-point "#<" sym " {DEADBEEF}>")) + +;;(def-slime-test symbol-at-point.8 (sym) +;; "fancy symbol-name wrapped in #<>" +;; slime-test-symbols +;; (slime-check-symbol-at-point "#<" sym ">")) + +(def-slime-test symbol-at-point.9 (sym) + "fancy symbol-name wrapped in #| ... |#" + slime-test-symbols + (slime-check-symbol-at-point "#|\n" sym "\n|#")) + +(def-slime-test symbol-at-point.10 (sym) + "fancy symbol-name after #| )))(( |# (1)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|\n" sym "")) + +(def-slime-test symbol-at-point.11 (sym) + "fancy symbol-name after #| )))(( |# (2)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|" sym "")) + +(def-slime-test symbol-at-point.12 (sym) + "fancy symbol-name wrapped in \"...\"" + slime-test-symbols + (slime-check-symbol-at-point "\"\n" sym "\"\n")) + +(def-slime-test symbol-at-point.13 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"\n" sym "")) + +(def-slime-test symbol-at-point.14 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"" sym "")) + +(def-slime-test symbol-at-point.15 (sym) + "symbol-at-point after #." + slime-test-symbols + (slime-check-symbol-at-point "#." sym "")) + +(def-slime-test symbol-at-point.16 (sym) + "symbol-at-point after #+" + slime-test-symbols + (slime-check-symbol-at-point "#+" sym "")) + + +(def-slime-test sexp-at-point.1 (string) + "symbol-at-point after #'" + '(("foo") + ("#:foo") + ("#'foo") + ("#'(lambda (x) x)") + ("()")) + (with-temp-buffer + (lisp-mode) + (insert string) + (goto-char (point-min)) + (slime-test-expect (format "Check sexp `%s' (at %d)..." + (buffer-string) (point)) + string + (slime-sexp-at-point) + #'equal))) + +(def-slime-test narrowing () + "Check that narrowing is properly sustained." + '() + (slime-check-top-level) + (let ((random-buffer-name (symbol-name (cl-gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (slime-check "Checking that newly created buffer is not narrowed." + (not (slime-buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (slime-check "Checking that narrowing succeeded." + (slime-buffer-narrowed-p)) + + (slime-with-popup-buffer (random-buffer-name) + (slime-check ("Checking that we're in Slime's temp buffer `%s'" + random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name))) + (with-current-buffer random-buffer-name + ;; Notice that we cannot quit the buffer within the extent + ;; of slime-with-output-to-temp-buffer. + (quit-window t)) + (slime-check ("Checking that we've got back from `%s'" + random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained \ +after quitting Slime's temp buffer." + (slime-buffer-narrowed-p)) + + (let ((slime-buffer-package "SWANK") + (symbol '*buffer-package*)) + (slime-edit-definition (symbol-name symbol)) + (slime-check ("Checking that we've got M-. into swank.lisp. %S" symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "swank.lisp")) + (slime-pop-find-definition-stack) + (slime-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after M-," + (slime-buffer-narrowed-p))) + )) + (slime-check-top-level)) + +(defun slime-test--display-region-eval-arg (line window-height) + (cl-etypecase line + (number line) + (cons (slime-dcase line + ((+h line) + (+ (slime-test--display-region-eval-arg line window-height) + window-height)) + ((-h line) + (- (slime-test--display-region-eval-arg line window-height) + window-height)))))) + +(defun slime-test--display-region-line-to-position (line window-height) + (let ((line (slime-test--display-region-eval-arg line window-height))) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (line-beginning-position)))) + +(def-slime-test display-region + (start end pos window-start expected-window-start expected-point) + "Test `slime-display-region'." + ;; numbers are actually lines numbers + '(;; region visible, point in region + (2 4 3 1 1 3) + ;; region visible, point visible but ouside region + (2 4 5 1 1 5) + ;; end not visible, point at start + (2 (+h 2) 2 1 2 2) + ;; start not visible, point at start + ((+h 2) (+h 500) (+h 2) 1 (+h 2) (+h 2)) + ;; start not visible, point after end + ((+h 2) (+h 500) (+h 6) 1 (+h 2) (+h 6)) + ;; end - start should be visible, point after end + ((+h 2) (+h 7) (+h 10) 1 (-h (+h 7)) (+h 6)) + ;; region is window-height + 1 and ends with newline + ((+h -2) (+h (+h -3)) (+h -2) 1 (+h -3) (+h -2)) + (2 (+h 1) 3 1 1 3) + (2 (+h 0) 3 1 1 3) + (2 (+h -1) 3 1 1 3) + ;; start and end are the beginning + (1 1 1 1 1 1) + ;; + (1 (+h 1) (+h 22) (+h 20) 1 (+h 0)) + ) + (when noninteractive + (slime-skip-test "Can't test slime-display-region in batch mode")) + (with-temp-buffer + (dotimes (i 1000) + (insert (format "%09d\n" i))) + (let* ((win (display-buffer (current-buffer) t)) + (wh (window-text-height win))) + (cl-macrolet ((l2p (l) + `(slime-test--display-region-line-to-position ,l wh))) + (select-window win) + (set-window-start win (l2p window-start)) + (redisplay) + (goto-char (l2p pos)) + (cl-assert (= (l2p window-start) (window-start win))) + (cl-assert (= (point) (l2p pos))) + (slime--display-region (l2p start) (l2p end)) + (redisplay) + (cl-assert (= (l2p expected-window-start) (window-start))) + (cl-assert (= (l2p expected-point) (point))) + )))) + +(def-slime-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in swank.lisp." + '(("start-server" "SWANK" "(defun start-server ") + ("swank::start-server" "CL-USER" "(defun start-server ") + ("swank:start-server" "CL-USER" "(defun start-server ") + ("swank::connection" "CL-USER" "(defstruct (connection") + ("swank::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") + ) + (switch-to-buffer "*scratch*") ; not buffer of definition + (slime-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (slime-buffer-package buffer-package)) + (slime-edit-definition name) + ;; Postconditions + (slime-check ("Definition of `%S' is in swank.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp")) + (slime-check ("Looking at '%s'." snippet) (looking-at snippet)) + (slime-pop-find-definition-stack) + (slime-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (slime-check-top-level)) + +(def-slime-test (find-definition.2 (:fails-for "allegro" "lispworks")) + (buffer-content buffer-package snippet) + "Check that we're able to find definitions even when +confronted with nasty #.-fu." + '(("#.(prog1 nil (defvar *foobar* 42)) + + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SWANK" + "[ \t]*(defun .foo. " + ) + ("#.(prog1 nil (defvar *foobar* 42)) + + ;; some comment + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SWANK" + "[ \t]*(defun .foo. " + ) + ("(in-package swank) + (eval-when (:compile-toplevel) (defparameter *bar* 456)) + (eval-when (:load-toplevel :execute) (makunbound '*bar*)) + (defun bar () #.*bar*) + (defun .foo. () 123)" + "SWANK" + "[ \t]*(defun .foo. () 123)")) + (let ((slime-buffer-package buffer-package)) + (with-temp-buffer + (insert buffer-content) + (slime-check-top-level) + (slime-eval + `(swank:compile-string-for-emacs + ,buffer-content + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil)) + (let ((bufname (buffer-name))) + (slime-edit-definition ".foo.") + (slime-check ("Definition of `.foo.' is in buffer `%s'." bufname) + (string= (buffer-name) bufname)) + (slime-check "Definition now at point." (looking-at snippet)))))) + +(def-slime-test (find-definition.3 + (:fails-for "abcl" "allegro" "clisp" "lispworks" "sbcl" + "ecl")) + (name source regexp) + "Extra tests for defstruct." + '(("swank::foo-struct" + "(progn + (defun foo-fun ()) + (defstruct (foo-struct (:constructor nil) (:predicate nil))) +)" + "(defstruct (foo-struct")) + (switch-to-buffer "*scratch*") + (with-temp-buffer + (insert source) + (let ((slime-buffer-package "SWANK")) + (slime-eval + `(swank:compile-string-for-emacs + ,source + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil))) + (let ((temp-buffer (current-buffer))) + (with-current-buffer "*scratch*" + (slime-edit-definition name) + (slime-check ("Definition of %S is in buffer `%s'." + name temp-buffer) + (eq (current-buffer) temp-buffer)) + (slime-check "Definition now at point." (looking-at regexp))) + ))) + +(def-slime-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" ("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" + "cl:compiler-macro" "cl:compiler-macro-function")) + ("cl:foobar" ()) + ("swank::compile-file" ("swank::compile-file" + "swank::compile-file-for-emacs" + "swank::compile-file-if-needed" + "swank::compile-file-output" + "swank::compile-file-pathname")) + ("cl:m-v-l" ())) + (let ((completions (slime-simple-completions prefix))) + (slime-test-expect "Completion set" expected-completions completions))) + +(def-slime-test read-from-minibuffer + (input-keys expected-result) + "Test `slime-read-from-minibuffer' with INPUT-KEYS as events." + '(("( r e v e TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" + "(reverse '(1 2 3))") + ("( c l : c o n TAB s t a n t l TAB SPC 4 2 ) RET" + "(cl:constantly 42)")) + (when noninteractive + (slime-skip-test "Can't use unread-command-events in batch mode")) + (let ((keys (eval `(kbd ,input-keys)))) ; kbd is a macro in Emacs 23 + (setq unread-command-events (listify-key-sequence keys))) + (let ((actual-result (slime-read-from-minibuffer "Test: "))) + (accept-process-output) ; run idle timers + (slime-test-expect "Completed string" expected-result actual-result))) + +(def-slime-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("swank::operator-arglist" "(swank::operator-arglist name package)") + ("swank::compute-backtrace" "(swank::compute-backtrace start end)") + ("swank::emacs-connected" "(swank::emacs-connected)") + ("swank::compile-string-for-emacs" + "(swank::compile-string-for-emacs \ +string buffer position filename policy)") + ("swank::connection.socket-io" + "(swank::connection.socket-io \ +\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") + ("cl:class-name" + "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) + (let ((arglist (slime-eval `(swank:operator-arglist ,function-name + "swank")))) + (slime-test-expect "Argument list is as expected" + expected-arglist (and arglist (downcase arglist)) + (lambda (pattern arglist) + (and arglist (string-match pattern arglist)))))) + +(defun slime-test--compile-defun (program subform) + (slime-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert program) + (let ((font-lock-verbose nil)) + (setq slime-buffer-package ":swank") + (slime-compile-string (buffer-string) 1) + (setq slime-buffer-package ":cl-user") + (slime-sync-to-top-level 5) + (goto-char (point-max)) + (slime-previous-note) + (slime-check error-location-correct + (equal (read (current-buffer)) subform)))) + (slime-check-top-level)) + +(def-slime-test (compile-defun (:fails-for "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + \"\\\" bla bla \\\"\" + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #.*log-events* + (cl-user::bar))" + (cl-user::bar)) + ("#.'(defun x () (/ 1 0)) + (defun foo () + (cl-user::bar)) + + " + (cl-user::bar))) + (slime-test--compile-defun program subform)) + +;; This test ideally would be collapsed into the previous +;; compile-defun test, but only 1 case fails for ccl--and that's here +(def-slime-test (compile-defun-with-reader-conditionals + (:fails-for "allegro" "lispworks" "clisp" "ccl")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) + (slime-test--compile-defun program subform)) + +;; SBCL used to pass this one but since they changed the +;; backquote/unquote reader it fails. +(def-slime-test (compile-defun-with-backquote + (:fails-for "allegro" "lispworks" "clisp" "sbcl")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 + ,(cl-user::bar))))" + (cl-user::bar))) + (slime-test--compile-defun program subform)) + +(def-slime-test (compile-file (:fails-for "allegro" "clisp")) + (string) + "Insert STRING in a file, and compile it." + `((,(pp-to-string '(defun foo () nil)))) + (let ((filename "/tmp/slime-tmp-file.lisp")) + (with-temp-file filename + (insert string)) + (let ((cell (cons nil nil))) + (slime-eval-async + `(swank:compile-file-for-emacs ,filename nil) + (slime-rcurry (lambda (result cell) + (setcar cell t) + (setcdr cell result)) + cell)) + (slime-wait-condition "Compilation finished" (lambda () (car cell)) + 0.5) + (let ((result (cdr cell))) + (slime-check "Compilation successfull" + (eq (slime-compilation-result.successp result) t)))))) + +(def-slime-test utf-8-source + (input output) + "Source code containing utf-8 should work" + (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") + ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) + ;; 'utf-8) + (string (decode-coding-string bytes 'utf-8-unix))) + (assert (equal bytes (encode-coding-string string 'utf-8-unix))) + (list (concat "(defun cl-user::foo () \"" string "\")") + string))) + (slime-eval `(cl:eval (cl:read-from-string ,input))) + (slime-test-expect "Eval result correct" + output (slime-eval '(cl-user::foo))) + (let ((cell (cons nil nil))) + (let ((hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell))) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (progn + (slime-compile-string input 0) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (slime-test-expect "Compile-string result correct" + output (slime-eval '(cl-user::foo)))) + (remove-hook 'slime-compilation-finished-hook hook)) + (let ((filename "/tmp/slime-tmp-file.lisp")) + (setcar cell nil) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (with-temp-buffer + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte t)) + (setq buffer-file-coding-system 'utf-8-unix) + (setq buffer-file-name filename) + (insert ";; -*- coding: utf-8-unix -*- \n") + (insert input) + (let ((coding-system-for-write 'utf-8-unix)) + (write-region nil nil filename nil t)) + (let ((slime-load-failed-fasl 'always)) + (slime-compile-and-load-file) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (slime-test-expect "Compile-file result correct" + output (slime-eval '(cl-user::foo)))) + (remove-hook 'slime-compilation-finished-hook hook) + (ignore-errors (delete-file filename))))))) + +(def-slime-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (lexical-let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (when (> sldb-level debug-hook-max-depth) + (setq debug-hook-max-depth sldb-level) + (if (= sldb-level depth) + ;; We're at maximum recursion - time to unwind + (sldb-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (slime-eval-async '(error)))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async '(error)) + (slime-sync-to-top-level 5) + (slime-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)))))) + +(def-slime-test unwind-to-previous-sldb-level (level2 level1) + "Test recursive debugging and returning to lower SLDB levels." + '((2 1) (4 2)) + (slime-check-top-level) + (lexical-let ((level2 level2) + (level1 level1) + (state 'enter) + (max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (setq max-depth (max sldb-level max-depth)) + (ecase state + (enter + (cond ((= sldb-level level2) + (setq state 'leave) + (sldb-invoke-restart (sldb-first-abort-restart))) + (t + (slime-eval-async `(cl:aref cl:nil ,sldb-level))))) + (leave + (cond ((= sldb-level level1) + (setq state 'ok) + (sldb-quit)) + (t + (sldb-invoke-restart (sldb-first-abort-restart)) + )))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async `(cl:aref cl:nil 0)) + (slime-sync-to-top-level 15) + (slime-check-top-level) + (slime-check ("Maximum depth reached (%S) is %S." max-depth level2) + (= max-depth level2)) + (slime-check ("Final state reached.") + (eq state 'ok)))))) + +(defun sldb-first-abort-restart () + (let ((case-fold-search t)) + (cl-position-if (lambda (x) (string-match "abort" (car x))) + sldb-restarts))) + +(def-slime-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (accept-process-output nil 1) + (slime-check "In eval state." (slime-busy-p)) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (slime-wait-condition "running" #'slime-busy-p 5) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "running" (lambda () + (and (slime-busy-p) + (not (sldb-get-default-buffer)))) 5) + (slime-interrupt) + (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + "(progn\ + (cerror \"foo\" \"restart\")\ + (cerror \"bar\" \"restart\")\ + (+ 1 2))") + (while (not done) (accept-process-output)) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-slime-test report-condition-with-circular-list + (format-control format-argument) + "Test conditions involving circular lists." + '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") + ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") + ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ + (setf (cdr x) x))")) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" + format-control format-argument)) + (while (not done) (accept-process-output)) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-slime-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) + (accept-process-output nil 1) + (slime-check-top-level) + (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) + (cl:finish-output))) + (lambda (_) ) + "CL-USER") + (sleep-for 1) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test (interrupt-encode-message (:style :sigio)) + () + "Test interrupt processing during swank::encode-message" + '(()) + (slime-eval-async '(cl:loop :for i :from 0 + :do (swank::background-message "foo ~d" i))) + (sleep-for 1) + (slime-eval-async '(cl:/ 1 0)) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test inspector + (exp) + "Test basic inspector workingness." + '(((let ((h (make-hash-table))) + (loop for i below 10 do (setf (gethash i h) i)) + h)) + ((make-array 10)) + ((make-list 10)) + ('cons) + (#'cons)) + (slime-inspect (prin1-to-string exp)) + (cl-assert (not (slime-inspector-visible-p))) + (slime-wait-condition "Inspector visible" #'slime-inspector-visible-p 5) + (with-current-buffer (window-buffer (selected-window)) + (slime-inspector-quit)) + (slime-wait-condition "Inspector closed" + (lambda () (not (slime-inspector-visible-p))) + 5) + (slime-sync-to-top-level 1)) + +(defun slime-buffer-visible-p (name) + (let ((buffer (window-buffer (selected-window)))) + (string-match name (buffer-name buffer)))) + +(defun slime-inspector-visible-p () + (slime-buffer-visible-p (slime-buffer-name :inspector))) + +(defun slime-execute-as-command (name) + "Execute `name' as if it was done by the user through the +Command Loop. Similiar to `call-interactively' but also pushes on +the buffer's undo-list." + (undo-boundary) + (call-interactively name)) + +(def-slime-test macroexpand + (macro-defs bufcontent expansion1 search-str expansion2) + "foo" + '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" + "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") + "(yxcv :A :B :C)" + "(list :yxcv (qwertz :a :b :c))" + "(qwertz" + "(list :yxcv (list :qwertz '(:a :b :c)))")) + (slime-check-top-level) + (setq slime-buffer-package ":swank") + (with-temp-buffer + (lisp-mode) + (dolist (def macro-defs) + (slime-compile-string def 0) + (slime-sync-to-top-level 5)) + (insert bufcontent) + (goto-char (point-min)) + (slime-execute-as-command 'slime-macroexpand-1) + (slime-wait-condition "Macroexpansion buffer visible" + (lambda () + (slime-buffer-visible-p + (slime-buffer-name :macroexpansion))) + 5) + (with-current-buffer (get-buffer (slime-buffer-name :macroexpansion)) + (slime-test-expect "Initial macroexpansion is correct" + expansion1 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) + (search-forward search-str) + (backward-up-list) + (slime-execute-as-command 'slime-macroexpand-1-inplace) + (slime-sync-to-top-level 3) + (slime-test-expect "In-place macroexpansion is correct" + expansion2 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) + (slime-execute-as-command 'slime-macroexpand-undo) + (slime-test-expect "Expansion after undo is correct" + expansion1 + (downcase (buffer-string)) + #'slime-test-macroexpansion=))) + (setq slime-buffer-package ":cl-user")) + +(defun slime-test-macroexpansion= (string1 string2) + (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) + (string2 (replace-regexp-in-string " *\n *" " " string2))) + (equal string1 string2))) + +(def-slime-test indentation (buffer-content point-markers) + "Check indentation update to work correctly." + '((" +\(in-package :swank) + +\(defmacro with-lolipop (&body body) + `(progn ,@body)) + +\(defmacro lolipop (&body body) + `(progn ,@body)) + +\(with-lolipop + 1 + 2 + 42) + +\(lolipop + 1 + 2 + 23) +" + ("23" "42"))) + (with-temp-buffer + (lisp-mode) + (slime-lisp-mode-hook) + (insert buffer-content) + (slime-compile-region (point-min) (point-max)) + (slime-sync-to-top-level 3) + (slime-update-indentation) + (slime-sync-to-top-level 3) + (dolist (marker point-markers) + (search-backward marker) + (beginning-of-defun) + (indent-sexp)) + (slime-test-expect "Correct buffer content" + buffer-content + (substring-no-properties (buffer-string))))) + +(def-slime-test break + (times exp) + "Test whether BREAK invokes SLDB." + (let ((exp1 '(break))) + `((1 ,exp1) (2 ,exp1) (3 ,exp1))) + (accept-process-output nil 0.2) + (slime-check-top-level) + (slime-eval-async + `(cl:eval (cl:read-from-string + ,(prin1-to-string `(dotimes (i ,times) + (unless (= i 0) + (swank::sleep-for 1)) + ,exp))))) + (dotimes (_i times) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window + (sldb-get-default-buffer)))) + 3) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "sldb closed" + (lambda () (not (sldb-get-default-buffer))) + 0.5)) + (slime-sync-to-top-level 1)) + +(def-slime-test (break2 (:fails-for "cmucl" "allegro")) + (times exp) + "Backends should arguably make sure that BREAK does not depend +on *DEBUGGER-HOOK*." + (let ((exp2 + '(block outta + (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) + (break))))) + `((1 ,exp2) (2 ,exp2) (3 ,exp2))) + (slime-test-break times exp)) + +(def-slime-test locally-bound-debugger-hook + () + "Test that binding *DEBUGGER-HOOK* locally works properly." + '(()) + (accept-process-output nil 1) + (slime-check-top-level) + (slime-compile-string + (prin1-to-string `(defun cl-user::quux () + (block outta + (let ((*debugger-hook* + (lambda (c hook) + (declare (ignore c hook)) + (return-from outta 42)))) + (error "FOO"))))) + 0) + (slime-sync-to-top-level 2) + (slime-eval-async '(cl-user::quux)) + ;; FIXME: slime-wait-condition returns immediately if the test returns true + (slime-wait-condition "Checking that Debugger does not popup" + (lambda () + (not (sldb-get-default-buffer))) + 3) + (slime-sync-to-top-level 5)) + +(def-slime-test end-of-file + (expr) + "Signalling END-OF-FILE should invoke the debugger." + '(((cl:error 'cl:end-of-file)) + ((cl:read-from-string ""))) + (let ((value (slime-eval + `(cl:let ((condition nil)) + (cl:with-simple-restart + (cl:continue "continue") + (cl:let ((cl:*debugger-hook* + (cl:lambda (c h) + (cl:setq condition c) + (cl:continue)))) + ,expr)) + (cl:if (cl:typep condition 'cl:end-of-file) t))))) + (slime-test-expect "Debugger invoked" t value))) + +(def-slime-test interrupt-at-toplevel + () + "Let's see what happens if we send a user interrupt at toplevel." + '(()) + (slime-check-top-level) + (unless (and (eq (slime-communication-style) :spawn) + (not (featurep 'slime-repl))) + (slime-interrupt) + (slime-wait-condition + "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5))) + +(def-slime-test interrupt-in-debugger (interrupts continues) + "Let's see what happens if we interrupt the debugger. +INTERRUPTS ... number of nested interrupts +CONTINUES ... how often the continue restart should be invoked" + '((1 0) (2 1) (4 2)) + (slime-check "No debugger" (not (sldb-get-default-buffer))) + (when (and (eq (slime-communication-style) :spawn) + (not (featurep 'slime-repl))) + (slime-eval-async '(swank::without-slime-interrupts + (swank::receive))) + (sit-for 0.2)) + (dotimes (i interrupts) + (slime-interrupt) + (let ((level (1+ i))) + (slime-wait-condition (format "Debug level %d reachend" level) + (lambda () (equal (sldb-level) level)) + 2))) + (dotimes (i continues) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (let ((level (- interrupts (1+ i)))) + (slime-wait-condition (format "Return to debug level %d" level) + (lambda () (equal (sldb-level) level)) + 2))) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 1)) + +(def-slime-test flow-control + (n delay interrupts) + "Let Lisp produce output faster than Emacs can consume it." + `((400 0.03 3)) + (when noninteractive + (slime-skip-test "test is currently unstable")) + (slime-check "No debugger" (not (sldb-get-default-buffer))) + (slime-eval-async `(swank:flow-control-test ,n ,delay)) + (sleep-for 0.2) + (dotimes (_i interrupts) + (slime-interrupt) + (slime-wait-condition "In debugger" (lambda () (slime-sldb-level= 1)) 5) + (slime-check "In debugger" (slime-sldb-level= 1)) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "No debugger" (lambda () (slime-sldb-level= nil)) 3) + (slime-check "Debugger closed" (slime-sldb-level= nil))) + (slime-sync-to-top-level 8)) + +(def-slime-test sbcl-world-lock + (n delay) + "Print something from *MACROEXPAND-HOOK*. +In SBCL, the compiler grabs a lock which can be problematic because +no method dispatch code can be generated for other threads. +This test will fail more likely before dispatch caches are warmed up." + '((10 0.03) + ;;((cl:+ swank::send-counter-limit 10) 0.03) + ) + (slime-test-expect "no error" + 123 + (slime-eval + `(cl:let ((cl:*macroexpand-hook* + (cl:lambda (fun form env) + (swank:flow-control-test ,n ,delay) + (cl:funcall fun form env)))) + (cl:eval '(cl:macrolet ((foo () 123)) + (foo))))))) + +(def-slime-test (disconnect-one-connection (:style :spawn)) () + "`slime-disconnect' should disconnect only the current connection" + '(()) + (let ((connection-count (length slime-net-processes)) + (old-connection slime-default-connection) + (slime-connected-hook nil)) + (unwind-protect + (let ((slime-dispatching-connection + (slime-connect "localhost" + ;; Here we assume that the request will + ;; be evaluated in its own thread. + (slime-eval `(swank:create-server + :port 0 ; use random port + :style :spawn + :dont-close nil))))) + (slime-sync-to-top-level 3) + (slime-disconnect) + (slime-test-expect "Number of connections must remane the same" + connection-count + (length slime-net-processes))) + (slime-select-connection old-connection)))) + +(def-slime-test disconnect-and-reconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (slime-check-top-level) + (let* ((c (slime-connection)) + (p (slime-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (assert (equal (process-status c) 'closed) nil "Connection not closed") + (accept-process-output nil 0.1) + (assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (assert (< (buffer-size) 500) nil "Unusual output")) + (slime-inferior-connect p (slime-inferior-lisp-args p)) + (lexical-let ((hook nil) (p p)) + (setq hook (lambda () + (slime-test-expect + "We are connected again" p (slime-inferior-process)) + (remove-hook 'slime-connected-hook hook))) + (add-hook 'slime-connected-hook hook) + (slime-wait-condition "Lisp restarted" + (lambda () + (not (member hook slime-connected-hook))) + 5)))) + + +;;;; SLIME-loading tests that launch separate Emacsen +;;;; +(cl-defun slime-test-recipe-test-for (&key preflight + takeoff + landing) + (let ((success nil) + (test-file (make-temp-file "slime-recipe-" nil ".el")) + (test-forms + `((require 'cl) + (labels + ((die + (reason &optional more) + (princ reason) + (terpri) + (and more (pp more)) + (kill-emacs 254))) + (condition-case err + (progn ,@preflight) + (error + (die "Unexpected error running preflight forms" + err))) + (add-hook + 'slime-connected-hook + #'(lambda () + (condition-case err + (progn + ,@landing + (kill-emacs 0)) + (error + (die "Unexpected error running landing forms" + err)))) + t) + (condition-case err + (progn + ,@takeoff + ,(when (null landing) '(kill-emacs 0))) + (error + (die "Unexpected error running takeoff forms" + err))) + (with-timeout + (20 + (die "Timeout waiting for recipe test to finish." + takeoff)) + (while t (sit-for 1))))))) + (unwind-protect + (progn + (with-temp-buffer + (mapc #'insert (mapcar #'pp-to-string test-forms)) + (write-file test-file)) + (with-temp-buffer + (let ((retval + (call-process (concat invocation-directory invocation-name) + nil (list t nil) nil + "-Q" "--batch" + "-l" test-file))) + (unless (= 0 retval) + (ert-fail (buffer-substring + (+ (goto-char (point-min)) + (skip-chars-forward " \t\n")) + (+ (goto-char (point-max)) + (skip-chars-backward " \t\n"))))))) + (setq success t)) + (if success (delete-file test-file) + (message "Test failed: keeping %s for inspection" test-file))))) + +(define-slime-ert-test readme-recipe () + "Test the README.md's autoload recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime-autoloads) + (setq inferior-lisp-program ,inferior-lisp-program) + (setq slime-contribs '(slime-fancy))) + :takeoff `((call-interactively 'slime)) + :landing `((unless (and (featurep 'slime-repl) + (find 'swank-repl slime-required-modules)) + (die "slime-repl not loaded properly")) + (with-current-buffer (slime-repl-buffer) + (unless (and (string-match "^; +SLIME" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die "REPL prompt not properly setup" + (buffer-substring-no-properties (point-min) + (point-max)))))))) + +(define-slime-ert-test traditional-recipe () + "Test the README.md's traditional recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime) + (setq inferior-lisp-program ,inferior-lisp-program) + (slime-setup '(slime-fancy))) + :takeoff `((call-interactively 'slime)) + :landing `((unless (and (featurep 'slime-repl) + (find 'swank-repl slime-required-modules)) + (die "slime-repl not loaded properly")) + (with-current-buffer (slime-repl-buffer) + (unless (and (string-match "^; +SLIME" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die "REPL prompt not properly setup" + (buffer-substring-no-properties (point-min) + (point-max)))))))) + +(define-slime-ert-test readme-recipe-autoload-on-lisp-visit () + "Test more autoload bits in README.md's installation recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime-autoloads)) + :takeoff `((if (featurep 'slime) + (die "Didn't expect SLIME to be loaded so early!")) + (find-file ,(make-temp-file "slime-lisp-source-file" nil + ".lisp")) + (unless (featurep 'slime) + (die "Expected SLIME to be fully loaded by now"))))) + +(defun slime-test-eval-now (string) + (second (slime-eval `(swank:eval-and-grab-output ,string)))) + +(def-slime-test (slime-recompile-all-xrefs (:fails-for "cmucl")) () + "Test recompilation of all references within an xref buffer." + '(()) + (let* ((cell (cons nil nil)) + (hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell)) + (filename (make-temp-file "slime-recompile-all-xrefs" nil ".lisp"))) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (with-temp-file filename + (set-visited-file-name filename) + (slime-test-eval-now "(defparameter swank::*.var.* nil)") + (insert "(in-package :swank) + (defun .fn1. ()) + (defun .fn2. () (.fn1.) #.*.var.*) + (defun .fn3. () (.fn1.) #.*.var.*)") + (save-buffer) + (slime-compile-and-load-file) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (slime-test-eval-now "(setq *.var.* t)") + (setcar cell nil) + (slime-xref :calls ".fn1." + (lambda (&rest args) + (apply #'slime-show-xrefs args) + (setcar cell t))) + (slime-wait-condition "Xrefs computed and displayed" + (lambda () (car cell)) + 0.5) + (setcar cell nil) + (with-current-buffer slime-xref-last-buffer + (slime-recompile-all-xrefs) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (should (cl-equalp (list (slime-test-eval-now "(.fn2.)") + (slime-test-eval-now "(.fn3.)")) + '("T" "T")))) + (remove-hook 'slime-compilation-finished-hook hook) + (when slime-xref-last-buffer + (kill-buffer slime-xref-last-buffer))))) + +(provide 'slime-tests) diff --git a/elpa/slime-20200319.1939/slime-tests.elc b/elpa/slime-20200319.1939/slime-tests.elc new file mode 100644 index 00000000..038ac846 Binary files /dev/null and b/elpa/slime-20200319.1939/slime-tests.elc differ diff --git a/elpa/slime-20200319.1939/slime.el b/elpa/slime-20200319.1939/slime.el new file mode 100644 index 00000000..20c28d1b --- /dev/null +++ b/elpa/slime-20200319.1939/slime.el @@ -0,0 +1,7659 @@ +;;; slime.el --- Superior Lisp Interaction Mode for Emacs -*-lexical-binding:t-*- + +;; URL: https://github.com/slime/slime +;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9")) +;; Keywords: languages, lisp, slime +;; Version: 2.24 + +;;;; License and Commentary + +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program 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 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;; Commentary: + +;; SLIME is the ``Superior Lisp Interaction Mode for Emacs.'' +;; +;; SLIME extends Emacs with support for interactive programming in +;; Common Lisp. The features are centered around slime-mode, an Emacs +;; minor-mode that complements the standard lisp-mode. While lisp-mode +;; supports editing Lisp source files, slime-mode adds support for +;; interacting with a running Common Lisp process for compilation, +;; debugging, documentation lookup, and so on. +;; +;; The slime-mode programming environment follows the example of +;; Emacs's native Emacs Lisp environment. We have also included good +;; ideas from similar systems (such as ILISP) and some new ideas of +;; our own. +;; +;; SLIME is constructed from two parts: a user-interface written in +;; Emacs Lisp, and a supporting server program written in Common +;; Lisp. The two sides are connected together with a socket and +;; communicate using an RPC-like protocol. +;; +;; The Lisp server is primarily written in portable Common Lisp. The +;; required implementation-specific functionality is specified by a +;; well-defined interface and implemented separately for each Lisp +;; implementation. This makes SLIME readily portable. + +;;; Code: + + +;;;; Dependencies and setup +(eval-and-compile + (require 'cl-lib nil t) + ;; For emacs 23, look for bundled version + (require 'cl-lib "lib/cl-lib")) + +(eval-when-compile (require 'cl)) ; defsetf, lexical-let + +(eval-and-compile + (if (< emacs-major-version 23) + (error "Slime requires an Emacs version of 23, or above"))) + +(require 'hyperspec "lib/hyperspec") +(require 'thingatpt) +(require 'comint) +(require 'pp) +(require 'easymenu) +(require 'outline) +(require 'arc-mode) +(require 'etags) +(require 'compile) + +(eval-when-compile + (require 'apropos) + (require 'gud) + (require 'lisp-mnt)) + +(declare-function lm-version "lisp-mnt") + +(defvar slime-path nil + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +The default value is automatically computed from the location of +the Emacs Lisp package.") +(setq slime-path (file-name-directory load-file-name)) + +(defvar slime-version nil + "The version of SLIME that you're using.") +(setq slime-version + (eval-when-compile + (lm-version + (cl-find "slime.el" + (remove nil + (list load-file-name + (when (boundp 'byte-compile-current-file) + byte-compile-current-file))) + :key #'file-name-nondirectory + :test #'string-equal)))) + +(defvar slime-lisp-modes '(lisp-mode)) +(defvar slime-contribs nil + "A list of contrib packages to load with SLIME.") +(define-obsolete-variable-alias 'slime-setup-contribs +'slime-contribs "2.3.2") + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load. If `nil', use +`slime-contribs'. " + (interactive) + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (when contribs + (setq slime-contribs contribs)) + (slime--setup-contribs)) + +(defvar slime-required-modules '()) + +(defun slime--setup-contribs () + "Load and initialize contribs." + (dolist (c slime-contribs) + (unless (featurep c) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) + +(defun slime-lisp-mode-hook () + (slime-mode 1) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function)) + +(defvar slime-protocol-version nil) +(setq slime-protocol-version slime-version) + + +;;;; Customize groups +;; +;;;;; slime + +(defgroup slime nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'applications) + +;;;;; slime-ui + +(defgroup slime-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'slime) + +(defcustom slime-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-kill-without-query-p nil + "If non-nil, kill SLIME processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'slime-ui) + +;;;;; slime-lisp + +(defgroup slime-lisp nil + "Lisp server configuration." + :prefix "slime-" + :group 'slime) + +(defcustom slime-backend "swank-loader.lisp" + "The name of the Lisp file that loads the Swank server. +This name is interpreted relative to the directory containing +slime.el, but could also be set to an absolute filename." + :type 'string + :group 'slime-lisp) + +(defcustom slime-connected-hook nil + "List of functions to call when SLIME connects to Lisp." + :type 'hook + :group 'slime-lisp) + +(defcustom slime-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + +(defcustom slime-lisp-host "localhost" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'slime-lisp) + +(defcustom slime-port 4005 + "Port to use as the default for `slime-connect'." + :type 'integer + :group 'slime-lisp) + +(defvar slime-connect-host-history (list slime-lisp-host)) +(defvar slime-connect-port-history (list (prin1-to-string slime-port))) + +(defvar slime-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun slime-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `slime-net-valid-coding-systems' +of nil." + (let ((probe (assq name slime-net-valid-coding-systems))) + (when (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defcustom slime-net-coding-system + (car (cl-find-if 'slime-find-coding-system + slime-net-valid-coding-systems :key 'car)) + "Coding system used for network connections. +See also `slime-net-valid-coding-systems'." + :type (cons 'choice + (mapcar (lambda (x) + (list 'const (car x))) + slime-net-valid-coding-systems)) + :group 'slime-lisp) + +;;;;; slime-mode + +(defgroup slime-mode nil + "Settings for slime-mode Lisp source buffers." + :prefix "slime-" + :group 'slime) + +(defcustom slime-find-definitions-function 'slime-find-definitions-rpc + "Function to find definitions for a name. +The function is called with the definition name, a string, as its +argument." + :type 'function + :group 'slime-mode + :options '(slime-find-definitions-rpc + slime-etags-definitions + (lambda (name) + (append (slime-find-definitions-rpc name) + (slime-etags-definitions name))) + (lambda (name) + (or (slime-find-definitions-rpc name) + (and tags-table-list + (slime-etags-definitions name)))))) + +;; FIXME: remove one day +(defcustom slime-complete-symbol-function 'nil + "Obsolete. Use `slime-completion-at-point-functions' instead." + :group 'slime-mode + :type '(choice (const :tag "Compound" slime-complete-symbol*) + (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) + +(make-obsolete-variable 'slime-complete-symbol-function + 'slime-completion-at-point-functions + "2015-10-18") + +(defcustom slime-completion-at-point-functions + '(slime-filename-completion + slime-simple-completion-at-point) + "List of functions to perform completion. +Works like `completion-at-point-functions'. +`slime--completion-at-point' uses this variable." + :group 'slime-mode) + +;;;;; slime-mode-faces + +(defgroup slime-mode-faces nil + "Faces in slime-mode source code buffers." + :prefix "slime-" + :group 'slime-mode) + +(defface slime-error-face + `((((class color) (background light)) + (:underline "red")) + (((class color) (background dark)) + (:underline "red")) + (t (:underline t))) + "Face for errors from the compiler." + :group 'slime-mode-faces) + +(defface slime-warning-face + `((((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-style-warning-face + `((((class color) (background light)) + (:underline "brown")) + (((class color) (background dark)) + (:underline "gold")) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-note-face + `((((class color) (background light)) + (:underline "brown4")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) + "Face for notes from the compiler." + :group 'slime-mode-faces) + +(defface slime-early-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "brown")) + (((type graphic) (class color) (background dark)) + (:strike-through "gold")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "brown")) + (((class color) (background dark)) + (:underline "gold")) + (t + (:underline t))) + "Face for early deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-late-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "orange")) + (((type graphic) (class color) (background dark)) + (:strike-through "coral")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t + (:underline t))) + "Face for late deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-final-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "red")) + (((type graphic) (class color) (background dark)) + (:strike-through "red")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "red")) + (((class color) (background dark)) + (:underline "red")) + (t + (:strike-through t))) + "Face for final deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-highlight-face + '((t (:inherit highlight :underline nil))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +;;;;; sldb + +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro define-sldb-faces (&rest faces) + "Define the set of SLDB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sldb-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(cl-loop for face in faces + collect `(define-sldb-face ,@face)))) + +(defmacro define-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'slime-debugger))) + +(define-sldb-faces + (topline "the top line describing the error") + (condition "the condition class" + '(:inherit font-lock-warning-face)) + (section "the labels of major sections in the debugger buffer" + '(:inherit header-line)) + (frame-label "backtrace frame numbers" + '(:inherit shadow)) + (restart-type "restart names." + '(:inherit font-lock-keyword-face)) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:bold t)) + (frame-line "function names and arguments in the backtrace") + (restartable-frame-line + "frames which are surely restartable" + '(:foreground "lime green")) + (non-restartable-frame-line + "frames which are surely not restartable") + (detailed-frame-line + "function names and arguments in a detailed (expanded) frame") + (local-name "local variable names" + '(:inherit font-lock-variable-name-face)) + (local-value "local variable values") + (catch-tag "catch tags" + '(:inherit highlight))) + + +;;;; Minor modes + +;;;;; slime-mode + +(defvar slime-mode-indirect-map (make-sparse-keymap) + "Empty keymap which has `slime-mode-map' as it's parent. +This is a hack so that we can reinitilize the real slime-mode-map +more easily. See `slime-init-keymaps'.") + +(defvar slime-buffer-connection) +(defvar slime-dispatching-connection) +(defvar slime-current-thread) + +(defun slime--on () + (slime-setup-completion)) + +(defun slime--off () + (remove-hook 'completion-at-point-functions #'slime--completion-at-point t)) + +(define-minor-mode slime-mode + "\\\ +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). + +Commands to compile the current buffer's source file and visually +highlight any resulting compiler notes and warnings: +\\[slime-compile-and-load-file] - Compile and load the current buffer's file. +\\[slime-compile-file] - Compile (but not load) the current buffer's file. +\\[slime-compile-defun] - Compile the top-level form at point. + +Commands for visiting compiler notes: +\\[slime-next-note] - Goto the next form with a compiler note. +\\[slime-previous-note] - Goto the previous form with a compiler note. +\\[slime-remove-notes] - Remove compiler-note annotations in buffer. + +Finding definitions: +\\[slime-edit-definition] +- Edit the definition of the function called at point. +\\[slime-pop-find-definition-stack] +- Pop the definition stack to go back from a definition. + +Documentation commands: +\\[slime-describe-symbol] - Describe symbol. +\\[slime-apropos] - Apropos search. +\\[slime-disassemble-symbol] - Disassemble a function. + +Evaluation commands: +\\[slime-eval-defun] - Evaluate top-level from containing point. +\\[slime-eval-last-expression] - Evaluate sexp before point. +\\[slime-pprint-eval-last-expression] \ +- Evaluate sexp before point, pretty-print result. + +Full set of commands: +\\{slime-mode-map}" + :keymap slime-mode-indirect-map + :lighter (:eval (slime-modeline-string)) + (cond (slime-mode (slime--on)) + (t (slime--off)))) + + +;;;;;; Modeline + +(defun slime-modeline-string () + "Return the string to display in the modeline. +\"Slime\" only appears if we aren't connected. If connected, +include package-name, connection-name, and possibly some state +information." + (let ((conn (slime-current-connection))) + ;; Bail out early in case there's no connection, so we won't + ;; implicitly invoke `slime-connection' which may query the user. + (if (not conn) + (and slime-mode " Slime") + (let ((local (eq conn slime-buffer-connection)) + (pkg (slime-current-package))) + (concat " " + (if local "{" "[") + (if pkg (slime-pretty-package-name pkg) "?") + " " + ;; ignore errors for closed connections + (ignore-errors (slime-connection-name conn)) + (slime-modeline-state-string conn) + (if local "}" "]")))))) + +(defun slime-pretty-package-name (name) + "Return a pretty version of a package name NAME." + (cond ((string-match "^#?:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name))) + +(defun slime-modeline-state-string (conn) + "Return a string possibly describing CONN's state." + (cond ((not (eq (process-status conn) 'open)) + (format " %s" (process-status conn))) + ((let ((pending (length (slime-rex-continuations conn))) + (sldbs (length (sldb-buffers conn)))) + (cond ((and (zerop sldbs) (zerop pending)) nil) + ((zerop sldbs) (format " %s" pending)) + (t (format " %s/%s" pending sldbs))))))) + +(defun slime--recompute-modelines () + (force-mode-line-update t)) + + +;;;;; Key bindings + +(defvar slime-parent-map nil + "Parent keymap for shared between all Slime related modes.") + +(defvar slime-parent-bindings + '(("\M-." slime-edit-definition) + ("\M-," slime-pop-find-definition-stack) + ("\M-_" slime-edit-uses) ; for German layout + ("\M-?" slime-edit-uses) ; for USian layout + ("\C-x4." slime-edit-definition-other-window) + ("\C-x5." slime-edit-definition-other-frame) + ("\C-x\C-e" slime-eval-last-expression) + ("\C-\M-x" slime-eval-defun) + ;; Include PREFIX keys... + ("\C-c" slime-prefix-map))) + +(defvar slime-prefix-map nil + "Keymap for commands prefixed with `slime-prefix-key'.") + +(defvar slime-prefix-bindings + '(("\C-r" slime-eval-region) + (":" slime-interactive-eval) + ("\C-e" slime-interactive-eval) + ("E" slime-edit-value) + ("\C-l" slime-load-file) + ("\C-b" slime-interrupt) + ("\M-d" slime-disassemble-symbol) + ("\C-t" slime-toggle-trace-fdefinition) + ("I" slime-inspect) + ("\C-xt" slime-list-threads) + ("\C-xn" slime-next-connection) + ("\C-xp" slime-prev-connection) + ("\C-xc" slime-list-connections) + ("<" slime-list-callers) + (">" slime-list-callees) + ;; Include DOC keys... + ("\C-d" slime-doc-map) + ;; Include XREF WHO-FOO keys... + ("\C-w" slime-who-map) + )) + +(defvar slime-editing-map nil + "These keys are useful for buffers where the user can insert and +edit s-exprs, e.g. for source buffers and the REPL.") + +(defvar slime-editing-keys + `(;; Arglist display & completion + (" " slime-space) + ;; Evaluating + ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) + ("\C-c\C-p" slime-pprint-eval-last-expression) + ;; Macroexpand + ("\C-c\C-m" slime-expand-1) + ("\C-c\M-m" slime-macroexpand-all) + ;; Misc + ("\C-c\C-u" slime-undefine-function) + (,(kbd "C-M-.") slime-next-location) + (,(kbd "C-M-,") slime-previous-location) + ;; Obsolete, redundant bindings + ("\C-c\C-i" completion-at-point) + ;;("\M-*" pop-tag-mark) ; almost to clever + )) + +(defvar slime-mode-map nil + "Keymap for slime-mode.") + +(defvar slime-keys + '( ;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\C-c\M-c" slime-remove-notes) + ("\C-c\C-k" slime-compile-and-load-file) + ("\C-c\M-k" slime-compile-file) + ("\C-c\C-c" slime-compile-defun))) + +(defun slime-nop () + "The null command. Used to shadow currently-unused keybindings." + (interactive) + (call-interactively 'undefined)) + +(defvar slime-doc-map nil + "Keymap for documentation commands. Bound to a prefix key.") + +(defvar slime-doc-bindings + '((?a slime-apropos) + (?z slime-apropos-all) + (?p slime-apropos-package) + (?d slime-describe-symbol) + (?f slime-describe-function) + (?h slime-documentation-lookup) + (?~ common-lisp-hyperspec-format) + (?g common-lisp-hyperspec-glossary-term) + (?# common-lisp-hyperspec-lookup-reader-macro))) + +(defvar slime-who-map nil + "Keymap for who-xref commands. Bound to a prefix key.") + +(defvar slime-who-bindings + '((?c slime-who-calls) + (?w slime-calls-who) + (?r slime-who-references) + (?b slime-who-binds) + (?s slime-who-sets) + (?m slime-who-macroexpands) + (?a slime-who-specializes))) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode'." + (interactive) + (slime-init-keymap 'slime-doc-map t t slime-doc-bindings) + (slime-init-keymap 'slime-who-map t t slime-who-bindings) + (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings) + (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings) + (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys) + (set-keymap-parent slime-editing-map slime-parent-map) + (slime-init-keymap 'slime-mode-map nil nil slime-keys) + (set-keymap-parent slime-mode-map slime-editing-map) + (set-keymap-parent slime-mode-indirect-map slime-mode-map)) + +(defun slime-init-keymap (keymap-name prefixp bothp bindings) + (set keymap-name (make-sparse-keymap)) + (when prefixp (define-prefix-command keymap-name)) + (slime-bind-keys (eval keymap-name) bothp bindings)) + +(defun slime-bind-keys (keymap bothp bindings) + "Add BINDINGS to KEYMAP. +If BOTHP is true also add bindings with control modifier." + (cl-loop for (key command) in bindings do + (cond (bothp + (define-key keymap `[,key] command) + (unless (equal key ?h) ; But don't bind C-h + (define-key keymap `[(control ,key)] command))) + (t (define-key keymap key command))))) + +(slime-init-keymaps) + +(define-minor-mode slime-editing-mode + "Minor mode which makes slime-editing-map available. +\\{slime-editing-map}" + nil + nil + slime-editing-map) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLIME idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(defmacro slime-dcase (value &rest patterns) + (declare (indent 1)) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (cl-gensym "op-")) + (operands (cl-gensym "rand-")) + (tmp (cl-gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (cl-case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (cl-destructuring-bind ((op &rest rands) &rest body) + clause + `(,op (cl-destructuring-bind ,rands ,operands + . ,(or body + '((ignore)) ; suppress some warnings + )))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "slime-dcase failed: %S" ,tmp)))))))) + +(defmacro slime-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + (declare (indent 1)) + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(cl-defmacro with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (declare (indent 2)) + (let ((struct-var (cl-gensym "struct")) + (reader (lambda (slot) + (intern (concat (symbol-name conc-name) + (symbol-name slot)))))) + `(let ((,struct-var ,struct)) + (cl-symbol-macrolet + ,(mapcar (lambda (slot) + (cl-etypecase slot + (symbol `(,slot (,(funcall reader slot) ,struct-var))) + (cons `(,(cl-first slot) + (,(funcall reader (cl-second slot)) + ,struct-var))))) + slots) + . ,body)))) + +;;;;; Very-commonly-used functions + +(defvar slime-message-function 'message) + +;; Interface +(defun slime-buffer-name (type &optional hidden) + (cl-assert (keywordp type)) + (concat (if hidden " " "") + (format "*slime-%s*" (substring (symbol-name type) 1)))) + +;; Interface +(defun slime-message (format &rest args) + "Like `message' but with special support for multi-line messages. +Single-line messages use the echo area." + (apply slime-message-function format args)) + +(defun slime-display-warning (message &rest args) + (display-warning '(slime warning) (apply #'format message args))) + +(defvar slime-background-message-function 'slime-display-oneliner) + +;; Interface +(defun slime-background-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer or display multi-line messages. +It should be used for \"background\" messages such as argument lists." + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) + +(defun slime-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (cl-position ?\n string) most-positive-fixnum) + (1- (window-width (minibuffer-window)))))) + +;; Interface +(defun slime-set-truncate-lines () + "Apply `slime-truncate-lines' to the current buffer." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun slime-read-package-name (prompt &optional initial-value) + "Read a package name from the minibuffer, prompting with PROMPT." + (let ((completion-ignore-case t)) + (completing-read prompt (slime-bogus-completion-alist + (slime-eval + `(swank:list-all-package-names t))) + nil t initial-value))) + +;; Interface +(defun slime-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (cond ((or current-prefix-arg query (not (slime-symbol-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-at-point))) + (t (slime-symbol-at-point)))) + +;; Interface +(defmacro slime-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) (debug (sexp &rest form))) + (let ((start (cl-gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(defun slime-add-face (face string) + (declare (indent 1)) + (add-text-properties 0 (length string) (list 'face face) string) + string) + +;; Interface +(defsubst slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + +(defmacro slime-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (declare (indent 1)) + (let ((start (cl-gensym)) (l (cl-gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (slime-indent-rigidly ,start (point) ,l))))) + +(defun slime-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (let ((indent (make-string column ?\ ))) + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (insert-before-markers indent) + (zerop (forward-line -1)))))))) + +(defun slime-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (slime-with-rigid-indentation nil + (apply #'insert strings))) + +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (cl-assert (get-text-property (point) prop)) + (let ((end (next-single-char-property-change (point) prop))) + (list (previous-single-char-property-change end prop) end))) + +(defun slime-curry (fun &rest args) + "Partially apply FUN to ARGS. The result is a new function. +This idiom is preferred over `lexical-let'." + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun slime-rcurry (fun &rest args) + "Like `slime-curry' but ARGS on the right are applied." + `(lambda (&rest more) (apply ',fun (append more ',args)))) + + +;;;;; Temporary popup buffers + +;; keep compiler quiet +(defvar slime-buffer-package) +(defvar slime-buffer-connection) + +;; Interface +(cl-defmacro slime-with-popup-buffer ((name &key package connection select + mode) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. + +NAME is the name of the buffer to be created. +PACKAGE is the value `slime-buffer-package'. +CONNECTION is the value for `slime-buffer-connection', + if nil, no explicit connection is associated with + the buffer. If t, the current connection is taken. +MODE is the name of a major mode which will be enabled. +" + (declare (indent 1)) + (let ((package-sym (cl-gensym "package-")) + (connection-sym (cl-gensym "connection-"))) + `(let ((,package-sym ,(if (eq package t) + `(slime-current-package) + package)) + (,connection-sym ,(if (eq connection t) + `(slime-current-connection) + connection))) + (with-current-buffer (get-buffer-create ,name) + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + (funcall (or ,mode 'fundamental-mode)) + (setq slime-buffer-package ,package-sym + slime-buffer-connection ,connection-sym) + (set-syntax-table lisp-mode-syntax-table) + ,@body + (slime-popup-buffer-mode 1) + (funcall (if ,select 'pop-to-buffer 'display-buffer) + (current-buffer)) + (current-buffer)))))) + +(defvar slime-popup-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "q") 'quit-window) + ;;("\C-c\C-z" . slime-switch-to-output-buffer) + (define-key map (kbd "M-.") 'slime-edit-definition) + map)) + +(define-minor-mode slime-popup-buffer-mode + "Mode for displaying read only stuff" + nil nil nil + (setq buffer-read-only t)) + +(add-to-list 'minor-mode-alist + `(slime-popup-buffer-mode + (:eval (unless slime-mode + (slime-modeline-string))))) + +(set-keymap-parent slime-popup-buffer-mode-map slime-parent-map) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defvar slime-to-lisp-filename-function #'convert-standard-filename + "Function to translate Emacs filenames to CL namestrings.") +(defvar slime-from-lisp-filename-function #'identity + "Function to translate CL namestrings to Emacs filenames.") + +(defun slime-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename." + (funcall slime-to-lisp-filename-function filename)) + +(defun slime-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename." + (funcall slime-from-lisp-filename-function filename)) + + +;;;; Starting SLIME +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") + +(defvar slime-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +For KEYWORD-ARGS see `slime-start'. + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defvar slime-default-lisp nil + "*The name of the default Lisp implementation. +See `slime-lisp-implementations'") + +;; dummy definitions for the compiler +(defvar slime-net-processes) +(defvar slime-default-connection) + +(defun slime (&optional command coding-system) + "Start an inferior^_superior Lisp and connect to its Swank server." + (interactive) + (slime-setup) + (let ((inferior-lisp-program (or command inferior-lisp-program)) + (slime-net-coding-system (or coding-system slime-net-coding-system))) + (slime-start* (cond ((and command (symbolp command)) + (slime-lisp-options command)) + (t (slime-read-interactive-args)))))) + +(defvar slime-inferior-lisp-program-history '() + "History list of command strings. Used by `slime'.") + +(defun slime-read-interactive-args () + "Return the list of args which should be passed to `slime-start'. + +The rules for selecting the arguments are rather complicated: + +- In the most common case, i.e. if there's no prefix-arg in + effect and if `slime-lisp-implementations' is nil, use + `inferior-lisp-program' as fallback. + +- If the table `slime-lisp-implementations' is non-nil use the + implementation with name `slime-default-lisp' or if that's nil + the first entry in the table. + +- If the prefix-arg is `-', prompt for one of the registered + lisps. + +- If the prefix-arg is positive, read the command to start the + process." + (let ((table slime-lisp-implementations)) + (cond ((not current-prefix-arg) (slime-lisp-options)) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + table) + nil t))) + (slime-lookup-lisp-implementation table (intern key)))) + (t + (cl-destructuring-bind (program &rest program-args) + (split-string-and-unquote + (read-shell-command "Run lisp: " inferior-lisp-program + 'slime-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "set slime-coding-system: " + slime-net-coding-system) + slime-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system))))))) + +(defun slime-lisp-options (&optional name) + (let ((table slime-lisp-implementations)) + (cl-assert (or (not name) table)) + (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations + (or name slime-default-lisp + (car (car table))))) + (t (cl-destructuring-bind (program &rest args) + (split-string inferior-lisp-program) + (list :program program :program-args args)))))) + +(defun slime-lookup-lisp-implementation (table name) + (let ((arguments (cl-rest (assoc name table)))) + (unless arguments + (error "Could not find lisp implementation with the name '%S'" name)) + (when (and (= (length arguments) 1) + (functionp (cl-first arguments))) + (setf arguments (funcall (cl-first arguments)))) + (cl-destructuring-bind ((prog &rest args) &rest keys) arguments + (cl-list* :name name :program prog :program-args args keys)))) + +(cl-defun slime-start (&key (program inferior-lisp-program) program-args + directory + (coding-system slime-net-coding-system) + (init 'slime-init-command) + name + (buffer "*inferior-lisp*") + init-function + env) + "Start a Lisp process and connect to it. +This function is intended for programmatic use if `slime' is not +flexible enough. + +PROGRAM and PROGRAM-ARGS are the filename and argument strings + for the subprocess. +INIT is a function that should return a string to load and start + Swank. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `slime-init-command'. +CODING-SYSTEM a symbol for the coding system. The default is + slime-net-coding-system +ENV environment variables for the subprocess (see `process-environment'). +INIT-FUNCTION function to call right after the connection is established. +BUFFER the name of the buffer to use for the subprocess. +NAME a symbol to describe the Lisp implementation +DIRECTORY change to this directory before starting the process. +" + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function :env env))) + (slime-check-coding-system coding-system) + (when (slime-bytecode-stale-p) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp program program-args env + directory buffer))) + (slime-inferior-connect proc args) + (pop-to-buffer (process-buffer proc))))) + +(defun slime-start* (options) + (apply #'slime-start options)) + +(defun slime-connect (host port &optional _coding-system interactive-p &rest parameters) + "Connect to a running Swank server. Return the connection." + (interactive (list (read-from-minibuffer + "Host: " (cl-first slime-connect-host-history) + nil nil '(slime-connect-host-history . 1)) + (string-to-number + (read-from-minibuffer + "Port: " (cl-first slime-connect-port-history) + nil nil '(slime-connect-port-history . 1))) + nil t)) + (slime-setup) + (when (and interactive-p + slime-net-processes + (y-or-n-p "Close old connections first? ")) + (slime-disconnect-all)) + (message "Connecting to Swank on port %S.." port) + (let* ((process (apply 'slime-net-connect host port parameters)) + (slime-dispatching-connection process)) + (slime-setup-connection process))) + +;; FIXME: seems redundant +(defun slime-start-and-init (options fun) + (let* ((rest (plist-get options :init-function)) + (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun))) + (t fun)))) + (slime-start* (plist-put (cl-copy-list options) :init-function init)))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLIME: +;;; +;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale. +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Swank. +;;; 3. Lisp recompiles the Swank if needed. +;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Swank needs recompilation. + +(defvar slime-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +;;; Recompiling bytecode: + +(defun slime-bytecode-stale-p () + "Return true if slime.elc is older than slime.el." + (let ((libfile (locate-library "slime"))) + (when libfile + (let* ((basename (file-name-sans-extension libfile)) + (sourcefile (concat basename ".el")) + (bytefile (concat basename ".elc"))) + (and (file-exists-p bytefile) + (file-newer-than-file-p sourcefile bytefile)))))) + +(defun slime-recompile-bytecode () + "Recompile and reload slime." + (interactive) + (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime")) + ".el"))) + (byte-compile-file sourcefile t))) + +(defun slime-urge-bytecode-recompile () + "Urge the user to recompile slime.elc. +Return true if we have been given permission to continue." + (when (y-or-n-p "slime.elc is older than source. Recompile first? ") + (slime-recompile-bytecode))) + +(defun slime-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (slime-connect-retry-timer + (slime-cancel-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Swank: + +(defun slime-maybe-start-lisp (program program-args env directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (slime-start-lisp program program-args env directory buffer)) + ((slime-reinitialize-inferior-lisp-p program program-args env buffer) + (let ((conn (cl-find (get-buffer-process buffer) + slime-net-processes + :key #'slime-inferior-process))) + (when conn + (slime-net-close conn))) + (get-buffer-process buffer)) + (t (slime-start-lisp program program-args env directory + (generate-new-buffer-name buffer))))) + +(defun slime-reinitialize-inferior-lisp-p (program program-args env buffer) + (let ((args (slime-inferior-lisp-args (get-buffer-process buffer)))) + (and (equal (plist-get args :program) program) + (equal (plist-get args :program-args) program-args) + (equal (plist-get args :env) env) + (not (y-or-n-p "Create an additional *inferior-lisp*? "))))) + +(defvar slime-inferior-process-start-hook nil + "Hook called whenever a new process gets started.") + +(defun slime-start-lisp (program program-args env directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (let ((process-environment (append env process-environment)) + (process-connection-type nil)) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (slime-set-query-on-exit-flag proc) + (run-hooks 'slime-inferior-process-start-hook) + proc))) + +(defun slime-inferior-connect (process args) + "Start a Swank server in the inferior Lisp and connect." + (slime-delete-swank-port-file 'quiet) + (slime-start-swank-server process args) + (slime-read-port-and-connect process)) + +(defvar slime-inferior-lisp-args nil + "A buffer local variable in the inferior proccess. +See `slime-start'.") + +(defun slime-start-swank-server (process args) + "Start a Swank server on the inferior lisp." + (cl-destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer process) + (make-local-variable 'slime-inferior-lisp-args) + (setq slime-inferior-lisp-args args) + (let ((str (funcall init (slime-swank-port-file) coding-system))) + (goto-char (process-mark process)) + (insert-before-markers str) + (process-send-string process str))))) + +(defun slime-inferior-lisp-args (process) + "Return the initial process arguments. +See `slime-start'." + (with-current-buffer (process-buffer process) + slime-inferior-lisp-args)) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun slime-init-command (port-filename _coding-system) + "Return a string to initialize Lisp." + (let ((loader (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend)))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,(slime-to-lisp-filename (expand-file-name loader)) + :verbose t) + (funcall (read-from-string "swank-loader:init") + :from-emacs t) + (funcall (read-from-string "swank:start-server") + ,(slime-to-lisp-filename port-filename)))))) + +(defun slime-swank-port-file () + "Filename where the SWANK server writes its TCP port number." + (expand-file-name (format "slime.%S" (emacs-pid)) (slime-temp-directory))) + +(defun slime-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + +(defun slime-delete-swank-port-file (&optional quiet) + (condition-case data + (delete-file (slime-swank-port-file)) + (error + (cl-ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (message (message "Unable to delete swank port file %S" + (slime-swank-port-file))))))) + +(defun slime-read-port-and-connect (inferior-process) + (slime-attempt-connection inferior-process nil 1)) + +(defun slime-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (slime-cancel-connect-retry-timer) + (let ((file (slime-swank-port-file))) + (unless (active-minibuffer-window) + (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)" + file attempt)) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (slime-read-swank-port)) + (args (slime-inferior-lisp-args process))) + (slime-delete-swank-port-file 'message) + (let ((c (slime-connect slime-lisp-host port + (plist-get args :coding-system)))) + (slime-set-inferior-process c process)))) + ((and retries (zerop retries)) + (message "Gave up connecting to Swank after %d attempts." attempt)) + ((eq (process-status process) 'exit) + (message "Failed to connect to Swank: inferior process exited.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (cl-assert (not slime-connect-retry-timer)) + (setq slime-connect-retry-timer + (run-with-timer + 0.3 nil + #'slime-timer-call #'slime-attempt-connection + process (and retries (1- retries)) + (1+ attempt))))))) + +(defun slime-timer-call (fun &rest args) + "Call function FUN with ARGS, reporting all errors. + +The default condition handler for timer functions (see +`timer-event-handler') ignores errors." + (condition-case data + (apply fun args) + ((debug error) + (debug nil (list "Error in timer" fun args data))))) + +(defun slime-cancel-connect-retry-timer () + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (setq slime-connect-retry-timer nil))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (cl-assert (integerp port)) + port)))) + +(defun slime-toggle-debug-on-swank-error () + (interactive) + (if (slime-eval `(swank:toggle-debug-on-swank-error)) + (message "Debug on SWANK error enabled.") + (message "Debug on SWANK error disabled."))) + +;;; Words of encouragement + +(defun slime-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar slime-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + "Are we consing yet?" + ,(format "%s, this could be the start of a beautiful program." + (slime-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun slime-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length slime-words-of-encouragement)) + slime-words-of-encouragement))) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLIME protocol message beings with a 6-byte header followed +;;; by an S-expression as text. The sexp must be readable both by +;;; Emacs and by Common Lisp, so if it contains any embedded code +;;; fragments they should be sent as strings: +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in swank.lisp. + +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") + +(defun slime-secret () + "Find the magic secret from the user's home directory. +Return nil if the file doesn't exist or is empty; otherwise the +first line of the file." + (condition-case _err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface + +(defun slime-send-secret (proc) + (let ((secret (slime-secret))) + (when secret + (let* ((payload (encode-coding-string secret 'utf-8-unix)) + (string (concat (slime-net-encode-length (length payload)) + payload))) + (process-send-string proc string))))) + +(defun slime-net-connect (host port &rest parameters) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (proc (apply 'open-network-stream "SLIME Lisp" nil host port parameters)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) + (slime-set-query-on-exit-flag proc) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system proc 'binary 'binary)) + (slime-send-secret proc) + proc)) + +(defun slime-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'kill-buffer-query-functions) nil)) + buffer)) + +(defun slime-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'." + (when slime-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + +;;;;; Coding system madness + +(defun slime-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (slime-find-coding-system coding-system))) + (unless props + (error "Invalid slime-net-coding-system: %s. %s" + coding-system (mapcar #'car slime-net-valid-coding-systems))) + (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) + (cl-assert default-enable-multibyte-characters)) + t)) + +(defun slime-coding-system-mulibyte-p (coding-system) + (cl-second (slime-find-coding-system coding-system))) + +(defun slime-coding-system-cl-name (coding-system) + (cl-third (slime-find-coding-system coding-system))) + +;;; Interface +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((payload (encode-coding-string + (concat (slime-prin1-to-string sexp) "\n") + 'utf-8-unix)) + (string (concat (slime-net-encode-length (length payload)) + payload))) + (slime-log-event sexp) + (process-send-string proc string))) + +(defun slime-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (slime-coding-system-mulibyte-p coding-system))))) + +(defun slime-net-close (process &optional debug) + (setq slime-net-processes (remove process slime-net-processes)) + (when (eq process slime-default-connection) + (setq slime-default-connection nil)) + (cond (debug + (set-process-sentinel process 'ignore) + (set-process-filter process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'slime-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) + +(defun slime-net-sentinel (process message) + (message "Lisp connection closed unexpectedly: %s" message) + (slime-net-close process)) + +;;; Socket input is handled by `slime-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun slime-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) + +(defun slime-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (slime-net-read-or-lose process)) + (ok nil)) + (slime-log-event event) + (unwind-protect + (save-current-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle 'slime-process-available-input process))))))) + +(defun slime-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) + +(defun slime-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time 0 nil function args)) + +(defun slime-handle-net-read-error (error) + (let ((packet (buffer-string))) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) + (goto-char (point-min))) + (cond ((y-or-n-p "Skip this packet? ") + `(:emacs-skipped-packet ,packet)) + (t + (when (y-or-n-p "Enter debugger instead? ") + (debug 'error error)) + (signal (car error) (cdr error)))))) + +(defun slime-net-read-or-lose (process) + (condition-case error + (slime-net-read) + (error + (slime-net-close process t) + (error "net-read error: %S" error)))) + +(defun slime-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (slime-net-decode-length)) + (start (+ (point) 6)) + (end (+ start length))) + (cl-assert (cl-plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (condition-case error + (progn + (decode-coding-region start end 'utf-8-unix) + (setq end (point-max)) + (read (current-buffer))) + (error + (slime-handle-net-read-error error)))) + (delete-region (point-min) end)))) + +(defun slime-net-decode-length () + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) + 16)) + +(defun slime-net-encode-length (n) + (format "%06x" n)) + +(defun slime-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1-to-string sexp))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `slime-dispatching-connection' if dynamically bound, or +;;; `slime-buffer-connection' if this is set buffer-local, or +;;; `slime-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `slime-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `slime-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `slime-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and slime hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") + +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) + +(defvar slime-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`slime-dispatching-connection' or `slime-buffer-connection'.") + +(defun slime-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or slime-dispatching-connection + slime-buffer-connection + slime-default-connection)) + +(defun slime-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (slime-current-connection))) + (cond ((and (not conn) slime-net-processes) + (or (slime-auto-select-connection) + (error "No default connection selected."))) + ((not conn) + (or (slime-auto-start) + (error "Not connected."))) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(define-obsolete-variable-alias 'slime-auto-connect +'slime-auto-start "2.5") +(defcustom slime-auto-start 'never + "Controls auto connection when information from lisp process is needed. +This doesn't mean it will connect right after Slime is loaded." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-start () + (cond ((or (eq slime-auto-start 'always) + (and (eq slime-auto-start 'ask) + (y-or-n-p "No connection. Start Slime? "))) + (save-window-excursion + (slime) + (while (not (slime-current-connection)) + (sleep-for 1)) + (slime-connection))) + (t nil))) + +(defcustom slime-auto-select-connection 'ask + "Controls auto selection after the default connection was closed." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-select-connection () + (let* ((c0 (car slime-net-processes)) + (c (cond ((eq slime-auto-select-connection 'always) c0) + ((and (eq slime-auto-select-connection 'ask) + (y-or-n-p + (format "No default connection selected. %s %s? " + "Switch to" (slime-connection-name c0)))) + c0)))) + (when c + (slime-select-connection c) + (message "Switching to connection: %s" (slime-connection-name c)) + c))) + +(defun slime-select-connection (process) + "Make PROCESS the default connection." + (setq slime-default-connection process)) + +(defvar slime-cycle-connections-hook nil) + +(defun slime-cycle-connections-within (connections) + (let* ((tail (or (cdr (member (slime-current-connection) connections)) + connections)) ; loop around to the beginning + (next (car tail))) + (slime-select-connection next) + (run-hooks 'slime-cycle-connections-hook) + (message "Lisp: %s %s" + (slime-connection-name next) + (process-contact next)))) + +(defun slime-next-connection () + "Change current slime connection, cycling through all connections." + (interactive) + (slime-cycle-connections-within (reverse slime-net-processes))) + +(define-obsolete-function-alias 'slime-cycle-connections + 'slime-next-connection "2.13") + +(defun slime-prev-connection () + "Change current slime connection, cycling through all connections. +Goes in reverse order, relative to `slime-next-connection'." + (interactive) + (slime-cycle-connections-within slime-net-processes)) + +(cl-defmacro slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + (declare (indent 1)) + `(with-current-buffer + (process-buffer (or ,process (slime-connection) + (error "No connection"))) + ,@body)) + +;;; Connection-local variables: + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (declare (indent 2)) + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (slime-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(slime-with-connection-buffer (,process) + (setq (\, (quote (\, real-var))) (\, store)))) + '(\, varname)))) + +(slime-def-connection-var slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-modules '() + "The strings of Lisp's *MODULES*.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(slime-def-connection-var slime-lisp-implementation-program nil + "The argv[0] of the process running the Lisp implementation.") + +(slime-def-connection-var slime-connection-name nil + "The short name for connection.") + +(slime-def-connection-var slime-inferior-process nil + "The inferior process for the connection if any.") + +(slime-def-connection-var slime-communication-style nil + "The communication style.") + +(slime-def-connection-var slime-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +(slime-def-connection-var slime-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + +;;;;; Connection setup + +(defvar slime-connection-counter 0 + "The number of SLIME connections made. For generating serial numbers.") + +;;; Interface +(defun slime-setup-connection (process) + "Make a connection out of PROCESS." + (let ((slime-dispatching-connection process)) + (slime-init-connection-state process) + (slime-select-connection process) + process)) + +(defun slime-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal slime-net-processes (list proc)) + (setq slime-connection-counter 0)) + (slime-with-connection-buffer () + (setq slime-buffer-connection proc)) + (setf (slime-connection-number proc) (cl-incf slime-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (let ((slime-current-thread t)) + (slime-eval-async '(swank:connection-info) + (slime-curry #'slime-set-connection-info proc)))) + +(defun slime-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((slime-dispatching-connection connection) + (slime-current-thread t)) + (cl-destructuring-bind (&key pid style lisp-implementation machine + features version modules encoding + &allow-other-keys) info + (slime-check-version version connection) + (setf (slime-pid) pid + (slime-communication-style) style + (slime-lisp-features) features + (slime-lisp-modules) modules) + (cl-destructuring-bind (&key type name version program) + lisp-implementation + (setf (slime-lisp-implementation-type) type + (slime-lisp-implementation-version) version + (slime-lisp-implementation-name) name + (slime-lisp-implementation-program) program + (slime-connection-name) (slime-generate-connection-name name))) + (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine + (setf (slime-machine-instance) instance)) + (cl-destructuring-bind (&key coding-systems) encoding + (setf (slime-connection-coding-systems) coding-systems))) + (let ((args (let ((p (slime-inferior-process))) + (if p (slime-inferior-lisp-args p))))) + (let ((name (plist-get args ':name))) + (when name + (unless (string= (slime-lisp-implementation-name) name) + (setf (slime-connection-name) + (slime-generate-connection-name (symbol-name name)))))) + (slime-load-contribs) + (run-hooks 'slime-connected-hook) + (let ((fun (plist-get args ':init-function))) + (when fun (funcall fun)))) + (message "Connected. %s" (slime-random-words-of-encouragement)))) + +(defun slime-check-version (version conn) + (or (equal version slime-protocol-version) + (equal slime-protocol-version 'ignore) + (y-or-n-p + (format "Versions differ: %s (slime) vs. %s (swank). Continue? " + slime-protocol-version version)) + (slime-net-close conn) + (top-level))) + +(defun slime-generate-connection-name (lisp-name) + (cl-loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (cl-find name slime-net-processes + :key #'slime-connection-name :test #'equal) + finally (cl-return name))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-default-connection) + (when slime-net-processes + (slime-select-connection (car slime-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (slime-connection-number) + (slime-connection-name))))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +;;;;; Commands on connections + +(defun slime-disconnect () + "Close the current connection." + (interactive) + (slime-net-close (slime-connection))) + +(defun slime-disconnect-all () + "Disconnect all connections." + (interactive) + (mapc #'slime-net-close slime-net-processes)) + +(defun slime-connection-port (connection) + "Return the remote port number of CONNECTION." + (cadr (process-contact connection))) + +(defun slime-process (&optional connection) + "Return the Lisp process for CONNECTION (default `slime-connection'). +Return nil if there's no process object for the connection." + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + +(defun slime-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (slime-connection)))) + (cl-ecase (slime-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar slime-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun slime-background-activities-enabled-p () + (and (let ((con (slime-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (slime-busy-p)) + (not slime-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`slime-eval-async') for +;;; most things. Reserve synchronous evaluations (`slime-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `slime-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `slime-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar slime-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar slime-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `slime-rex' is the RPC primitive which is used to implement both +;;; `slime-eval' and `slime-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(cl-defmacro slime-rex ((&rest saved-vars) + (sexp &optional + (package '(slime-current-package)) + (thread 'slime-current-thread)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (slime-current-package). + +CLAUSES is a list of patterns with same syntax as +`slime-dcase'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because various Emacs +versions cannot deal with that." + (declare (indent 2)) + (let ((result (cl-gensym))) + `(lexical-let ,(cl-loop for var in saved-vars + collect (cl-etypecase var + (symbol (list var var)) + (cons var))) + (slime-dispatch-event + (list :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (slime-dcase ,result + ,@continuations))))))) + +;;; Interface +(defun slime-current-package () + "Return the Common Lisp package in the current context. +If `slime-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form." + (or slime-buffer-package + (save-restriction + (widen) + (slime-find-buffer-package)))) + +(defvar slime-find-buffer-package-function 'slime-search-buffer-package + "*Function to use for `slime-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun slime-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall slime-find-buffer-package-function)) + +(make-variable-buffer-local + (defvar slime-package-cache nil + "Cons of the form (buffer-modified-tick . package)")) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) + +(defun slime-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" + "\\([^)]+\\)[ \t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (match-string-no-properties 2))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +(defun slime-eval (sexp &optional package) + "Evaluate EXPR on the superior Lisp and return the result." + (when (null package) (setq package (slime-current-package))) + (let* ((tag (cl-gensym (format "slime-result-%d-" + (1+ (slime-continuation-counter))))) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (apply + #'funcall + (catch tag + (slime-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag slime-stack-eval-tags) + (error "Reply to canceled synchronous eval request tag=%S sexp=%S" + tag sexp)) + (throw tag (list #'identity value))) + ((:abort _condition) + (throw tag (list #'error "Synchronous Lisp Evaluation aborted")))) + (let ((debug-on-quit t) + (inhibit-quit nil) + (conn (slime-connection))) + (while t + (unless (eq (process-status conn) 'open) + (error "Lisp connection closed unexpectedly")) + (accept-process-output nil 0.01))))))) + +(defun slime-eval-async (sexp &optional cont package) + "Evaluate EXPR on the superior Lisp and call CONT with the result." + (declare (indent 1)) + (slime-rex (cont (buffer (current-buffer))) + (sexp (or package (slime-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:abort condition) + (message "Evaluation aborted on %s." condition))) + ;; Guard against arbitrary return values which once upon a time + ;; showed up in the minibuffer spuriously (due to a bug in + ;; slime-autodoc.) If this ever happens again, returning the + ;; following will make debugging much easier: + :slime-eval-async) + +;;; These functions can be handy too: + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (not (null slime-net-processes))) + +(defun slime-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (slime-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[slime]")))) + +;; UNUSED +(defun slime-debugged-connection-p (conn) + ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T), + ;; but an SLDB buffer may exist without having continuations + ;; attached to it, e.g. the one resulting from `slime-interrupt'. + (cl-loop for b in (sldb-buffers) + thereis (with-current-buffer b + (eq slime-buffer-connection conn)))) + +(defun slime-busy-p (&optional conn) + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sldb-debugged-continuations (or conn (slime-connection))))) + (cl-remove-if (lambda (id) + (memq id debugged)) + (slime-rex-continuations) + :key #'car))) + +(defun slime-sync () + "Block until the most recent request has finished." + (when (slime-rex-continuations) + (let ((tag (caar (slime-rex-continuations)))) + (while (cl-find tag (slime-rex-continuations) :key #'car) + (accept-process-output nil 0.1))))) + +(defun slime-ping () + "Check that communication works." + (interactive) + (message "%s" (slime-eval "PONG"))) + +;;;;; Protocol event handler (cl-the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(slime-def-connection-var slime-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(slime-def-connection-var slime-continuation-counter 0 + "Continuation serial number counter.") + +(defvar slime-event-hooks) + +(defun slime-dispatch-event (event &optional process) + (let ((slime-dispatching-connection (or process (slime-connection)))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (slime-dcase event + ((:emacs-rex form package thread continuation) + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (slime-display-oneliner "; pipelined request... %S" form)) + (let ((id (cl-incf (slime-continuation-counter)))) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)) + (push (cons id continuation) (slime-rex-continuations)) + (slime--recompute-modelines))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (slime--recompute-modelines) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level &optional select) + (cl-assert thread) + (sldb-activate thread level select)) + ((:debug thread level condition restarts frames conts) + (cl-assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (cl-assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:channel-send id msg) + (slime-channel-send (or (slime-find-channel id) + (error "Invalid channel id: %S %S" id msg)) + msg)) + ((:emacs-channel-send id msg) + (slime-send `(:emacs-channel-send ,id ,msg))) + ((:read-from-minibuffer thread tag prompt initial-value) + (slime-read-from-minibuffer-for-swank thread tag prompt + initial-value)) + ((:y-or-n-p thread tag question) + (slime-y-or-n-p thread tag question)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:eval-no-wait form) + (slime-check-eval-in-emacs-enabled) + (eval (read form))) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (slime-eval-for-lisp thread tag form-string)) + ((:ed-rpc-no-wait fn-name &rest args) + (let ((fn (intern-soft fn-name))) + (slime-check-rpc-allowed fn) + (apply fn args))) + ((:ed-rpc thread tag fn-name &rest args) + (slime-rpc-from-lisp thread tag (intern-soft fn-name) args)) + ((:emacs-return thread tag value) + (slime-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (slime-ed what)) + ((:inspect what thread tag) + (let ((hook (when (and thread tag) + (slime-curry #'slime-send + `(:emacs-return ,thread ,tag nil))))) + (slime-open-inspector what nil hook))) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (cl-assert thread) + (message "%s" message)) + ((:ping thread tag) + (slime-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "Invalid protocol message:\n%s\n\n%s" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")) + ((:invalid-rpc id message) + (setf (slime-rex-continuations) + (cl-remove id (slime-rex-continuations) :key #'car)) + (error "Invalid rpc: %s" message)) + ((:emacs-skipped-packet _pkg)) + ((:test-delay seconds) ; for testing only + (sit-for seconds)))))) + +(defun slime-send (sexp) + "Send SEXP directly over the wire on the current connection." + (slime-net-send sexp (slime-connection))) + +(defun slime-reset () + "Clear all pending continuations and erase connection buffer." + (interactive) + (setf (slime-rex-continuations) '()) + (mapc #'kill-buffer (sldb-buffers)) + (slime-with-connection-buffer () + (erase-buffer))) + +(defun slime-send-sigint () + (interactive) + (signal-process (slime-pid) 'SIGINT)) + +;;;;; Channels + +;;; A channel implements a set of operations. Those operations can be +;;; invoked by sending messages to the channel. Channels are used for +;;; protocols which can't be expressed naturally with RPCs, e.g. for +;;; streaming data over the wire. +;;; +;;; A channel can be "remote" or "local". Remote channels are +;;; represented by integers. Local channels are structures. Messages +;;; sent to a closed (remote) channel are ignored. + +(slime-def-connection-var slime-channels '() + "Alist of the form (ID . CHANNEL).") + +(slime-def-connection-var slime-channels-counter 0 + "Channel serial number counter.") + +(cl-defstruct (slime-channel (:conc-name slime-channel.) + (:constructor + slime-make-channel% (operations name id plist))) + operations name id plist) + +(defun slime-make-channel (operations &optional name) + (let* ((id (cl-incf (slime-channels-counter))) + (ch (slime-make-channel% operations name id nil))) + (push (cons id ch) (slime-channels)) + ch)) + +(defun slime-close-channel (channel) + (setf (slime-channel.operations channel) 'closed-channel) + (let ((probe (assq (slime-channel.id channel) (slime-channels)))) + (cond (probe (setf (slime-channels) (delete probe (slime-channels)))) + (t (error "Invalid channel: %s" channel))))) + +(defun slime-find-channel (id) + (cdr (assq id (slime-channels)))) + +(defun slime-channel-send (channel message) + (apply (or (gethash (car message) (slime-channel.operations channel)) + (error "Unsupported operation: %S %S" message channel)) + channel (cdr message))) + +(defun slime-channel-put (channel prop value) + (setf (slime-channel.plist channel) + (plist-put (slime-channel.plist channel) prop value))) + +(defun slime-channel-get (channel prop) + (plist-get (slime-channel.plist channel) prop)) + +(eval-and-compile + (defun slime-channel-method-table-name (type) + (intern (format "slime-%s-channel-methods" type)))) + +(defmacro slime-define-channel-type (name) + (declare (indent defun)) + (let ((tab (slime-channel-method-table-name name))) + `(progn + (defvar ,tab) + (setq ,tab (make-hash-table :size 10))))) + +(defmacro slime-define-channel-method (type method args &rest body) + (declare (indent 3) (debug (&define name sexp lambda-list + def-body))) + `(puthash ',method + (lambda (self . ,args) . ,body) + ,(slime-channel-method-table-name type))) + +(defun slime-send-to-remote-channel (channel-id msg) + (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) + +;;;;; Event logging to *slime-events* +;;; +;;; The *slime-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + +(defvar slime-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *slime-events*.") + +(defvar slime-event-buffer-name (slime-buffer-name :events) + "The name of the slime event buffer.") + +(defun slime-log-event (event) + "Record the fact that EVENT occurred." + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (slime-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun slime-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun slime-events-buffer () + "Return or create the event log buffer." + (or (get-buffer slime-event-buffer-name) + (let ((buffer (get-buffer-create slime-event-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when slime-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + + +;;;;; Cleanup after a quit + +(defun slime-restart-inferior-lisp () + "Kill and restart the Lisp subprocess." + (interactive) + (cl-assert (slime-inferior-process) () "No inferior lisp process") + (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t)) + +(defun slime-restart-sentinel (process _message) + "Restart the inferior lisp process. +Also rearrange windows." + (cl-assert (process-status process) 'closed) + (let* ((proc (slime-inferior-process process)) + (args (slime-inferior-lisp-args proc)) + (buffer (buffer-name (process-buffer proc))) + ;;(buffer-window (get-buffer-window buffer)) + (new-proc (slime-start-lisp (plist-get args :program) + (plist-get args :program-args) + (plist-get args :env) + nil + buffer))) + (slime-net-close process) + (slime-inferior-connect new-proc args) + (switch-to-buffer buffer) + (goto-char (point-max)))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar slime-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defvar slime-before-compile-functions nil + "A list of function called before compiling a buffer or region. +The function receive two arguments: the beginning and the end of the +region that will be compiled.") + +;; FIXME: remove some of the options +(defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log + "Hook called with a list of compiler notes after a compilation." + :group 'slime-mode + :type 'hook + :options '(slime-maybe-show-compilation-log + slime-create-compilation-log + slime-show-compilation-log + slime-maybe-list-compiler-notes + slime-list-compiler-notes + slime-maybe-show-xrefs-for-notes + slime-goto-first-note)) + +;; FIXME: I doubt that anybody uses this directly and it seems to be +;; only an ugly way to pass arguments. +(defvar slime-compilation-policy nil + "When non-nil compile with these optimization settings.") + +(defun slime-compute-policy (arg) + "Return the policy for the prefix argument ARG." + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) + (let ((n (prefix-numeric-value arg))) + (cond ((not arg) slime-compilation-policy) + ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) + ((eq arg '-) `((cl:speed . 3))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) + +(cl-defstruct (slime-compilation-result + (:type list) + (:conc-name slime-compilation-result.) + (:constructor nil) + (:copier nil)) + tag notes successp duration loadp faslfile) + +(defvar slime-last-compilation-result nil + "The result of the most recently issued compilation.") + +(defun slime-compiler-notes () + "Return all compiler notes, warnings, and errors." + (slime-compilation-result.notes slime-last-compilation-result)) + +(defun slime-compile-and-load-file (&optional policy) + "Compile and load the buffer's file and highlight compiler notes. + +With (positive) prefix argument the file is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`slime-next-note' and `slime-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive "P") + (slime-compile-file t (slime-compute-policy policy))) + +(defcustom slime-compile-file-options '() + "Plist of additional options that C-c C-k should pass to Lisp. +Currently only :fasl-directory is supported." + :group 'slime-lisp + :type '(plist :key-type symbol :value-type (file :must-match t))) + +(defun slime-compile-file (&optional load policy) + "Compile current buffer's file and highlight resulting compiler notes. + +See `slime-compile-and-load-file' for further details." + (interactive) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (check-parens) + (slime--maybe-save-buffer) + (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) + (let ((file (slime-to-lisp-filename (buffer-file-name))) + (options (slime-simplify-plist `(,@slime-compile-file-options + :policy ,policy)))) + (slime-eval-async + `(swank:compile-file-for-emacs ,file ,(if load t nil) + . ,(slime-hack-quotes options)) + #'slime-compilation-finished) + (message "Compiling %s..." file))) + +;; FIXME: compilation-save-buffers-predicate was introduced in 24.1 +(defun slime--maybe-save-buffer () + (let ((slime--this-buffer (current-buffer))) + (save-some-buffers (not compilation-ask-about-save) + (lambda () (eq (current-buffer) slime--this-buffer))))) + +(defun slime-hack-quotes (arglist) + ;; eval is the wrong primitive, we really want funcall + (cl-loop for arg in arglist collect `(quote ,arg))) + +(defun slime-simplify-plist (plist) + (cl-loop for (key val) on plist by #'cddr + append (cond ((null val) '()) + (t (list key val))))) + +(defun slime-compile-defun (&optional raw-prefix-arg) + "Compile the current toplevel form. + +With (positive) prefix argument the form is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign." + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (if (use-region-p) + (slime-compile-region (region-beginning) (region-end)) + (apply #'slime-compile-region (slime-region-for-defun-at-point))))) + +(defun slime-compile-region (start end) + "Compile the region." + (interactive "r") + ;; Check connection before running hooks things like + ;; slime-flash-region don't make much sense if there's no connection + (slime-connection) + (slime-flash-region start end) + (run-hook-with-args 'slime-before-compile-functions start end) + (slime-compile-string (buffer-substring-no-properties start end) start)) + +(defun slime-flash-region (start end &optional timeout) + "Temporarily highlight region from START to END." + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face 'secondary-selection) + (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) + +(defun slime-compile-string (string start-offset) + (let* ((line (save-excursion + (goto-char start-offset) + (list (line-number-at-pos) (1+ (current-column))))) + (position `((:position ,start-offset) (:line ,@line)))) + (slime-eval-async + `(swank:compile-string-for-emacs + ,string + ,(buffer-name) + ',position + ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name))) + ',slime-compilation-policy) + #'slime-compilation-finished))) + +(defcustom slime-load-failed-fasl 'ask + "Which action to take when COMPILE-FILE set FAILURE-P to T. +NEVER doesn't load the fasl +ALWAYS loads the fasl +ASK asks the user." + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-load-failed-fasl-p () + (cl-ecase slime-load-failed-fasl + (never nil) + (always t) + (ask (y-or-n-p "Compilation failed. Load fasl file anyway? ")))) + +(defun slime-compilation-finished (result) + (with-struct (slime-compilation-result. notes duration successp + loadp faslfile) result + (setf slime-last-compilation-result result) + (slime-show-note-counts notes duration (cond ((not loadp) successp) + (t (and faslfile successp)))) + (when slime-highlight-compiler-notes + (slime-highlight-notes notes)) + (run-hook-with-args 'slime-compilation-finished-hook notes) + (when (and loadp faslfile + (or successp + (slime-load-failed-fasl-p))) + (slime-eval-async `(swank:load-file ,faslfile))))) + +(defun slime-show-note-counts (notes secs successp) + (message (concat + (cond (successp "Compilation finished") + (t (slime-add-face 'font-lock-warning-face + "Compilation failed"))) + (if (null notes) ". (No warnings)" ": ") + (mapconcat + (lambda (messages) + (cl-destructuring-bind (sev . notes) messages + (let ((len (length notes))) + (format "%d %s%s" len (slime-severity-label sev) + (if (= len 1) "" "s"))))) + (sort (slime-alistify notes #'slime-note.severity #'eq) + (lambda (x y) (slime-severity< (car y) (car x)))) + " ") + (if secs (format " [%.2f secs]" secs))))) + +(defun slime-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (slime-remove-old-overlays) + (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))) + +(defvar slime-note-overlays '() + "List of overlays created by `slime-make-note-overlay'") + +(defun slime-remove-old-overlays () + "Delete the existing note overlays." + (mapc #'delete-overlay slime-note-overlays) + (setq slime-note-overlays '())) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (cl-remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +;;;;; Recompilation. + +;; FIXME: This whole idea is questionable since it depends so +;; crucially on precise source-locs. + +(defun slime-recompile-location (location) + (save-excursion + (slime-goto-source-location location) + (slime-compile-defun))) + +(defun slime-recompile-locations (locations cont) + (slime-eval-async + `(swank:compile-multiple-strings-for-emacs + ',(cl-loop for loc in locations collect + (save-excursion + (slime-goto-source-location loc) + (cl-destructuring-bind (start end) + (slime-region-for-defun-at-point) + (list (buffer-substring-no-properties start end) + (buffer-name) + (slime-current-package) + start + (if (buffer-file-name) + (slime-to-lisp-filename (buffer-file-name)) + nil))))) + ',slime-compilation-policy) + cont)) + + +;;;;; Merging together compiler notes in the same location. + +(defun slime-merge-notes-for-display (notes) + "Merge together notes that refer to the same location. +This operation is \"lossy\" in the broad sense but not for display purposes." + (mapcar #'slime-merge-notes + (slime-group-similar 'slime-notes-in-same-location-p notes))) + +(defun slime-merge-notes (notes) + "Merge NOTES together. Keep the highest severity, concatenate the messages." + (let* ((new-severity (cl-reduce #'slime-most-severe notes + :key #'slime-note.severity)) + (new-message (mapconcat #'slime-note.message notes "\n"))) + (let ((new-note (cl-copy-list (car notes)))) + (setf (cl-getf new-note :message) new-message) + (setf (cl-getf new-note :severity) new-severity) + new-note))) + +(defun slime-notes-in-same-location-p (a b) + (equal (slime-note.location a) (slime-note.location b))) + + +;;;;; Compiler notes list + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun slime-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (cl-getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (list (format "%s: %s" + (cl-getf note :severity) + (slime-one-line-ify (cl-getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (cl-acons fn (list node) xrefs)))))) + xrefs)) + +(defun slime-maybe-show-xrefs-for-notes (notes) + "Show the compiler notes NOTES if they come from more than one file." + (let ((xrefs (slime-xrefs-for-notes notes))) + (when (slime-length> xrefs 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-current-package))))) + +(defun slime-note-has-location-p (note) + (not (eq ':error (car (slime-note.location note))))) + +(defun slime-redefinition-note-p (note) + (eq (slime-note.severity note) :redefinition)) + +(defun slime-create-compilation-log (notes) + "Create a buffer for `next-error' to use." + (with-current-buffer (get-buffer-create (slime-buffer-name :compilation)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (slime-insert-compilation-log notes) + (compilation-mode))) + +(defun slime-maybe-show-compilation-log (notes) + "Display the log on failed compilations or if NOTES is non-nil." + (slime-create-compilation-log notes) + (with-struct (slime-compilation-result. notes duration successp) + slime-last-compilation-result + (unless successp + (with-current-buffer (slime-buffer-name :compilation) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (insert "Compilation " (if successp "succeeded." "failed.")) + (goto-char (point-min)) + (display-buffer (current-buffer))))))) + +(defun slime-show-compilation-log (notes) + "Create and display the compilation log buffer." + (interactive (list (slime-compiler-notes))) + (slime-with-popup-buffer ((slime-buffer-name :compilation) + :mode 'compilation-mode) + (slime-insert-compilation-log notes))) + +(defun slime-insert-compilation-log (notes) + "Insert NOTES in format suitable for `compilation-mode'." + (cl-destructuring-bind (grouped-notes canonicalized-locs-table) + (slime-group-and-sort-notes notes) + (with-temp-message "Preparing compilation log..." + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ; inefficient font-lock-hook + (insert (format "cd %s\n%d compiler notes:\n\n" + default-directory (length notes))) + (dolist (notes grouped-notes) + (let ((loc (gethash (cl-first notes) canonicalized-locs-table)) + (start (point))) + (insert (slime-canonicalized-location-to-string loc) ":") + (slime-insert-note-group notes) + (insert "\n") + (slime-make-note-overlay (cl-first notes) start (1- (point)))))) + (set (make-local-variable 'compilation-skip-threshold) 0) + (setq next-error-last-buffer (current-buffer))))) + +(defun slime-insert-note-group (notes) + "Insert a group of compiler messages." + (insert "\n") + (dolist (note notes) + (insert " " (slime-severity-label (slime-note.severity note)) ": ") + (let ((start (point))) + (insert (slime-note.message note)) + (let ((ctx (slime-note.source-context note))) + (if ctx (insert "\n" ctx))) + (slime-indent-block start 4)) + (insert "\n"))) + +(defun slime-indent-block (start column) + "If the region back to START isn't a one-liner indent it." + (when (< start (line-beginning-position)) + (save-excursion + (goto-char start) + (insert "\n")) + (slime-indent-rigidly start (point) column))) + +(defun slime-canonicalized-location (location) + "Return a list (FILE LINE COLUMN) for slime-location LOCATION. +This is quite an expensive operation so use carefully." + (save-excursion + (slime-goto-location-buffer (slime-location.buffer location)) + (save-excursion + (slime-goto-source-location location) + (list (or (buffer-file-name) (buffer-name)) + (save-restriction + (widen) + (line-number-at-pos)) + (1+ (current-column)))))) + +(defun slime-canonicalized-location-to-string (loc) + (if loc + (cl-destructuring-bind (filename line col) loc + (format "%s:%d:%d" + (cond ((not filename) "") + ((let ((rel (file-relative-name filename))) + (if (< (length rel) (length filename)) + rel))) + (t filename)) + line col)) + (format "Unknown location"))) + +(defun slime-goto-note-in-compilation-log (note) + "Find `note' in the compilation log and display it." + (with-current-buffer (get-buffer (slime-buffer-name :compilation)) + (let ((pos + (save-excursion + (goto-char (point-min)) + (cl-loop for overlay = (slime-find-next-note) + while overlay + for other-note = (overlay-get overlay 'slime-note) + when (slime-notes-in-same-location-p note other-note) + return (overlay-start overlay))))) + (when pos + (slime--display-position pos nil 0))))) + +(defun slime-group-and-sort-notes (notes) + "First sort, then group NOTES according to their canonicalized locs." + (let ((locs (make-hash-table :test #'eq))) + (mapc (lambda (note) + (let ((loc (slime-note.location note))) + (when (slime-location-p loc) + (puthash note (slime-canonicalized-location loc) locs)))) + notes) + (list (slime-group-similar + (lambda (n1 n2) + (equal (gethash n1 locs nil) (gethash n2 locs t))) + (let* ((bottom most-negative-fixnum) + (+default+ (list "" bottom bottom))) + (sort notes + (lambda (n1 n2) + (cl-destructuring-bind ((filename1 line1 col1) + (filename2 line2 col2)) + (list (gethash n1 locs +default+) + (gethash n2 locs +default+)) + (cond ((string-lessp filename1 filename2) t) + ((string-lessp filename2 filename1) nil) + ((< line1 line2) t) + ((> line1 line2) nil) + (t (< col1 col2)))))))) + locs))) + +(defun slime-note.severity (note) + (plist-get note :severity)) + +(defun slime-note.message (note) + (plist-get note :message)) + +(defun slime-note.source-context (note) + (plist-get note :source-context)) + +(defun slime-note.location (note) + (plist-get note :location)) + +(defun slime-severity-label (severity) + (cl-subseq (symbol-name severity) 1)) + + +;;;;; Adding a single compiler note + +(defun slime-overlay-note (note) + "Add a compiler note to the buffer as an overlay. +If an appropriate overlay for a compiler note in the same location +already exists then the new information is merged into it. Otherwise a +new overlay is created." + (cl-multiple-value-bind (start end) (slime-choose-overlay-region note) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (overlay (slime-note-at-point))) + (if overlay + (slime-merge-note-into-overlay overlay severity message) + (slime-create-note-overlay note start end severity message)))))) + +(defun slime-make-note-overlay (note start end) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'slime-note note) + (push overlay slime-note-overlays) + overlay)) + +(defun slime-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (slime-make-note-overlay note start end))) + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value))) + (putp 'face (slime-severity-face severity)) + (putp 'severity severity) + (putp 'mouse-face 'highlight) + (putp 'help-echo message) + overlay))) + +;; XXX Obsolete due to `slime-merge-notes-for-display' doing the +;; work already -- unless we decide to put several sets of notes on a +;; buffer without clearing in between, which only this handles. +(defun slime-merge-note-into-overlay (overlay severity message) + "Merge another compiler note into an existing overlay. +The help text describes both notes, and the highest of the severities +is kept." + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value)) + (getp (name) `(overlay-get overlay ,name))) + (putp 'severity (slime-most-severe severity (getp 'severity))) + (putp 'face (slime-severity-face (getp 'severity))) + (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) + +(defun slime-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (slime-note.location note))) + (when location + (slime-dcase location + ((:error _)) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + ((eq (slime-note.severity note) :read-error) + (slime-choose-overlay-for-read-error location)) + ((equal pos '(:eof)) + (cl-values (1- (point-max)) (point-max))) + (t + (slime-choose-overlay-for-sexp location)))))))) + +(defun slime-choose-overlay-for-read-error (location) + (let ((pos (slime-location-offset location))) + (save-excursion + (goto-char pos) + (cond ((slime-symbol-at-point) + ;; package not found, &c. + (cl-values (slime-symbol-start-pos) (slime-symbol-end-pos))) + (t + (cl-values pos (1+ pos))))))) + +(defun slime-choose-overlay-for-sexp (location) + (slime-goto-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (slime-forward-sexp)) + (if (slime-same-line-p start (point)) + (cl-values start (point)) + (cl-values (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) + +(defun slime-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defvar slime-severity-face-plist + '(:error slime-error-face + :read-error slime-error-face + :warning slime-warning-face + :redefinition slime-style-warning-face + :style-warning slime-style-warning-face + :early-deprecation-warning slime-early-deprecation-warning-face + :late-deprecation-warning slime-late-deprecation-warning-face + :final-deprecation-warning slime-final-deprecation-warning-face + :note slime-note-face)) + +(defun slime-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (or (plist-get slime-severity-face-plist severity) + (error "No face for: %S" severity))) + +(defvar slime-severity-order + '(:note + :early-deprecation-warning :style-warning :redefinition + :late-deprecation-warning :final-deprecation-warning + :warning :error :read-error)) + +(defun slime-severity< (sev1 sev2) + "Return true if SEV1 is less severe than SEV2." + (< (cl-position sev1 slime-severity-order) + (cl-position sev2 slime-severity-order))) + +(defun slime-most-severe (sev1 sev2) + "Return the most servere of two conditions." + (if (slime-severity< sev1 sev2) sev2 sev1)) + +;; XXX: unused function +(defun slime-visit-source-path (source-path) + "Visit a full source path including the top-level form." + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (let ((source-path (cdr source-path))) + (when source-path + (down-list 1) + (slime-forward-source-path source-path)))) + +(defun slime-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (cl-loop for (count . more) on source-path + do (progn + (slime-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + + +;; FIXME: really fix this mess +;; FIXME: the check shouln't be done here anyway but by M-. itself. + +(defun slime-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun slime-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (slime-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (split-string (file-name-directory target-filename) + "/" t)) + (buffer-dirs (split-string (file-name-directory buffer-filename) + "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (cl-loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (cl-position target-dir buffer-dirs* + :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix + ; PUSH reversed for us! + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (cl-return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) + +(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (let ((base-dirs (split-string base-dirname "/" t)) + (contrast-dirs (split-string contrast-dirname "/" t))) + (with-temp-buffer + (cl-loop initially (insert (slime-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) + (cond ((not pos) + (slime-insert-propertized '(face highlight) base-dir) + (insert "/")) + (t + (insert (file-name-as-directory base-dir)) + (setq contrast-dirs + (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max))))) + +(defvar slime-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`slime-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (cl-the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun slime-maybe-warn-for-different-source-root (target-filename + buffer-filename) + (let ((guessed-target (slime-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (slime-message "Attention: This is `%s'." + (concat (slime-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename)))))) + +(defun slime-check-location-filename-sanity (filename) + (when slime-warn-when-possibly-tricked-by-M-. + (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) + (let ((target-filename (truename-safe filename)) + (buffer-filename (truename-safe (buffer-file-name)))) + (when (and target-filename + buffer-filename) + (slime-maybe-warn-for-different-source-root + target-filename buffer-filename)))))) + +(defun slime-check-location-buffer-name-sanity (buffer-name) + (slime-check-location-filename-sanity + (buffer-file-name (get-buffer buffer-name)))) + + + +(defun slime-goto-location-buffer (buffer) + (slime-dcase buffer + ((:file filename) + (let ((filename (slime-from-lisp-filename filename))) + (slime-check-location-filename-sanity filename) + (set-buffer (or (get-file-buffer filename) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect filename)))))) + ((:buffer buffer-name) + (slime-check-location-buffer-name-sanity buffer-name) + (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (slime-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) + ((:source-form string) + (set-buffer (get-buffer-create (slime-buffer-name :source))) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min)))))) + +(defun slime-goto-location-position (position) + (slime-dcase position + ((:position pos) + (goto-char 1) + (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos))))) + ((:offset start offset) + (goto-char start) + (forward-char offset)) + ((:line start &optional column) + (goto-char (point-min)) + (beginning-of-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (goto-char (point-min)) + (when (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" + (regexp-quote name)) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (goto-char (match-beginning 0))))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ((:eof) + (goto-char (point-max))))) + +(defun slime-eol-conversion-fixup (n) + ;; Return the number of \r\n eol markers that we need to cross when + ;; moving N chars forward. N is the number of chars but \r\n are + ;; counted as 2 separate chars. + (cl-case (coding-system-eol-type buffer-file-coding-system) + ((1) + (save-excursion + (cl-do ((pos (+ (point) n)) + (count 0 (1+ count))) + ((>= (point) pos) (1- count)) + (forward-line) + (cl-decf pos)))) + (t 0))) + +(defun slime-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) + +(defun slime-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[)\n \t]")) + (case-fold-search t)) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun slime-search-edit-path (edit-path) + "Move to EDIT-PATH starting at the current toplevel form." + (when edit-path + (unless (and (= (current-column) 0) + (looking-at "(")) + (beginning-of-defun)) + (slime-forward-source-path edit-path))) + +(defun slime-goto-source-location (location &optional noerror) + "Move to the source location LOCATION. Several kinds of locations +are supported: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:buffer-and-file ) + | (:source-form ) + | (:zip ) + + ::= (:position ) ; 1 based (for files) + | (:offset ) ; start+offset (for C-c C-c) + | (:line []) + | (:function-name ) + | (:source-path ) + | (:method . )" + (slime-dcase location + ((:location buffer _position _hints) + (slime-goto-location-buffer buffer) + (let ((pos (slime-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) + +(defun slime-location-offset (location) + "Return the position, as character number, of LOCATION." + (save-restriction + (widen) + (condition-case nil + (slime-goto-location-position + (slime-location.position location)) + (error (goto-char 0))) + (cl-destructuring-bind (&key snippet edit-path call-site align) + (slime-location.hints location) + (when snippet (slime-isearch snippet)) + (when edit-path (slime-search-edit-path edit-path)) + (when call-site (slime-search-call-site call-site)) + (when align + (slime-forward-sexp) + (beginning-of-sexp))) + (point))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun slime-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (slime-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (slime-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun slime-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (cl-loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (cl-case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (cl-return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes + +(defun slime-next-note () + "Go to and describe the next compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-next-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No next note.")))) + +(defun slime-previous-note () + "Go to and describe the previous compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-previous-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No previous note.")))) + +(defun slime-goto-first-note (&rest _) + "Go to the first note in the buffer." + (let ((point (point))) + (goto-char (point-min)) + (cond ((slime-find-next-note) + (slime-show-note (slime-note-at-point))) + (t (goto-char point))))) + +(defun slime-remove-notes () + "Remove compiler-note annotations from the current buffer." + (interactive) + (slime-remove-old-overlays)) + +(defun slime-show-note (overlay) + "Present the details of a compiler note to the user." + (slime-temporarily-highlight-note overlay) + (if (get-buffer-window (slime-buffer-name :compilation) t) + (slime-goto-note-in-compilation-log (overlay-get overlay 'slime-note)) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) "\"\"" message))))) + +;; FIXME: could probably use flash region +(defun slime-temporarily-highlight-note (overlay) + "Temporarily highlight a compiler note's overlay. +The highlighting is designed to both make the relevant source more +visible, and to highlight any further notes that are nested inside the +current one. + +The highlighting is automatically undone with a timer." + (run-with-timer 0.2 nil + #'overlay-put overlay 'face (overlay-get overlay 'face)) + (overlay-put overlay 'face 'slime-highlight-face)) + + +;;;;; Overlay lookup operations + +(defun slime-note-at-point () + "Return the overlay for a note starting at point, otherwise NIL." + (cl-find (point) (slime-note-overlays-at-point) + :key 'overlay-start)) + +(defun slime-note-overlay-p (overlay) + "Return true if OVERLAY represents a compiler note." + (overlay-get overlay 'slime-note)) + +(defun slime-note-overlays-at-point () + "Return a list of all note overlays that are under the point." + (cl-remove-if-not 'slime-note-overlay-p (overlays-at (point)))) + +(defun slime-find-next-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note nil #'slime-note-at-point)) + +(defun slime-find-previous-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note t #'slime-note-at-point)) + + +;;;; Arglist Display + +(defun slime-space (n) + "Insert a space and print some relevant information (function arglist). +Designed to be bound to the SPC key. Prefix argument can be used to insert +more than one space." + (interactive "p") + (self-insert-command n) + (slime-echo-arglist)) + +(put 'slime-space 'delete-selection t) ; for delete-section-mode & CUA + +(defun slime-echo-arglist () + (when (slime-background-activities-enabled-p) + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op + ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist)))))))) + +(defvar slime-operator-before-point-function 'slime-lisp-operator-before-point) + +(defun slime-operator-before-point () + (funcall slime-operator-before-point-function)) + +(defun slime-lisp-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-at-point)))) + +;;;; Completion + +;; FIXME: use this in Emacs 24 +;;(define-obsolete-function-alias slime-complete-symbol completion-at-point) + +(defalias 'slime-complete-symbol #'completion-at-point) +(make-obsolete 'slime-complete-symbol #'completion-at-point "2015-10-17") + +;; This is the function that we add to +;; `completion-at-point-functions'. For backward-compatibilty we look +;; at `slime-complete-symbol-function' first. The indirection through +;; `slime-completion-at-point-functions' is used so that users don't +;; have to set `completion-at-point-functions' in every slime-like +;; buffer. +(defun slime--completion-at-point () + (cond (slime-complete-symbol-function + slime-complete-symbol-function) + (t + (run-hook-with-args-until-success + 'slime-completion-at-point-functions)))) + +(defun slime-setup-completion () + (add-hook 'completion-at-point-functions #'slime--completion-at-point nil t)) + +(defun slime-simple-completion-at-point () + "Complete the symbol at point. +Perform completion similar to `elisp-completion-at-point'." + (let* ((end (point)) + (beg (slime-symbol-start-pos))) + (list beg end (completion-table-dynamic #'slime-simple-completions)))) + +(defun slime-filename-completion () + "If point is at a string starting with \", complete it as filename. +Return nil if point is not at filename." + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" + (max (point-min) (- (point) 1000)) + t)) + (let ((comint-completion-addsuffix '("/" . "\""))) + (comint-filename-completion)))) + +;; FIXME: for backward compatibility. Remove it one day +;; together with slime-complete-symbol-function. +(defun slime-simple-complete-symbol () + (let ((completion-at-point-functions '(slime-maybe-complete-as-filename + slime-simple-completion-at-point))) + (completion-at-point))) + +;; NOTE: the original idea was to bind this to TAB but that no longer +;; works as `completion-at-point' sets a transient keymap that +;; overrides TAB. So this is rather useless now. +(defun slime-indent-and-complete-symbol () + "Indent the current line and perform symbol completion. +First indent the line. If indenting doesn't move point, complete +the symbol. If there's no symbol at the point, show the arglist +for the most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (completion-at-point)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(make-obsolete 'slime-indent-and-complete-symbol + "Set tab-always-indent to 'complete." + "2015-10-18") + +(defvar slime-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" #'completion-at-point) + (define-key map "\M-\t" #'completion-at-point) + map) + "Minibuffer keymap used for reading CL expressions.") + +(defvar slime-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defun slime-minibuffer-setup-hook () + (cons (lexical-let ((package (slime-current-package)) + (connection (slime-connection))) + (lambda () + (setq slime-buffer-package package) + (setq slime-buffer-connection connection) + (set-syntax-table lisp-mode-syntax-table) + (slime-setup-completion))) + minibuffer-setup-hook)) + +(defun slime-read-from-minibuffer (prompt &optional initial-value history) + "Read a string from the minibuffer, prompting with PROMPT. +If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before +reading input. The result is a string (\"\" if no input was given)." + (let ((minibuffer-setup-hook (slime-minibuffer-setup-hook))) + (read-from-minibuffer prompt initial-value slime-minibuffer-map + nil (or history 'slime-minibuffer-history)))) + +(defun slime-bogus-completion-alist (list) + "Make an alist out of list. +The same elements go in the CAR, and nil in the CDR. To support the +apparently very stupid `try-completions' interface, that wants an +alist but ignores CDRs." + (mapcar (lambda (x) (cons x nil)) list)) + +(defun slime-simple-completions (prefix) + (cl-destructuring-bind (completions _partial) + (let ((slime-current-thread t)) + (slime-eval + `(swank:simple-completions ,(substring-no-properties prefix) + ',(slime-current-package)))) + completions)) + + +;;;; Edit definition + +(defun slime-push-definition-stack () + "Add point to find-tag-marker-ring." + (require 'etags) + (ring-insert find-tag-marker-ring (point-marker))) + +(defun slime-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (pop-tag-mark)) + +(cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list)) + dspec location) + +(cl-defstruct (slime-location (:conc-name slime-location.) (:type list) + (:constructor nil) + (:copier nil)) + tag buffer position hints) + +(defun slime-location-p (o) (and (consp o) (eq (car o) :location))) + +(defun slime-xref-has-location-p (xref) + (slime-location-p (slime-xref.location xref))) + +(defun make-slime-buffer-location (buffer-name position &optional hints) + `(:location (:buffer ,buffer-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +(defun make-slime-file-location (file-name position &optional hints) + `(:location (:file ,file-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +;;; The hooks are tried in order until one succeeds, otherwise the +;;; default implementation involving `slime-find-definitions-function' +;;; is used. The hooks are called with the same arguments as +;;; `slime-edit-definition'. +(defvar slime-edit-definition-hooks) + +(defun slime-edit-definition (&optional name where) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then the +function name is prompted." + (interactive (list (or (and (not current-prefix-arg) + (slime-symbol-at-point)) + (slime-read-symbol-name "Edit Definition of: ")))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (or (run-hook-with-args-until-success 'slime-edit-definition-hooks + name where) + (slime-edit-definition-cont (slime-find-definitions name) + name where))) + +(defun slime-edit-definition-cont (xrefs name where) + (cl-destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) + (cond ((null xrefs) + (error "No known definition for: %s (in %s)" + name (slime-current-package))) + (1loc + (slime-push-definition-stack) + (slime-pop-to-location (slime-xref.location (car xrefs)) where)) + ((slime-length= xrefs 1) ; ((:error "...")) + (error "%s" (cadr (slime-xref.location (car xrefs))))) + (t + (slime-push-definition-stack) + (slime-show-xrefs file-alist 'definition name + (slime-current-package)))))) + +(defvar slime-edit-uses-xrefs + '(:calls :macroexpands :binds :references :sets :specializes)) + +;;; FIXME. TODO: Would be nice to group the symbols (in each +;;; type-group) by their home-package. +(defun slime-edit-uses (symbol) + "Lookup all the uses of SYMBOL." + (interactive (list (slime-read-symbol-name "Edit Uses of: "))) + (slime-xrefs slime-edit-uses-xrefs + symbol + (lambda (xrefs type symbol package) + (cond + ((null xrefs) + (message "No xref information found for %s." symbol)) + ((and (slime-length= xrefs 1) ; one group + (slime-length= (cdar xrefs) 1)) ; one ref in group + (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) + (slime-push-definition-stack) + (slime-pop-to-location loc))) + (t + (slime-push-definition-stack) + (slime-show-xref-buffer xrefs type symbol package)))))) + +(defun slime-analyze-xrefs (xrefs) + "Find common filenames in XREFS. +Return a list (SINGLE-LOCATION FILE-ALIST). +SINGLE-LOCATION is true if all xrefs point to the same location. +FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." + (list (and xrefs + (let ((loc (slime-xref.location (car xrefs)))) + (and (slime-location-p loc) + (cl-every (lambda (x) (equal (slime-xref.location x) loc)) + (cdr xrefs))))) + (slime-alistify xrefs #'slime-xref-group #'equal))) + +(defun slime-xref-group (xref) + (cond ((slime-xref-has-location-p xref) + (slime-dcase (slime-location.buffer (slime-xref.location xref)) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#" + (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file _buffer filename) filename) + ((:source-form _) "(S-Exp)") + ((:zip _zip entry) entry))) + (t + "(No location)"))) + +(defun slime-pop-to-location (location &optional where) + (slime-goto-source-location location) + (let ((point (point))) + (cl-ecase where + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))) + (goto-char point))) + +(defun slime-postprocess-xref (original-xref) + "Process (for normalization purposes) an Xref comming directly +from SWANK before the rest of Slime sees it. In particular, +convert ETAGS based xrefs to actual file+position based +locations." + (if (not (slime-xref-has-location-p original-xref)) + (list original-xref) + (let ((loc (slime-xref.location original-xref))) + (slime-dcase (slime-location.buffer loc) + ((:etags-file tags-file) + (slime-dcase (slime-location.position loc) + ((:tag &rest tags) + (visit-tags-table tags-file) + (mapcar (lambda (xref) + (let ((old-dspec (slime-xref.dspec original-xref)) + (new-dspec (slime-xref.dspec xref))) + (setf (slime-xref.dspec xref) + (format "%s: %s" old-dspec new-dspec)) + xref)) + (cl-mapcan #'slime-etags-definitions tags))))) + (t + (list original-xref)))))) + +(defun slime-postprocess-xrefs (xrefs) + (cl-mapcan #'slime-postprocess-xref xrefs)) + +(defun slime-find-definitions (name) + "Find definitions for NAME." + (slime-postprocess-xrefs (funcall slime-find-definitions-function name))) + +(defun slime-find-definitions-rpc (name) + (slime-eval `(swank:find-definitions-for-emacs ,name))) + +(defun slime-edit-definition-other-window (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'window)) + +(defun slime-edit-definition-other-frame (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'frame)) + +(defun slime-edit-definition-with-etags (name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (let ((xrefs (slime-etags-definitions name))) + (cond (xrefs + (message "Using tag file...") + (slime-edit-definition-cont xrefs name nil)) + (t + (error "No known definition for: %s" name))))) + +(defun slime-etags-to-locations (name) + "Search for definitions matching `name' in the currently active +tags table. Return a possibly empty list of slime-locations." + (let ((locs '())) + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (goto-char (point-min)) + (while (search-forward name nil t) + (beginning-of-line) + (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (push `(:location (:file ,(expand-file-name (file-of-tag))) + (:line ,line) + (:snippet ,hint)) + locs)))))) + (nreverse locs)))) + +(defun slime-etags-definitions (name) + "Search definitions matching NAME in the tags file. +The result is a (possibly empty) list of definitions." + (mapcar (lambda (loc) + (make-slime-xref :dspec (cl-second (slime-location.hints loc)) + :location loc)) + (slime-etags-to-locations name))) + +;;;;; first-change-hook + +(defun slime-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (slime-background-activities-enabled-p)) + (let ((filename (slime-to-lisp-filename (buffer-file-name)))) + (slime-eval-async `(swank:buffer-first-change ,filename))))))) + +(defun slime-setup-first-change-hook () + (add-hook (make-local-variable 'first-change-hook) + 'slime-first-change-hook)) + +(add-hook 'slime-mode-hook 'slime-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun slime-lisp-readable-p (x) + (or (stringp x) + (memq x '(nil t)) + (integerp x) + (keywordp x) + (and (consp x) + (let ((l x)) + (while (consp l) + (slime-lisp-readable-p (car x)) + (setq l (cdr l))) + (slime-lisp-readable-p l))))) + +(defun slime--funcall-and-dispatch-result (thread tag fn &rest args) + (let ((ok nil) + (value nil) + (error nil)) + (unwind-protect + (condition-case err + (progn + (setq value (apply fn args)) + (setq ok t)) + ((debug error) + (setq error err))) + (let ((result (cond ((and ok + (not (slime-lisp-readable-p value))) + `(:unreadable ,(slime-prin1-to-string value))) + (ok `(:ok ,value)) + (error `(:error ,(symbol-name (car error)) + . ,(mapcar #'slime-prin1-to-string + (cdr error)))) + (t `(:abort))))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,result)))))) + +(defun slime-eval-for-lisp (thread tag form-string) + (slime--funcall-and-dispatch-result thread tag + (lambda (s) (eval (read s))) + form-string)) + +(defun slime-check-eval-in-emacs-enabled () + "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." + (unless slime-enable-evaluate-in-emacs + (error (concat "slime-eval-in-emacs disabled for security. " + "Set `slime-enable-evaluate-in-emacs' true to enable it.")))) + + +;;;; RPC from Lisp + +(defmacro defslimefun (name arglist &rest body) + "Define a function via `cl-defun' that can be invoked from SWANK." + `(progn + (put ',name 'slime-rpc t) + (cl-defun ,name ,arglist ,@body))) + +(defun slime-rpc-allowed-p (fn) + (get fn 'slime-rpc)) + +(defun slime-check-rpc-allowed (fn) + "Raise an error if FN does not denote a function defined via +`defslimefun'." + (unless (slime-rpc-allowed-p fn) + (error "Lisp tried to RPC `%s', but it wasn't defined via `defslimefun'." + fn))) + +(defun slime-rpc-from-lisp (thread tag fn args) + (if (not (slime-rpc-allowed-p fn)) + (slime-dispatch-event '(:ed-rpc-forbidden ,thread ,tag ,fn)) + (apply #'slime--funcall-and-dispatch-result thread tag fn args))) + + +;;;; `ED' + +(defvar slime-ed-frame nil + "The frame used by `slime-ed'.") + +(defcustom slime-ed-use-dedicated-frame t + "*When non-nil, `slime-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'slime-mode) + +(defun slime-ed (what) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (:filename FILENAME &key LINE COLUMN POSITION), + A function name (:function-name STRING) + nil. + +This is for use in the implementation of COMMON-LISP:ED." + (when slime-ed-use-dedicated-frame + (unless (and slime-ed-frame (frame-live-p slime-ed-frame)) + (setq slime-ed-frame (make-frame))) + (select-frame slime-ed-frame)) + (when what + (slime-dcase what + ((:filename file &key line column position bytep) + (find-file (slime-from-lisp-filename file)) + (when line (slime-goto-line line)) + (when column (move-to-column column)) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) + ((:function-name name) + (slime-edit-definition name))))) + +(defun slime-goto-line (line-number) + "Move to line LINE-NUMBER (1-based). +This is similar to `goto-line' but without pushing the mark and +the display stuff that we neither need nor want." + (cl-assert (= (buffer-size) (- (point-max) (point-min))) () + "slime-goto-line in narrowed buffer") + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun slime-y-or-n-p (thread tag question) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) + +(defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value) + (let ((answer (condition-case nil + (slime-read-from-minibuffer prompt initial-value) + (quit nil)))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) + +;;;; Interactive evaluation. + +(defun slime-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +Note: If a prefix argument is in effect then the result will be +inserted in the current buffer." + (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) + (cl-case current-prefix-arg + ((nil) + (slime-eval-with-transcript `(swank:interactive-eval ,string))) + ((-) + (slime-eval-save string)) + (t + (slime-eval-print string)))) + +(defvar slime-transcript-start-hook nil + "Hook run before start an evalution.") +(defvar slime-transcript-stop-hook nil + "Hook run after finishing a evalution.") + +(defun slime-display-eval-result (value) + (slime-message "%s" value)) + +(defun slime-eval-with-transcript (form) + "Eval FORM in Lisp. Display output, if any." + (run-hooks 'slime-transcript-start-hook) + (slime-rex () (form) + ((:ok value) + (run-hooks 'slime-transcript-stop-hook) + (slime-display-eval-result value)) + ((:abort condition) + (run-hooks 'slime-transcript-stop-hook) + (message "Evaluation aborted on %s." condition)))) + +(defun slime-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (push-mark) + (insert output value))))) + +(defun slime-eval-save (string) + "Evaluate STRING in Lisp and save the result in the kill ring." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (let ((string (concat output value))) + (kill-new string) + (message "Evaluation finished; pushed result to kill ring.")))))) + +(defun slime-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (slime-eval-async form (slime-rcurry #'slime-show-description + (slime-current-package)))) + +(defvar slime-description-autofocus nil + "If non-nil select description windows on display.") + +(defun slime-show-description (string package) + ;; So we can have one description buffer open per connection. Useful + ;; for comparing the output of DISASSEMBLE across implementations. + ;; FIXME: could easily be achieved with M-x rename-buffer + (let ((bufname (slime-buffer-name :description))) + (slime-with-popup-buffer (bufname :package package + :connection t + :select slime-description-autofocus) + (princ string) + (goto-char (point-min))))) + +(defun slime-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun slime-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-defun () + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval form))))) + +(defun slime-eval-region (start end) + "Evaluate region." + (interactive "r") + (slime-eval-with-transcript + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun slime-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (slime-eval-describe + `(swank:pprint-eval + ,(buffer-substring-no-properties start end)))) + +(defun slime-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (slime-eval-region (point-min) (point-max))) + +(defun slime-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (slime-last-expression))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form))) + +(defun slime-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) + +(defun slime-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (slime-last-expression))) + (insert "\n") + (slime-eval-print string)) + +;;;; Edit Lisp value +;;; +(defun slime-edit-value (form-string) + "\\\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[slime-edit-value-commit]." + (interactive + (list (slime-read-from-minibuffer "Edit value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:value-for-editing ,form-string) + (lexical-let ((form-string form-string) + (package (slime-current-package))) + (lambda (result) + (slime-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar slime-edit-form-string nil + "The form being edited by `slime-edit-value'.")) + +(define-minor-mode slime-edit-value-mode + "Mode for editing a Lisp value." + nil + " Edit-Value" + '(("\C-c\C-c" . slime-edit-value-commit))) + +(defun slime-edit-value-callback (form-string current-value package) + (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) + (buffer (slime-with-popup-buffer (name :package package + :connection t + :select t + :mode 'lisp-mode) + (slime-popup-buffer-mode -1) ; don't want binding of 'q' + (slime-mode 1) + (slime-edit-value-mode 1) + (setq slime-edit-form-string form-string) + (insert current-value) + (current-buffer)))) + (with-current-buffer buffer + (setq buffer-read-only nil) + (message "Type C-c C-c when done")))) + +(defun slime-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `slime-edit-value'.)" + (interactive) + (if (null slime-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (quit-window t)))))))) + +;;;; Tracing + +(defun slime-untrace-all () + "Untrace all functions." + (interactive) + (slime-eval `(swank:untrace-all))) + +(defun slime-toggle-trace-fdefinition (spec) + "Toggle trace." + (interactive (list (slime-read-from-minibuffer + "(Un)trace: " (slime-symbol-at-point)))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))) + + + +(defun slime-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Disassemble: "))) + (slime-eval-describe `(swank:disassemble-form ,(concat "'" symbol-name)))) + +(defun slime-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "fmakunbound: " t))) + (slime-eval-async `(swank:undefine-function ,symbol-name) + (lambda (result) (message "%s" result)))) + +(defun slime-unintern-symbol (symbol-name package) + "Unintern the symbol given with SYMBOL-NAME PACKAGE." + (interactive (list (slime-read-symbol-name "Unintern symbol: " t) + (slime-read-package-name "from package: " + (slime-current-package)))) + (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package) + (lambda (result) (message "%s" result)))) + +(defun slime-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (slime-read-package-name "Delete package: " + (slime-current-package)))) + (slime-eval-async `(cl:delete-package + (swank::guess-package ,package-name)))) + +(defun slime-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename)))) + (slime-eval-with-transcript `(swank:load-file ,lisp-filename)))) + +(defvar slime-change-directory-hooks nil + "Hook run by `slime-change-directory'. +The functions are called with the new (absolute) directory.") + +(defun slime-change-directory (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (let ((dir (expand-file-name directory))) + (prog1 (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))) + (slime-with-connection-buffer nil (cd-absolute dir)) + (run-hook-with-args 'slime-change-directory-hooks dir)))) + +(defun slime-cd (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (message "default-directory: %s" (slime-change-directory directory))) + +(defun slime-pwd () + "Show Lisp's default directory." + (interactive) + (message "Directory %s" (slime-eval `(swank:default-directory)))) + + +;;;; Profiling + +(defun slime-toggle-profile-fdefinition (fname-string) + "Toggle profiling for FNAME-STRING." + (interactive (list (slime-read-from-minibuffer + "(Un)Profile: " + (slime-symbol-at-point)))) + (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string) + (lambda (r) (message "%s" r)))) + +(defun slime-unprofile-all () + "Unprofile all functions." + (interactive) + (slime-eval-async '(swank:unprofile-all) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-report () + "Print profile report." + (interactive) + (slime-eval-with-transcript '(swank:profile-report))) + +(defun slime-profile-reset () + "Reset profile counters." + (interactive) + (slime-eval-async (slime-eval `(swank:profile-reset)) + (lambda (r) (message "%s" r)))) + +(defun slime-profiled-functions () + "Return list of names of currently profiled functions." + (interactive) + (slime-eval-async `(swank:profiled-functions) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-package (package callers methods) + "Profile all functions in PACKAGE. +If CALLER is non-nil names have counts of the most common calling +functions recorded. +If METHODS is non-nil, profile all methods of all generic function +having names in the given package." + (interactive (list (slime-read-package-name "Package: ") + (y-or-n-p "Record the most common callers? ") + (y-or-n-p "Profile methods? "))) + (slime-eval-async `(swank:swank-profile-package ,package ,callers ,methods) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-by-substring (substring &optional package) + "Profile all functions which names contain SUBSTRING. +If PACKAGE is NIL, then search in all packages." + (interactive (list + (slime-read-from-minibuffer + "Profile by matching substring: " + (slime-symbol-at-point)) + (slime-read-package-name "Package (RET for all packages): "))) + (let ((package (unless (equal package "") package))) + (slime-eval-async `(swank:profile-by-substring ,substring ,package) + (lambda (r) (message "%s" r)) ))) + +;;;; Documentation + +(defvar slime-documentation-lookup-function + 'slime-hyperspec-lookup) + +(defun slime-documentation-lookup () + "Generalized documentation lookup. Defaults to hyperspec lookup." + (interactive) + (call-interactively slime-documentation-lookup-function)) + +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (common-lisp-hyperspec-read-symbol-name + (slime-symbol-at-point)))) + (hyperspec-lookup symbol-name)) + +(defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-symbol ,symbol-name))) + +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name))) + +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol's function: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + +(defface slime-apropos-symbol + '((t (:inherit bold))) + "Face for the symbol name in Apropos output." + :group 'slime) + +(defface slime-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'slime) + +(defun slime-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun slime-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search." + (interactive + (if current-prefix-arg + (list (read-string "SLIME Apropos: ") + (y-or-n-p "External symbols only? ") + (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") nil pkg)) + (y-or-n-p "Case-sensitive? ")) + (list (read-string "SLIME Apropos: ") t nil nil))) + (let ((buffer-package (or package (slime-current-package)))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (slime-rcurry #'slime-show-apropos string buffer-package + (slime-apropos-summary string case-sensitive-p + package only-external-p))))) + +(defun slime-apropos-all () + "Shortcut for (slime-apropos nil nil)" + (interactive) + (slime-apropos (read-string "SLIME Apropos: ") nil nil)) + +(defun slime-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") (slime-current-package) pkg)) + current-prefix-arg)) + (slime-apropos "" (not internal) package)) + +(autoload 'apropos-mode "apropos") +(defun slime-show-apropos (plists string package summary) + (if (null plists) + (message "No apropos matches for %S" string) + (slime-with-popup-buffer ((slime-buffer-name :apropos) + :package package :connection t + :mode 'apropos-mode) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (slime-set-truncate-lines) + (slime-print-apropos plists) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min))))) + +(defvar slime-apropos-namespaces + '((:variable "Variable") + (:function "Function") + (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") + (:setf "Setf") + (:type "Type") + (:class "Class") + (:alien-type "Alien type") + (:alien-struct "Alien struct") + (:alien-union "Alien type") + (:alien-enum "Alien enum"))) + +(defun slime-print-apropos (plists) + (dolist (plist plists) + (let ((designator (plist-get plist :designator))) + (cl-assert designator) + (slime-insert-propertized `(face slime-apropos-symbol) designator)) + (terpri) + (cl-loop for (prop value) on plist by #'cddr + unless (eq prop :designator) do + (let ((namespace (cadr (or (assq prop slime-apropos-namespaces) + (error "Unknown property: %S" prop)))) + (start (point))) + (princ " ") + (slime-insert-propertized `(face slime-apropos-label) namespace) + (princ ": ") + (princ (cl-etypecase value + (string value) + ((member nil :not-documented) "(not documented)"))) + (add-text-properties + start (point) + (list 'type prop 'action 'slime-call-describer + 'button t 'apropos-label namespace + 'item (plist-get plist :designator))) + (terpri))))) + +(defun slime-call-describer (arg) + (let* ((pos (if (markerp arg) arg (point))) + (type (get-text-property pos 'type)) + (item (get-text-property pos 'item))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) + +(defun slime-info () + "Open Slime manual" + (interactive) + (let ((file (expand-file-name "doc/slime.info" slime-path))) + (if (file-exists-p file) + (info file) + (message "No slime.info, run `make slime.info' in %s" + (expand-file-name "doc/" slime-path))))) + + +;;;; XREF: cross-referencing + +(defvar slime-xref-mode-map) + +(define-derived-mode slime-xref-mode lisp-mode "Xref" + "slime-xref-mode: Major mode for cross-referencing. +\\\ +The most important commands: +\\[slime-xref-quit] - Dismiss buffer. +\\[slime-show-xref] - Display referenced source and keep xref window. +\\[slime-goto-xref] - Jump to referenced source and dismiss xref window. + +\\{slime-xref-mode-map} +\\{slime-popup-buffer-mode-map} +" + (slime-popup-buffer-mode) + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-goto-xref) + ((kbd "SPC") 'slime-goto-xref) + ("v" 'slime-show-xref) + ("n" 'slime-xref-next-line) + ("p" 'slime-xref-prev-line) + ("." 'slime-xref-next-line) + ("," 'slime-xref-prev-line) + ("\C-c\C-c" 'slime-recompile-xref) + ("\C-c\C-k" 'slime-recompile-all-xrefs) + ("\M-," 'slime-xref-retract) + ([remap next-line] 'slime-xref-next-line) + ([remap previous-line] 'slime-xref-prev-line) + ) + + +;;;;; XREF results buffer and window management + +(cl-defmacro slime-with-xref-buffer ((_xref-type _symbol &optional package) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (declare (indent 1)) + `(slime-with-popup-buffer ((slime-buffer-name :xref) + :package ,package + :connection t + :select t + :mode 'slime-xref-mode) + (slime-set-truncate-lines) + ,@body)) + +(defun slime-insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). +GROUP and LABEL are for decoration purposes. LOCATION is a +source-location." + (cl-loop for (group . refs) in xref-alist do + (slime-insert-propertized '(face bold) group "\n") + (cl-loop for (label location) in refs do + (slime-insert-propertized + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (slime-one-line-ify label) "\n"))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-delete-char 1)) + +(defun slime-xref-next-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location))) + +(defun slime-xref-prev-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location t))) + +(defun slime-xref-show-location (loc) + (cl-ecase (car loc) + (:location (slime-show-source-location loc nil 1)) + (:error (message "%s" (cadr loc))) + ((nil)))) + +(defvar slime-next-location-function nil + "Function to call for going to the next location.") + +(defvar slime-previous-location-function nil + "Function to call for going to the previous location.") + +(defvar slime-xref-last-buffer nil + "The most recent XREF results buffer. +This is used by `slime-goto-next-xref'") + +(defun slime-show-xref-buffer (xrefs _type _symbol package) + (slime-with-xref-buffer (_type _symbol package) + (slime-insert-xrefs xrefs) + (setq slime-next-location-function 'slime-goto-next-xref) + (setq slime-previous-location-function 'slime-goto-previous-xref) + (setq slime-xref-last-buffer (current-buffer)) + (goto-char (point-min)))) + +(defun slime-show-xrefs (xrefs type symbol package) + "Show the results of an XREF query." + (if (null xrefs) + (message "No references found for %s." symbol) + (slime-show-xref-buffer xrefs type symbol package))) + + +;;;;; XREF commands + +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls symbol)) + +(defun slime-calls-who (symbol) + "Show all known functions called by the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls-who symbol)) + +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref :references symbol)) + +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref :binds symbol)) + +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref :sets symbol)) + +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref :macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) + +;; FIXME: whats the call (slime-postprocess-xrefs result) good for? +(defun slime-xref (type symbol &optional continuation) + "Make an XREF request to Lisp." + (slime-eval-async + `(swank:xref ',type ',symbol) + (slime-rcurry (lambda (result type symbol package cont) + (slime-check-xref-implemented type result) + (let* ((_xrefs (slime-postprocess-xrefs result)) + (file-alist (cadr (slime-analyze-xrefs result)))) + (funcall (or cont 'slime-show-xrefs) + file-alist type symbol package))) + type + symbol + (slime-current-package) + continuation))) + +(defun slime-check-xref-implemented (type xrefs) + (when (eq xrefs :not-implemented) + (error "%s is not implemented yet on %s." + (slime-xref-type type) + (slime-lisp-implementation-name)))) + +(defun slime-xref-type (type) + (format "who-%s" (slime-cl-symbol-name type))) + +(defun slime-xrefs (types symbol &optional continuation) + "Make multiple XREF requests at once." + (slime-eval-async + `(swank:xrefs ',types ',symbol) + #'(lambda (result) + (funcall (or continuation + #'slime-show-xrefs) + (cl-loop for (key . val) in result + collect (cons (slime-xref-type key) val)) + types symbol (slime-current-package))))) + + +;;;;; XREF navigation + +(defun slime-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'slime-location) + (error "No reference at point.")))) + +(defun slime-xref-dspec-at-point () + (save-excursion + (beginning-of-line 1) + (with-syntax-table lisp-mode-syntax-table + (forward-sexp) ; skip initial whitespaces + (backward-sexp) + (slime-sexp-at-point)))) + +(defun slime-all-xrefs () + (let ((xrefs nil)) + (save-excursion + (goto-char (point-min)) + (while (zerop (forward-line 1)) + (let ((loc (get-text-property (point) 'slime-location))) + (when loc + (let* ((dspec (slime-xref-dspec-at-point)) + (xref (make-slime-xref :dspec dspec :location loc))) + (push xref xrefs)))))) + (nreverse xrefs))) + +(defun slime-goto-xref () + "Goto the cross-referenced location at point." + (interactive) + (slime-show-xref) + (quit-window)) + +(defun slime-show-xref () + "Display the xref at point in the other window." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-show-source-location location t 1))) + +(defun slime-goto-next-xref (&optional backward) + "Goto the next cross-reference location." + (if (not (buffer-live-p slime-xref-last-buffer)) + (error "No XREF buffer alive.") + (cl-destructuring-bind (location pos) + (with-current-buffer slime-xref-last-buffer + (list (slime-search-property 'slime-location backward) + (point))) + (cond ((slime-location-p location) + (slime-pop-to-location location) + ;; We do this here because changing the location can take + ;; a while when Emacs needs to read a file from disk. + (with-current-buffer slime-xref-last-buffer + (goto-char pos) + (slime-highlight-line 0.35))) + ((null location) + (message (if backward "No previous xref" "No next xref."))) + (t ; error location + (slime-goto-next-xref backward)))))) + +(defun slime-goto-previous-xref () + "Goto the previous cross-reference location." + (slime-goto-next-xref t)) + +(defun slime-search-property (prop &optional backward prop-value-fn) + "Search the next text range where PROP is non-nil. +Return the value of PROP. +If BACKWARD is non-nil, search backward. +If PROP-VALUE-FN is non-nil use it to extract PROP's value." + (let ((next-candidate (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (prop-value-fn (or prop-value-fn + (lambda () + (get-text-property (point) prop)))) + (start (point)) + (prop-value)) + (while (progn + (goto-char (funcall next-candidate (point) prop)) + (not (or (setq prop-value (funcall prop-value-fn)) + (eobp) + (bobp))))) + (cond (prop-value) + (t (goto-char start) nil)))) + +(defun slime-next-location () + "Go to the next location, depending on context. +When displaying XREF information, this goes to the next reference." + (interactive) + (when (null slime-next-location-function) + (error "No context for finding locations.")) + (funcall slime-next-location-function)) + +(defun slime-previous-location () + "Go to the previous location, depending on context. +When displaying XREF information, this goes to the previous reference." + (interactive) + (when (null slime-previous-location-function) + (error "No context for finding locations.")) + (funcall slime-previous-location-function)) + +(defun slime-recompile-xref (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((location (slime-xref-location-at-point)) + (dspec (slime-xref-dspec-at-point))) + (slime-recompile-locations + (list location) + (slime-rcurry #'slime-xref-recompilation-cont + (list dspec) (current-buffer)))))) + +(defun slime-recompile-all-xrefs (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((dspecs) (locations)) + (dolist (xref (slime-all-xrefs)) + (when (slime-xref-has-location-p xref) + (push (slime-xref.dspec xref) dspecs) + (push (slime-xref.location xref) locations))) + (slime-recompile-locations + locations + (slime-rcurry #'slime-xref-recompilation-cont + dspecs (current-buffer)))))) + +(defun slime-xref-recompilation-cont (results dspecs buffer) + ;; Extreme long-windedness to insert status of recompilation; + ;; sometimes Elisp resembles more of an Ewwlisp. + + ;; FIXME: Should probably throw out the whole recompilation cruft + ;; anyway. -- helmut + ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt + (with-current-buffer buffer + (slime-compilation-finished (slime-aggregate-compilation-results results)) + (save-excursion + (slime-xref-insert-recompilation-flags + dspecs (cl-loop for r in results collect + (or (slime-compilation-result.successp r) + (and (slime-compilation-result.notes r) + :complained))))))) + +(defun slime-aggregate-compilation-results (results) + `(:compilation-result + ,(cl-reduce #'append (mapcar #'slime-compilation-result.notes results)) + ,(cl-every #'slime-compilation-result.successp results) + ,(cl-reduce #'+ (mapcar #'slime-compilation-result.duration results)))) + +(defun slime-xref-insert-recompilation-flags (dspecs compilation-results) + (let* ((buffer-read-only nil) + (max-column (slime-column-max))) + (goto-char (point-min)) + (cl-loop for dspec in dspecs + for result in compilation-results + do (save-excursion + (cl-loop for dspec2 = (progn (search-forward dspec) + (slime-xref-dspec-at-point)) + until (equal dspec2 dspec)) + (end-of-line) ; skip old status information. + (insert-char ?\ (1+ (- max-column (current-column)))) + (insert (format "[%s]" + (cl-case result + ((t) :success) + ((nil) :failure) + (t result)))))))) + + +;;;; Macroexpansion + +(define-minor-mode slime-macroexpansion-minor-mode + "SLIME mode for macroexpansion" + nil + " Macroexpand" + '(("g" . slime-macroexpand-again))) + +(cl-macrolet ((remap (from to) + `(dolist (mapping + (where-is-internal ,from slime-mode-map)) + (define-key slime-macroexpansion-minor-mode-map + mapping ,to)))) + (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) + (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) + (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) + (remap 'slime-expand-1 + 'slime-expand-1-inplace) + (remap 'advertised-undo 'slime-macroexpand-undo) + (remap 'undo 'slime-macroexpand-undo)) + +(defun slime-macroexpand-undo (&optional arg) + (interactive) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) + (let ((inhibit-read-only t)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo-only arg)))) + +(defvar slime-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") + +(defun slime-eval-macroexpand (expander &optional string) + (let ((string (or string (slime-sexp-at-point-or-error)))) + (setq slime-eval-macroexpand-expression `(,expander ,string)) + (slime-eval-async slime-eval-macroexpand-expression + #'slime-initialize-macroexpansion-buffer))) + +(defun slime-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (slime-eval-async slime-eval-macroexpand-expression + (slime-rcurry #'slime-initialize-macroexpansion-buffer + (current-buffer)))) + +(defun slime-initialize-macroexpansion-buffer (expansion &optional buffer) + (pop-to-buffer (or buffer (slime-create-macroexpansion-buffer))) + (setq buffer-undo-list nil) ; Get rid of undo information from + ; previous expansions. + (let ((inhibit-read-only t) + (buffer-undo-list t)) ; Make the initial insertion not be undoable. + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (font-lock-fontify-buffer))) + +(defun slime-create-macroexpansion-buffer () + (let ((name (slime-buffer-name :macroexpansion))) + (slime-with-popup-buffer (name :package t :connection t + :mode 'lisp-mode) + (slime-mode 1) + (slime-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) + (current-buffer)))) + +(defun slime-eval-macroexpand-inplace (expander) + "Substitute the sexp at point with its macroexpansion. + +NB: Does not affect slime-eval-macroexpand-expression" + (interactive) + (let* ((bounds (or (slime-bounds-of-sexp-at-point) + (user-error "No sexp at point")))) + (lexical-let* ((start (copy-marker (car bounds))) + (end (copy-marker (cdr bounds))) + (point (point)) + (package (slime-current-package)) + (buffer (current-buffer))) + (slime-eval-async + `(,expander ,(buffer-substring-no-properties start end)) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (slime-insert-indented expansion) + (goto-char point)))))))) + +(defun slime-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-all () + "Display the recursively macro expanded sexp starting at +point." + (interactive) + (slime-eval-macroexpand 'swank:swank-macroexpand-all)) + +(defun slime-macroexpand-all-inplace () + "Display the recursively macro expanded sexp starting at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all)) + +(defun slime-compiler-macroexpand-1 (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-compiler-macroexpand-1-inplace (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-expand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND. If the form denotes a +compiler macro, SWANK/BACKEND:COMPILER-MACROEXPAND or +SWANK/BACKEND:COMPILER-MACROEXPAND-1 are used instead." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-expand-1-inplace (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-format-string-expand (&optional string) + "Expand the format-string at point and display it." + (interactive (list (or (and (not current-prefix-arg) + (slime-string-at-point)) + (slime-read-from-minibuffer "Expand format: " + (slime-string-at-point))))) + (slime-eval-macroexpand 'swank:swank-format-string-expand string)) + + +;;;; Subprocess control + +(defun slime-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) + (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) + +(defun slime-quit () + (error "Not implemented properly. Use `slime-interrupt' instead.")) + +(defun slime-quit-lisp (&optional kill) + "Quit lisp, kill the inferior process and associated buffers." + (interactive "P") + (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill)) + +(defun slime-quit-lisp-internal (connection sentinel kill) + (let ((slime-dispatching-connection connection)) + (slime-eval-async '(swank:quit-lisp)) + (let* ((process (slime-inferior-process connection))) + (set-process-filter connection nil) + (set-process-sentinel connection sentinel) + (when (and kill process) + (sleep-for 0.2) + (unless (memq (process-status process) '(exit signal)) + (kill-process process)))))) + +(defun slime-quit-sentinel (process _message) + (cl-assert (process-status process) 'closed) + (let* ((inferior (slime-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (slime-net-close process) + (message "Connection closed."))) + + +;;;; Debugger (SLDB) + +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + +(defcustom sldb-initial-restart-limit 6 + "Maximum number of restarts to display initially." + :group 'slime-debugger + :type 'integer) + + +;;;;; Local variables in the debugger buffer + +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + (defvar sldb-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sldb-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sldb-backtrace-start-marker nil + "Marker placed at the first frame of the backtrace.") + + (defvar sldb-restart-list-start-marker nil + "Marker placed at the first restart in the restart list.") + + (defvar sldb-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLDB macros + +;; some macros that we need to define before the first use + +(defmacro sldb-in-face (name string) + "Return STRING propertised with face sldb-NAME-face." + (declare (indent 1)) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (cl-gensym "string"))) + `(let ((,var ,string)) + (slime-add-face ',facename ,var) + ,var))) + + +;;;;; sldb-mode + +(defvar sldb-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This enables autodoc-mode to match + ;; # actual arguments in the backtraces with formal + ;; arguments of the function. (For Lisp mode, this is not + ;; desirable, since we do not wish to get a mismatched paren + ;; highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + table) + "Syntax table for SLDB mode.") + +(define-derived-mode sldb-mode fundamental-mode "sldb" + "Superior lisp debugger mode. +In addition to ordinary SLIME commands, the following are +available:\\ + +Commands to examine the selected frame: + \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \\[sldb-show-source] - view source for the frame + \\[sldb-eval-in-frame] - eval in frame + \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \\[sldb-disassemble] - disassemble + \\[sldb-inspect-in-frame] - inspect + +Commands to invoke restarts: + \\[sldb-quit] - quit + \\[sldb-abort] - abort + \\[sldb-continue] - continue + \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts + \\[sldb-invoke-restart-by-name] - invoke restart by name + +Commands to navigate frames: + \\[sldb-down] - down + \\[sldb-up] - up + \\[sldb-details-down] - down, with details + \\[sldb-details-up] - up, with details + \\[sldb-cycle] - cycle between restarts & backtrace + \\[sldb-beginning-of-backtrace] - beginning of backtrace + \\[sldb-end-of-backtrace] - end of backtrace + +Miscellaneous commands: + \\[sldb-restart-frame] - restart frame + \\[sldb-return-from-frame] - return from frame + \\[sldb-step] - step + \\[sldb-break-with-default-debugger] - switch to native debugger + \\[sldb-break-with-system-debugger] - switch to system debugger (gdb) + \\[slime-interactive-eval] - eval + \\[sldb-inspect-condition] - inspect signalled condition + +Full list of commands: + +\\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table sldb-mode-syntax-table) + (slime-set-truncate-lines) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection))) + +(set-keymap-parent sldb-mode-map slime-parent-map) + +(slime-define-keys sldb-mode-map + + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([return] 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ([follow-link] 'mouse-face) + ("\C-i" 'sldb-cycle) + ("h" 'describe-mode) + ("v" 'sldb-show-source) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("<" 'sldb-beginning-of-backtrace) + (">" 'sldb-end-of-backtrace) + ("t" 'sldb-toggle-details) + ("r" 'sldb-restart-frame) + ("I" 'sldb-invoke-restart-by-name) + ("R" 'sldb-return-from-frame) + ("c" 'sldb-continue) + ("s" 'sldb-step) + ("x" 'sldb-next) + ("o" 'sldb-out) + ("b" 'sldb-break-on-return) + ("a" 'sldb-abort) + ("q" 'sldb-quit) + ("A" 'sldb-break-with-system-debugger) + ("B" 'sldb-break-with-default-debugger) + ("P" 'sldb-print-condition) + ("C" 'sldb-inspect-condition) + (":" 'slime-interactive-eval) + ("\C-c\C-c" 'sldb-recompile-frame-source)) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(dotimes (number 10) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + (eval `(defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number))) + (define-key sldb-mode-map (number-to-string number) fname))) + + +;;;;; SLDB buffer creation & update + +(defun sldb-buffers (&optional connection) + "Return a list of all sldb buffers (belonging to CONNECTION.)" + (if connection + (slime-filter-buffers (lambda () + (and (eq slime-buffer-connection connection) + (eq major-mode 'sldb-mode)))) + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))) + +(defun sldb-find-buffer (thread &optional connection) + (let ((connection (or connection (slime-connection)))) + (cl-find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq slime-buffer-connection connection) + (eq slime-current-thread thread)))) + (sldb-buffers)))) + +(defun sldb-get-default-buffer () + "Get a sldb buffer. +The chosen buffer the default connection's it if exists." + (car (sldb-buffers slime-default-connection))) + +(defun sldb-get-buffer (thread &optional connection) + "Find or create a sldb-buffer for THREAD." + (let ((connection (or connection (slime-connection)))) + (or (sldb-find-buffer thread connection) + (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread))) + (with-current-buffer (generate-new-buffer name) + (setq slime-buffer-connection connection + slime-current-thread thread) + (current-buffer)))))) + +(defun sldb-debugged-continuations (connection) + "Return the all debugged continuations for CONNECTION across SLDB buffers." + (cl-loop for b in (sldb-buffers) + append (with-current-buffer b + (and (eq slime-buffer-connection connection) + sldb-continuations)))) + +(defun sldb--display-buffer-reuse-last-window (buffer _alist) + (let ((window + (get-window-with-predicate (lambda (w) + (window-parameter w 'sldb-last-window))))) + (when (and window + (not (with-current-buffer (window-buffer window) + (derived-mode-p 'sldb-mode)))) + (display-buffer-record-window 'reuse window buffer) + (set-window-buffer window buffer) + window))) + +(defun sldb-display-buffer (buffer) + "Pop to BUFFER reusing the last SLDB window, if any." + (pop-to-buffer buffer '(sldb--display-buffer-reuse-last-window))) + +(defun sldb-setup (thread level condition restarts frames conts) + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial +portion of the backtrace. Frames are numbered from 0. +CONTS is a list of pending Emacs continuations." + (with-current-buffer (sldb-get-buffer thread) + (cl-assert (if (equal sldb-level level) + (equal sldb-condition condition) + t) + () "Bug: sldb-level is equal but condition differs\n%s\n%s" + sldb-condition condition) + (unless (equal sldb-level level) + (setq buffer-read-only nil) + (sldb-mode) + (setq slime-current-thread thread) + (setq sldb-level level) + (setq mode-name (format "sldb[%d]" sldb-level)) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (setq sldb-continuations conts) + (sldb-insert-condition condition) + (insert "\n\n" (sldb-in-face section "Restarts:") "\n") + (setq sldb-restart-list-start-marker (point-marker)) + (sldb-insert-restarts restarts 0 sldb-initial-restart-limit) + (insert "\n" (sldb-in-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (save-excursion + (if frames + (sldb-insert-frames (sldb-prune-initial-frames frames) t) + (insert "[No backtrace]"))) + (run-hooks 'sldb-hook) + (set-syntax-table lisp-mode-syntax-table)) + ;; FIXME: remove when dropping Emacs23 support + (let ((saved (selected-window))) + (sldb-display-buffer (current-buffer)) + (set-window-parameter (selected-window) 'sldb-restore saved)) + (unless noninteractive ; needed for tests in batch-mode + (slime--display-region (point-min) (point))) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit)))) + +(defun sldb-activate (thread level select) + "Display the debugger buffer for THREAD. +If LEVEL isn't the same as in the buffer reinitialize the buffer." + (or (let ((buffer (sldb-find-buffer thread))) + (when buffer + (with-current-buffer buffer + (when (equal sldb-level level) + (when select (pop-to-buffer (current-buffer))) + t)))) + (sldb-reinitialize thread level))) + +(defun sldb-reinitialize (thread level) + (slime-rex (thread level) + ('(swank:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sldb-setup thread level result)))) + +(defun sldb--mark-last-window (window) + (dolist (window (window-list)) + (when (window-parameter window 'sldb-last-window) + (set-window-parameter window 'sldb-last-window nil))) + (set-window-parameter (selected-window) 'sldb-last-window t)) + +(defun sldb-exit (thread _level &optional stepping) + "Exit from the debug level LEVEL." + (let ((sldb (sldb-find-buffer thread))) + (when sldb + (with-current-buffer sldb + (cond (stepping + (setq sldb-level nil) + (run-with-timer 0.4 nil 'sldb-close-step-buffer sldb)) + ((not (eq sldb (window-buffer (selected-window)))) + ;; A different window selection means an indirect, + ;; non-interactive exit, we just kill the sldb buffer. + (kill-buffer)) + (t + (sldb--mark-last-window (selected-window)) + ;; An interactive exit should restore configuration per + ;; `quit-window's protocol. FIXME: remove + ;; `previous-window' hack when dropping Emacs23 support + (let ((previous-window (window-parameter (selected-window) + 'sldb-restore))) + (quit-window t) + (if (and (not (>= emacs-major-version 24)) + (window-live-p previous-window)) + (select-window previous-window))))))))) + +(defun sldb-close-step-buffer (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (not sldb-level) + (quit-window t))))) + + +;;;;;; SLDB buffer insertion + +(defun sldb-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (cl-destructuring-bind (message type extras) condition + (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) + (sldb-in-face topline message) + "\n" + (sldb-in-face condition type)) + (sldb-dispatch-extras extras))) + +(defvar sldb-extras-hooks) + +(defun sldb-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (slime-dcase extra + ((:show-frame-source n) + (sldb-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sldb-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sldb-insert-restarts (restarts start count) + "Insert RESTARTS and add the needed text props +RESTARTS should be a list ((NAME DESCRIPTION) ...)." + (let* ((len (length restarts)) + (end (if count (min (+ start count) len) len))) + (cl-loop for (name string) in (cl-subseq restarts start end) + for number from start + do (slime-insert-propertized + `(,@nil restart ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " (sldb-in-face restart-number (number-to-string number)) + ": [" (sldb-in-face restart-type name) "] " + (sldb-in-face restart string)) + (insert "\n")) + (when (< end len) + (let ((pos (point))) + (slime-insert-propertized + (list 'sldb-default-action + (slime-rcurry #'sldb-insert-more-restarts restarts pos end)) + " --more--\n"))))) + +(defun sldb-insert-more-restarts (restarts position start) + (goto-char position) + (let ((inhibit-read-only t)) + (delete-region position (1+ (line-end-position))) + (sldb-insert-restarts restarts start nil))) + +(defun sldb-frame.string (frame) + (cl-destructuring-bind (_ str &optional _) frame str)) + +(defun sldb-frame.number (frame) + (cl-destructuring-bind (n _ &optional _) frame n)) + +(defun sldb-frame.plist (frame) + (cl-destructuring-bind (_ _ &optional plist) frame plist)) + +(defun sldb-frame-restartable-p (frame) + (and (plist-get (sldb-frame.plist frame) :restartable) t)) + +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (let* ((case-fold-search t) + (rx "^\\([() ]\\|lambda\\)*swank\\>")) + (or (cl-loop for frame in frames + until (string-match rx (sldb-frame.string frame)) + collect frame) + frames))) + +(defun sldb-insert-frames (frames more) + "Insert FRAMES into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (mapc #'sldb-insert-frame frames) + (when more + (slime-insert-propertized + `(,@nil sldb-default-action sldb-fetch-more-frames + sldb-previous-frame-number + ,(sldb-frame.number (cl-first (last frames))) + point-entered sldb-fetch-more-frames + start-open t + face sldb-section-face + mouse-face highlight) + " --more--") + (insert "\n"))) + +(defun sldb-compute-frame-face (frame) + (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + 'sldb-frame-line-face)) + +(defun sldb-insert-frame (frame &optional face) + "Insert FRAME with FACE at point. +If FACE is nil, `sldb-compute-frame-face' is used to determine the face." + (setq face (or face (sldb-compute-frame-face frame))) + (let ((number (sldb-frame.number frame)) + (string (sldb-frame.string frame)) + (props `(frame ,frame sldb-default-action sldb-toggle-details))) + (slime-propertize-region props + (slime-propertize-region '(mouse-face highlight) + (insert " " (sldb-in-face frame-label (format "%2d:" number)) " ") + (slime-insert-indented + (slime-add-face face string))) + (insert "\n")))) + +(defun sldb-fetch-more-frames (&rest _) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (prev (get-text-property (point) 'sldb-previous-frame-number))) + ;; we may be called twice, PREV is nil the second time + (when prev + (let* ((count 40) + (from (1+ prev)) + (to (+ from count)) + (frames (slime-eval `(swank:backtrace ,from ,to))) + (more (slime-length= frames count)) + (pos (point))) + (delete-region (line-beginning-position) (point-max)) + (sldb-insert-frames frames more) + (goto-char pos))))) + + +;;;;;; SLDB examining text props + +(defun sldb-restart-at-point () + (or (get-text-property (point) 'restart) + (error "No restart at point"))) + +(defun sldb-frame-number-at-point () + (let ((frame (get-text-property (point) 'frame))) + (cond (frame (car frame)) + (t (error "No frame at point"))))) + +(defun sldb-var-number-at-point () + (let ((var (get-text-property (point) 'var))) + (cond (var var) + (t (error "No variable at point"))))) + +(defun sldb-previous-frame-number () + (save-excursion + (sldb-backward-frame) + (sldb-frame-number-at-point))) + +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) + +(defun sldb-frame-region () + (slime-property-bounds 'frame)) + +(defun sldb-forward-frame () + (goto-char (next-single-char-property-change (point) 'frame))) + +(defun sldb-backward-frame () + (when (> (point) sldb-backtrace-start-marker) + (goto-char (previous-single-char-property-change + (if (get-text-property (point) 'frame) + (car (sldb-frame-region)) + (point)) + 'frame + nil sldb-backtrace-start-marker)))) + +(defun sldb-goto-last-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame)) + (goto-char (previous-single-property-change (point) 'frame)) + ;; Recenter to bottom of the window; -2 to account for the + ;; empty last line displayed in sldb buffers. + (recenter -2))) + +(defun sldb-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sldb-backtrace-start-marker)) + + +;;;;;; SLDB recenter & redisplay +;; not sure yet, whether this is a good idea. +;; +;; jt: seconded. Only `sldb-show-frame-details' and +;; `sldb-hide-frame-details' use this. They could avoid it by not +;; removing and reinserting the frame's name line. +(defmacro slime-save-coordinates (origin &rest body) + "Restore line and column relative to ORIGIN, after executing BODY. + +This is useful if BODY deletes and inserts some text but we want to +preserve the current row and column as closely as possible." + (let ((base (make-symbol "base")) + (goal (make-symbol "goal")) + (mark (make-symbol "mark"))) + `(let* ((,base ,origin) + (,goal (slime-coordinates ,base)) + (,mark (point-marker))) + (set-marker-insertion-type ,mark t) + (prog1 (save-excursion ,@body) + (slime-restore-coordinate ,base ,goal ,mark))))) + +(put 'slime-save-coordinates 'lisp-indent-function 1) + +(defun slime-coordinates (origin) + ;; Return a pair (X . Y) for the column and line distance to ORIGIN. + (let ((y (slime-count-lines origin (point))) + (x (save-excursion + (- (current-column) + (progn (goto-char origin) (current-column)))))) + (cons x y))) + +(defun slime-restore-coordinate (base goal limit) + ;; Move point to GOAL. Coordinates are relative to BASE. + ;; Don't move beyond LIMIT. + (save-restriction + (narrow-to-region base limit) + (goto-char (point-min)) + (let ((col (current-column))) + (forward-line (cdr goal)) + (when (and (eobp) (bolp) (not (bobp))) + (backward-char)) + (move-to-column (+ col (car goal)))))) + +(defun slime-count-lines (start end) + "Return the number of lines between START and END. +This is 0 if START and END at the same line." + (- (count-lines start end) + (if (save-excursion (goto-char end) (bolp)) 0 1))) + + +;;;;; SLDB commands + +(defun sldb-default-action () + "Invoke the action at point." + (interactive) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))) + +(defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (cl-destructuring-bind (_mouse-1 (_w pos &rest ignore)) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))))) + +(defun sldb-cycle () + "Cycle between restart list and backtrace." + (interactive) + (let ((pt (point))) + (cond ((< pt sldb-restart-list-start-marker) + (goto-char sldb-restart-list-start-marker)) + ((< pt sldb-backtrace-start-marker) + (goto-char sldb-backtrace-start-marker)) + (t + (goto-char sldb-restart-list-start-marker))))) + +(defun sldb-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sldb-fetch-all-frames) + (sldb-goto-last-frame)) + +(defun sldb-fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sldb-goto-last-frame) + (let ((last (sldb-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame)) + (delete-region (point) (point-max)) + (save-excursion + (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLDB show source + +(defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." + (interactive) + (sldb-show-frame-source (sldb-frame-number-at-point))) + +(defun sldb-show-frame-source (frame-number) + (slime-eval-async + `(swank:frame-source-location ,frame-number) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location t nil)))))) + +(defun slime-show-source-location (source-location + &optional highlight recenter-arg) + "Go to SOURCE-LOCATION and display the buffer in the other window." + (slime-goto-source-location source-location) + ;; show the location, but don't hijack focus. + (slime--display-position (point) t recenter-arg) + (when highlight (slime-highlight-sexp))) + +(defun slime--display-position (pos other-window recenter-arg) + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +;; Set window-start so that the region from START to END becomes visible. +;; START is inclusive; END is exclusive. +(defun slime--adjust-window-start (start end) + (let* ((last (max start (1- end))) + (window-height (window-text-height)) + (region-height (count-screen-lines start last t))) + ;; if needed, make the region visible + (when (or (not (pos-visible-in-window-p start)) + (not (pos-visible-in-window-p last))) + (let* ((nlines (cond ((or (< start (window-start)) + (>= region-height window-height)) + 0) + (t + (- region-height))))) + (goto-char start) + (recenter nlines))) + (cl-assert (pos-visible-in-window-p start)) + (cl-assert (or (pos-visible-in-window-p last) + (> region-height window-height))) + (cl-assert (pos-visible-in-window-p (1- (window-end nil t)) nil t)))) + +;; move POS to visible region +(defun slime--adjust-window-point (pos) + (cond ((pos-visible-in-window-p pos) + (goto-char pos)) + ((< pos (window-start)) + (goto-char (window-start))) + (t + (goto-char (1- (window-end nil t))) + (move-to-column 0))) + (cl-assert (pos-visible-in-window-p (point) nil t))) + +(defun slime--display-region (start end) + "Make the region from START to END visible. +Minimize point motion." + (cl-assert (<= start end)) + (cl-assert (eq (window-buffer (selected-window)) + (current-buffer))) + (let ((pos (point))) + (slime--adjust-window-start start end) + (slime--adjust-window-point pos))) + +(defun slime-highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (slime-flash-region start end))) + +(defun slime-highlight-line (&optional timeout) + (slime-flash-region (+ (line-beginning-position) (current-indentation)) + (line-end-position) + timeout)) + + +;;;;;; SLDB toggle details + +(defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive) + (cl-assert (sldb-frame-number-at-point)) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (if (or on (not (sldb-frame-details-visible-p))) + (sldb-show-frame-details) + (sldb-hide-frame-details)))) + +(defun sldb-show-frame-details () + ;; fetch and display info about local variables and catch tags + (cl-destructuring-bind (start end frame locals catches) (sldb-frame-details) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region `(frame ,frame details-visible-p t) + (sldb-insert-frame frame (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + ;; FIXME: can we somehow merge the two? + 'sldb-detailed-frame-line-face)) + (let ((indent1 " ") + (indent2 " ")) + (insert indent1 (sldb-in-face section + (if locals "Locals:" "[No Locals]")) "\n") + (sldb-insert-locals locals indent2 frame) + (when catches + (insert indent1 (sldb-in-face section "Catch-tags:") "\n") + (dolist (tag catches) + (slime-propertize-region `(catch-tag ,tag) + (insert indent2 (sldb-in-face catch-tag (format "%s" tag)) + "\n")))) + (setq end (point))))) + (slime--display-region (point) end))) + +(defun sldb-frame-details () + ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. + (let* ((frame (get-text-property (point) 'frame)) + (num (car frame))) + (cl-destructuring-bind (start end) (sldb-frame-region) + (cl-list* start end frame + (slime-eval `(swank:frame-locals-and-catch-tags ,num)))))) + +(defvar sldb-insert-frame-variable-value-function + 'sldb-insert-frame-variable-value) + +(defun sldb-insert-locals (vars prefix frame) + "Insert VARS and add PREFIX at the beginning of each inserted line. +VAR should be a plist with the keys :name, :id, and :value." + (cl-loop for i from 0 + for var in vars do + (cl-destructuring-bind (&key name id value) var + (slime-propertize-region + (list 'sldb-default-action 'sldb-inspect-var 'var i) + (insert prefix + (sldb-in-face local-name + (concat name (if (zerop id) "" (format "#%d" id)))) + " = ") + (funcall sldb-insert-frame-variable-value-function + value frame i) + (insert "\n"))))) + +(defun sldb-insert-frame-variable-value (value _frame _index) + (insert (sldb-in-face local-value value))) + +(defun sldb-hide-frame-details () + ;; delete locals and catch tags, but keep the function name and args. + (cl-destructuring-bind (start end) (sldb-frame-region) + (let ((frame (get-text-property (point) 'frame))) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region '(details-visible-p nil) + (sldb-insert-frame frame)))))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) + (lambda (result) + (slime-show-description result nil))))) + + +;;;;;; SLDB eval and inspect + +(defun sldb-eval-in-frame (frame string package) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result))) + +(defun sldb-pprint-eval-in-frame (frame string package) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async + `(swank:pprint-eval-string-in-frame ,string ,frame ,package) + (lambda (result) + (slime-show-description result nil)))) + +(defun sldb-read-form-for-frame (fstring) + (let* ((frame (sldb-frame-number-at-point)) + (pkg (slime-eval `(swank:frame-package-name ,frame)))) + (list frame + (let ((slime-buffer-package pkg)) + (slime-read-from-minibuffer (format fstring pkg))) + pkg))) + +(defun sldb-inspect-in-frame (string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) + +(defun sldb-inspect-var () + (let ((frame (sldb-frame-number-at-point)) + (var (sldb-var-number-at-point))) + (slime-eval-async `(swank:inspect-frame-var ,frame ,var) + 'slime-open-inspector))) + +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-eval-async '(swank:inspect-current-condition) + 'slime-open-inspector)) + +(defun sldb-print-condition () + (interactive) + (slime-eval-describe `(swank:sdlb-print-condition))) + + +;;;;;; SLDB movement + +(defun sldb-down () + "Select next frame." + (interactive) + (sldb-forward-frame)) + +(defun sldb-up () + "Select previous frame." + (interactive) + (sldb-backward-frame) + (when (= (point) sldb-backtrace-start-marker) + (recenter (1+ (count-lines (point-min) (point)))))) + +(defun sldb-sugar-move (move-fn) + (let ((inhibit-read-only t)) + (when (sldb-frame-details-visible-p) (sldb-hide-frame-details)) + (funcall move-fn) + (sldb-show-source) + (sldb-toggle-details t))) + +(defun sldb-details-up () + "Select previous frame and show details." + (interactive) + (sldb-sugar-move 'sldb-up)) + +(defun sldb-details-down () + "Select next frame and show details." + (interactive) + (sldb-sugar-move 'sldb-down)) + + +;;;;;; SLDB restarts + +(defun sldb-quit () + "Quit to toplevel." + (interactive) + (cl-assert sldb-restarts () "sldb-quit called outside of sldb buffer") + (slime-rex () ('(swank:throw-to-toplevel)) + ((:ok x) (error "sldb-quit returned [%s]" x)) + ((:abort _)))) + +(defun sldb-continue () + "Invoke the \"continue\" restart." + (interactive) + (cl-assert sldb-restarts () "sldb-continue called outside of sldb buffer") + (slime-rex () + ('(swank:sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort _)))) + +(defun sldb-abort () + "Invoke the \"abort\" restart." + (interactive) + (slime-eval-async '(swank:sldb-abort) + (lambda (v) (message "Restart returned: %S" v)))) + +(defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER (index into `sldb-restarts') specifies the +restart to invoke, otherwise use the restart at point." + (interactive) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort _))))) + +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Restart: " sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name)))) + (sldb-invoke-restart (cl-position restart-name sldb-restarts + :test 'string= :key 'first))) + +(defun sldb-break-with-default-debugger (&optional dont-unwind) + "Enter default debugger." + (interactive "P") + (slime-rex () + ((list 'swank:sldb-break-with-default-debugger + (not (not dont-unwind))) + nil slime-current-thread) + ((:abort _)))) + +(defun sldb-break-with-system-debugger (&optional lightweight) + "Enter system debugger (gdb)." + (interactive "P") + (slime-attach-gdb slime-buffer-connection lightweight)) + +(defun slime-attach-gdb (connection &optional lightweight) + "Run `gud-gdb'on the connection with PID `pid'. + +If `lightweight' is given, do not send any request to the +inferior Lisp (e.g. to obtain default gdb config) but only +operate from the Emacs side; intended for cases where the Lisp is +truly screwed up." + (interactive + (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P")) + (let ((pid (slime-pid connection)) + (file (slime-lisp-implementation-program connection)) + (commands (unless lightweight + (let ((slime-dispatching-connection connection)) + (slime-eval `(swank:gdb-initial-commands)))))) + (gud-gdb (format "gdb -p %d %s" pid (or file ""))) + (with-current-buffer gud-comint-buffer + (dolist (cmd commands) + ;; First wait until gdb was initialized, then wait until current + ;; command was processed. + (while (not (looking-back comint-prompt-regexp nil)) + (sit-for 0.01)) + ;; We do not use `gud-call' because we want the initial commands + ;; to be displayed by the user so he knows what he's got. + (insert cmd) + (comint-send-input))))) + +(defun slime-read-connection (prompt &optional initial-value) + "Read a connection from the minibuffer. +Return the net process, or nil." + (cl-assert (memq initial-value slime-net-processes)) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (slime-connection-name p) (slime-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + slime-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) + +(defun sldb-step () + "Step to next basic-block boundary." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-step ,frame)))) + +(defun sldb-next () + "Step over call." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-next ,frame)))) + +(defun sldb-out () + "Resume stepping after returning from this function." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-out ,frame)))) + +(defun sldb-break-on-return () + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-break-on-return ,frame) + (lambda (msg) (message "%s" msg))))) + +(defun sldb-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (slime-read-symbol-name "Function: " t))) + (slime-eval-async `(swank:sldb-break ,name) + (lambda (msg) (message "%s" msg)))) + +(defun sldb-return-from-frame (string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:sldb-return-from-frame number string)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun sldb-restart-frame () + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:restart-frame number)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun slime-toggle-break-on-signals () + "Toggle the value of *break-on-signals*." + (interactive) + (slime-eval-async `(swank:toggle-break-on-signals) + (lambda (msg) (message "%s" msg)))) + + +;;;;;; SLDB recompilation commands + +(defun sldb-recompile-frame-source (&optional raw-prefix-arg) + (interactive "P") + (slime-eval-async + `(swank:frame-source-location ,(sldb-frame-number-at-point)) + (lexical-let ((policy (slime-compute-policy raw-prefix-arg))) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (let ((slime-compilation-policy policy)) + (slime-recompile-location source-location)))))))) + + +;;;; Thread control panel + +(defvar slime-threads-buffer-name (slime-buffer-name :threads)) +(defvar slime-threads-buffer-timer nil) + +(defcustom slime-threads-update-interval nil + "Interval at which the list of threads will be updated." + :type '(choice + (number :value 0.5) + (const nil)) + :group 'slime-ui) + +(defun slime-list-threads () + "Display a list of threads." + (interactive) + (let ((name slime-threads-buffer-name)) + (slime-with-popup-buffer (name :connection t + :mode 'slime-thread-control-mode) + (slime-update-threads-buffer) + (goto-char (point-min)) + (when slime-threads-update-interval + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (setq slime-threads-buffer-timer + (run-with-timer + slime-threads-update-interval + slime-threads-update-interval + 'slime-update-threads-buffer)))))) + +(defun slime-quit-threads-buffer () + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (quit-window t) + (slime-eval-async `(swank:quit-thread-browser))) + +(defun slime-update-threads-buffer () + (interactive) + (with-current-buffer slime-threads-buffer-name + (slime-eval-async '(swank:list-threads) + 'slime-display-threads))) + +(defun slime-move-point (position) + "Move point in the current buffer and in the window the buffer is displayed." + (let ((window (get-buffer-window (current-buffer) t))) + (goto-char position) + (when window + (set-window-point window position)))) + +(defun slime-display-threads (threads) + (with-current-buffer slime-threads-buffer-name + (let* ((inhibit-read-only t) + (old-thread-id (get-text-property (point) 'thread-id)) + (old-line (line-number-at-pos)) + (old-column (current-column))) + (erase-buffer) + (slime-insert-threads threads) + (let ((new-position (cl-position old-thread-id (cdr threads) + :key #'car :test #'equal))) + (goto-char (point-min)) + (forward-line (or new-position (1- old-line))) + (move-to-column old-column) + (slime-move-point (point)))))) + +(defun slime-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (cl-loop for col-index below ncols + collect (cl-loop for row in list-of-lists + collect (elt row col-index))))) + +(defun slime-insert-table-row (line line-props col-props col-widths) + (slime-propertize-region line-props + (cl-loop for string in line + for col-prop in col-props + for width in col-widths do + (slime-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun slime-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (cl-loop for columns in (slime-transpose-lists lines) + collect (1+ (cl-loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (slime-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (cl-loop for line in rows for line-props in row-properties do + (slime-insert-table-row line line-props column-properties widths) + (insert "\n")))) + +(defvar slime-threads-table-properties + '(nil (face bold))) + +(defun slime-insert-threads (threads) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (cl-loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (cl-loop for thread in threads collect + (cl-loop for prop in thread collect + (format "%s" prop)))) + (line-props (cl-loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (cl-loop for nil in labels for i from 0 collect + (nth i slime-threads-table-properties)))) + (slime-insert-table rows header line-props col-props))) + + +;;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "Threads" + "SLIME Thread Control Panel Mode. + +\\{slime-thread-control-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t)) + (setq buffer-undo-list t)) + +(slime-define-keys slime-thread-control-mode-map + ("a" 'slime-thread-attach) + ("d" 'slime-thread-debug) + ("g" 'slime-update-threads-buffer) + ("k" 'slime-thread-kill) + ("q" 'slime-quit-threads-buffer)) + +(defun slime-thread-kill () + (interactive) + (slime-eval `(cl:mapc 'swank:kill-nth-thread + ',(slime-get-properties 'thread-index))) + (call-interactively 'slime-update-threads-buffer)) + +(defun slime-get-region-properties (prop start end) + (cl-loop for position = (if (get-text-property start prop) + start + (next-single-property-change start prop)) + then (next-single-property-change position prop) + while (<= position end) + collect (get-text-property position prop))) + +(defun slime-get-properties (prop) + (if (use-region-p) + (slime-get-region-properties prop + (region-beginning) + (region-end)) + (let ((value (get-text-property (point) prop))) + (when value + (list value))))) + +(defun slime-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-index)) + (file (slime-swank-port-file))) + (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) + (slime-read-port-and-connect nil)) + +(defun slime-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-index))) + (slime-eval-async `(swank:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(define-derived-mode slime-connection-list-mode fundamental-mode + "Slime-Connections" + "SLIME Connection List Mode. + +\\{slime-connection-list-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-connection-list-mode-map + ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) + ((kbd "C-k") 'slime-quit-connection-at-point) + ("R" 'slime-restart-connection-at-point)) + +(defun slime-connection-at-point () + (or (get-text-property (point) 'slime-connection) + (error "No connection at point"))) + +(defun slime-quit-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (slime-quit-lisp t) + (while (memq connection slime-net-processes) + (when (time-less-p end (current-time)) + (message "Quit timeout expired. Disconnecting.") + (delete-process connection)) + (sit-for 0 100))) + (slime-update-connection-list)) + +(defun slime-restart-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-restart-inferior-lisp))) + +(defun slime-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) + +(defvar slime-connections-buffer-name (slime-buffer-name :connections)) + +(defun slime-list-connections () + "Display a list of all connections." + (interactive) + (slime-with-popup-buffer (slime-connections-buffer-name + :mode 'slime-connection-list-mode) + (slime-draw-connection-list))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) + +(defun slime-draw-connection-list () + (let ((default-pos nil) + (default slime-default-connection) + (fstring "%s%2s %-10s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-connection-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (when default-pos + (goto-char default-pos)))) + + +;;;; Inspector + +(defgroup slime-inspector nil + "Inspector faces." + :prefix "slime-inspector-" + :group 'slime) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime-inspector) + +(defface slime-inspector-label-face + '((t (:inherit font-lock-constant-face))) + "Face for labels in the inspector." + :group 'slime-inspector) + +(defface slime-inspector-value-face + '((t (:inherit font-lock-builtin-face))) + "Face for things which can themselves be inspected." + :group 'slime-inspector) + +(defface slime-inspector-action-face + '((t (:inherit font-lock-warning-face))) + "Face for labels of inspector actions." + :group 'slime-inspector) + +(defface slime-inspector-type-face + '((t (:inherit font-lock-type-face))) + "Face for type description in inspector." + :group 'slime-inspector) + +(defvar slime-inspector-mark-stack '()) + +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode + "Slime-Inspector" + " +\\{slime-inspector-mode-map} +\\{slime-popup-buffer-mode-map}" + (set-syntax-table lisp-mode-syntax-table) + (slime-set-truncate-lines) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer (slime-buffer-name :inspector)) + (slime-with-popup-buffer ((slime-buffer-name :inspector) + :mode 'slime-inspector-mode) + (setq slime-inspector-mark-stack '()) + (buffer-disable-undo) + (current-buffer)))) + +(defmacro slime-inspector-fontify (face string) + `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) + +(defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) + +(defun slime-open-inspector (inspected-parts &optional point hook) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT. If HOOK is provided, it is added to local +KILL-BUFFER hooks for the inspector buffer." + (with-current-buffer (slime-inspector-buffer) + (when hook + (add-hook 'kill-buffer-hook hook t t)) + (setq slime-buffer-connection (slime-current-connection)) + (let ((inhibit-read-only t)) + (erase-buffer) + (pop-to-buffer (current-buffer)) + (cl-destructuring-bind (&key id title content) inspected-parts + (cl-macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert title)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n" (fontify label "--------------------") "\n") + (save-excursion + (slime-inspector-insert-content content)) + (when point + (cl-check-type point cons) + (ignore-errors + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point))))))))) + +(defvar slime-inspector-limit 500) + +(defun slime-inspector-insert-content (content) + (slime-inspector-fetch-chunk + content nil + (lambda (chunk) + (let ((inhibit-read-only t)) + (slime-inspector-insert-chunk chunk t t))))) + +(defun slime-inspector-insert-chunk (chunk prev next) + "Insert CHUNK at point. +If PREV resp. NEXT are true insert more-buttons as needed." + (cl-destructuring-bind (ispecs len start end) chunk + (when (and prev (> start 0)) + (slime-inspector-insert-more-button start t)) + (mapc slime-inspector-insert-ispec-function ispecs) + (when (and next (< end len)) + (slime-inspector-insert-more-button end nil)))) + +(defun slime-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (slime-dcase ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert string))) + ((:label string) + (insert (slime-inspector-fontify label string))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + ;; FIXME: why would somebody narrow the buffer? + (save-restriction + (widen) + (cons (line-number-at-pos) + (current-column)))) + +(defun slime-inspector-property-at-point () + (let* ((properties '(slime-part-number slime-range-button + slime-action-number)) + (find-property + (lambda (point) + (cl-loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (1- (point)))))) + +(defun slime-inspector-operate-on-point () + "Invoke the command for the text at point. +1. If point is on a value then recursivly call the inspector on +that value. +2. If point is on an action then call that action. +3. If point is on a range-button fetch and insert the range." + (interactive) + (let ((opener (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (when parts + (slime-open-inspector parts point))))) + (new-opener (lambda (parts) + (when parts + (slime-open-inspector parts))))) + (cl-destructuring-bind (&optional property value) + (slime-inspector-property-at-point) + (cl-case property + (slime-part-number + (slime-eval-async `(swank:inspect-nth-part ,value) + new-opener) + (push (slime-inspector-position) slime-inspector-mark-stack)) + (slime-range-button + (slime-inspector-fetch-more value)) + (slime-action-number + (slime-eval-async `(swank:inspector-call-nth-action ,value) + opener)) + (t (error "No object at point")))))) + +(defun slime-inspector-operate-on-click (event) + "Move to events' position and operate the part." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'slime-part-number) + (get-text-property point 'slime-range-button) + (get-text-property point 'slime-action-number))) + (goto-char point) + (slime-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(defun slime-inspector-pop () + "Reinspect the previous object." + (interactive) + (slime-eval-async + `(swank:inspector-pop) + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + "Inspect the next object in the history." + (interactive) + (let ((result (slime-eval `(swank:inspector-next)))) + (cond (result + (push (slime-inspector-position) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) + +(defun slime-inspector-quit () + "Quit the inspector and kill the buffer." + (interactive) + (slime-eval-async `(swank:quit-inspector)) + (quit-window t)) + +;; FIXME: first return value is just point. +;; FIXME: could probably use slime-search-property. +(defun slime-find-inspectable-object (direction limit) + "Find the next/previous inspectable object. +DIRECTION can be either 'next or 'prev. +LIMIT is the maximum or minimum position in the current buffer. + +Return a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned." + (let ((finder (cl-ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'slime-part-number nil limit))) + (setq prop (get-text-property newpos 'slime-part-number)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun slime-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'prev minpos) + ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + +(defun slime-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (slime-inspector-next-inspectable-object (- arg))) + +(defun slime-inspector-describe () + (interactive) + (slime-eval-describe `(swank:describe-inspectee))) + +(defun slime-inspector-pprint (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-describe `(swank:pprint-inspector-part ,part))) + +(defun slime-inspector-eval (string) + "Eval an expression in the context of the inspected object. +The `*' variable will be bound to the inspected object." + (interactive (list (slime-read-from-minibuffer "Inspector eval: "))) + (slime-eval-with-transcript `(swank:inspector-eval ,string))) + +(defun slime-inspector-history () + "Show the previously inspected objects." + (interactive) + (slime-eval-describe `(swank:inspector-history))) + +(defun slime-inspector-show-source (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-async + `(swank:find-source-location-for-emacs '(:inspector ,part)) + #'slime-show-source-location)) + +(defun slime-inspector-reinspect () + (interactive) + (slime-eval-async `(swank:inspector-reinspect) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-toggle-verbose () + (interactive) + (slime-eval-async `(swank:inspector-toggle-verbose) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-insert-more-button (index previous) + (slime-insert-propertized + (list 'slime-range-button (list index previous) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + (if previous " [--more--]\n" " [--more--]"))) + +(defun slime-inspector-fetch-all () + "Fetch all inspector contents and go to the end." + (interactive) + (goto-char (1- (point-max))) + (let ((button (get-text-property (point) 'slime-range-button))) + (when button + (let (slime-inspector-limit) + (slime-inspector-fetch-more button))))) + +(defun slime-inspector-fetch-more (button) + (cl-destructuring-bind (index prev) button + (slime-inspector-fetch-chunk + (list '() (1+ index) index index) prev + (slime-rcurry + (lambda (chunk prev) + (let ((inhibit-read-only t)) + (apply #'delete-region (slime-property-bounds 'slime-range-button)) + (slime-inspector-insert-chunk chunk prev (not prev)))) + prev)))) + +(defun slime-inspector-fetch-chunk (chunk prev cont) + (slime-inspector-fetch chunk slime-inspector-limit prev cont)) + +(defun slime-inspector-fetch (chunk limit prev cont) + (cl-destructuring-bind (from to) + (slime-inspector-next-range chunk limit prev) + (cond ((and from to) + (slime-eval-async + `(swank:inspector-range ,from ,to) + (slime-rcurry (lambda (chunk2 chunk1 limit prev cont) + (slime-inspector-fetch + (slime-inspector-join-chunks chunk1 chunk2) + limit prev cont)) + chunk limit prev cont))) + (t (funcall cont chunk))))) + +(defun slime-inspector-next-range (chunk limit prev) + (cl-destructuring-bind (_ len start end) chunk + (let ((count (- end start))) + (cond ((and prev (< 0 start) (or (not limit) (< count limit))) + (list (if limit (max (- end limit) 0) 0) start)) + ((and (not prev) (< end len) (or (not limit) (< count limit))) + (list end (if limit (+ start limit) most-positive-fixnum))) + (t '(nil nil)))))) + +(defun slime-inspector-join-chunks (chunk1 chunk2) + (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 + (cl-destructuring-bind (i2 l2 s2 e2) chunk2 + (cond ((= e1 s2) + (list (append i1 i2) l2 s1 e2)) + ((= e2 s1) + (list (append i2 i1) l2 s2 e1)) + (t (error "Invalid chunks")))))) + +(set-keymap-parent slime-inspector-mode-map slime-parent-map) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-operate-on-point) + ("\C-m" 'slime-inspector-operate-on-point) + ([mouse-1] 'slime-inspector-operate-on-click) + ([mouse-2] 'slime-inspector-operate-on-click) + ([mouse-6] 'slime-inspector-pop) + ([mouse-7] 'slime-inspector-next) + ("l" 'slime-inspector-pop) + ("n" 'slime-inspector-next) + (" " 'slime-inspector-next) + ("d" 'slime-inspector-describe) + ("p" 'slime-inspector-pprint) + ("e" 'slime-inspector-eval) + ("h" 'slime-inspector-history) + ("g" 'slime-inspector-reinspect) + ("v" 'slime-inspector-toggle-verbose) + ("\C-i" 'slime-inspector-next-inspectable-object) + ([(shift tab)] + 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB + ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. + ("." 'slime-inspector-show-source) + (">" 'slime-inspector-fetch-all) + ("q" 'slime-inspector-quit)) + + +;;;; Buffer selector + +(defvar slime-selector-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defvar slime-selector-other-window nil + "If non-nil use switch-to-buffer-other-window.") + +(defun slime-selector (&optional other-window) + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((slime-selector-other-window other-window) + (sequence (save-window-excursion + (select-window (minibuffer-window)) + (key-description (read-key-sequence nil)))) + (ch (cond ((equal sequence "C-g") + (keyboard-quit)) + ((equal sequence "TAB") + ?i) + ((= (length sequence) 1) + (elt sequence 0)) + ((= (length sequence) 3) + (elt sequence 2)))) + (method (cl-find ch slime-selector-methods :key #'car))) + (cond (method + (funcall (cl-third method))) + (t + (message "No method for character: ?\\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (slime-selector))))) + +(defmacro def-slime-selector-method (key description &rest body) + "Define a new `slime-select' buffer selection method. + +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +switch-to-buffer." + (let ((method `(lambda () + (let ((buffer (progn ,@body))) + (cond ((not (get-buffer buffer)) + (message "No such buffer: %S" buffer) + (ding)) + ((get-buffer-window buffer) + (select-window (get-buffer-window buffer))) + (slime-selector-other-window + (switch-to-buffer-other-window buffer)) + (t + (switch-to-buffer buffer))))))) + `(setq slime-selector-methods + (cl-sort (cons (list ,key ,description ,method) + (cl-remove ,key slime-selector-methods :key #'car)) + #'< :key #'car)))) + +(def-slime-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (cl-loop for (key line nil) in slime-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (slime-selector) + (current-buffer)) + +(cl-pushnew (list ?4 "Select in other window" (lambda () (slime-selector t))) + slime-selector-methods :key #'car) + +(def-slime-selector-method ?q "Abort." + (top-level)) + +(def-slime-selector-method ?i + "*inferior-lisp* buffer." + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) + +(def-slime-selector-method ?v + "*slime-events* buffer." + slime-event-buffer-name) + +(def-slime-selector-method ?l + "most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-selector-method ?d + "*sldb* buffer for the current connection." + (or (sldb-get-default-buffer) + (error "No debugger buffer"))) + +(def-slime-selector-method ?e + "most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(def-slime-selector-method ?c + "SLIME connections buffer." + (slime-list-connections) + slime-connections-buffer-name) + +(def-slime-selector-method ?n + "Cycle to the next Lisp connection." + (slime-next-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?p + "Cycle to the previous Lisp connection." + (slime-prev-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?t + "SLIME threads buffer." + (slime-list-threads) + slime-threads-buffer-name) + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +Only considers buffers that are not already visible." + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (string-match "^ " (buffer-name buffer))) + (null (get-buffer-window buffer 'visible))) + return buffer + finally (error "Can't find unshown buffer in %S" mode))) + + +;;;; Indentation + +(defun slime-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (slime-eval-async '(swank:update-indentation-information))) + +(defvar slime-indentation-update-hooks) + +(defun slime-intern-indentation-spec (spec) + (cond ((consp spec) + (cons (slime-intern-indentation-spec (car spec)) + (slime-intern-indentation-spec (cdr spec)))) + ((stringp spec) + (intern spec)) + (t + spec))) + +;; FIXME: restore the old version without per-package +;; stuff. slime-indentation.el should be able tho disable the simple +;; version if needed. +(defun slime-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (slime-intern-indentation-spec (cl-second info))) + (packages (cl-third info))) + (if (and (boundp 'common-lisp-system-indentation) + (fboundp 'slime-update-system-indentation)) + ;; A table provided by slime-cl-indent.el. + (funcall #'slime-update-system-indentation symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'common-lisp-indent-function) + (get symbol 'slime-indent)) + (put symbol 'common-lisp-indent-function indent) + (put symbol 'slime-indent indent))) + (run-hook-with-args 'slime-indentation-update-hooks + symbol indent packages)))) + + +;;;; Contrib modules + +(defun slime-require (module) + (cl-pushnew module slime-required-modules) + (when (slime-connected-p) + (slime-load-contribs))) + +(defun slime-load-contribs () + (let ((needed (cl-remove-if (lambda (s) + (member (cl-subseq (symbol-name s) 1) + (mapcar #'downcase + (slime-lisp-modules)))) + slime-required-modules))) + (when needed + ;; No asynchronous request because with :SPAWN that could result + ;; in the attempt to load modules concurrently which may not be + ;; supported by the host Lisp. + (setf (slime-lisp-modules) + (slime-eval `(swank:swank-require ',needed)))))) + +(cl-defstruct slime-contrib + name + slime-dependencies + swank-dependencies + enable + disable + authors + license) + +(defun slime-contrib--enable-fun (name) + (intern (concat (symbol-name name) "-init"))) + +(defun slime-contrib--disable-fun (name) + (intern (concat (symbol-name name) "-unload"))) + +(defmacro define-slime-contrib (name _docstring &rest clauses) + (declare (indent 1)) + (cl-destructuring-bind (&key slime-dependencies + swank-dependencies + on-load + on-unload + authors + license) + (cl-loop for (key . value) in clauses append `(,key ,value)) + `(progn + ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies) + (defun ,(slime-contrib--enable-fun name) () + (mapc #'funcall ',(mapcar + #'slime-contrib--enable-fun + slime-dependencies)) + (mapc #'slime-require ',swank-dependencies) + ,@on-load) + (defun ,(slime-contrib--disable-fun name) () + ,@on-unload + (mapc #'funcall ',(mapcar + #'slime-contrib--disable-fun + slime-dependencies))) + (put 'slime-contribs ',name + (make-slime-contrib + :name ',name :authors ',authors :license ',license + :slime-dependencies ',slime-dependencies + :swank-dependencies ',swank-dependencies + :enable ',(slime-contrib--enable-fun name) + :disable ',(slime-contrib--disable-fun name)))))) + +(defun slime-all-contribs () + (cl-loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr + when (slime-contrib-p val) + collect val)) + +(defun slime-contrib-all-dependencies (contrib) + "List all contribs recursively needed by CONTRIB, including self." + (cons contrib + (cl-mapcan #'slime-contrib-all-dependencies + (slime-contrib-slime-dependencies + (slime-find-contrib contrib))))) + +(defun slime-find-contrib (name) + (get 'slime-contribs name)) + +(defun slime-read-contrib-name () + (let ((names (cl-loop for c in (slime-all-contribs) collect + (symbol-name (slime-contrib-name c))))) + (intern (completing-read "Contrib: " names nil t)))) + +(defun slime-enable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-enable c)))) + +(defun slime-disable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-disable c)))) + + +;;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-definition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" completion-at-point ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Eval Region" slime-eval-region ,C ] + [ "Eval Region And Pretty-Print" slime-pprint-eval-region ,C ] + [ "Interactive Eval..." slime-interactive-eval ,C ] + [ "Edit Lisp Value..." slime-edit-value ,C ] + [ "Call Defun" slime-call-defun ,C ]) + ("Debugging" + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Untrace All" slime-untrace-all ,C] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + [ "Compile Region" slime-compile-region ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ] + [ "List Notes" slime-list-compiler-notes ,C ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" slime-update-indentation ,C] + [ "Select Buffer" slime-selector t]) + ("Profiling" + [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ] + [ "Profile Package" slime-profile-package ,C] + [ "Profile by Substring" slime-profile-by-substring ,C ] + [ "Unprofile All" slime-unprofile-all ,C ] + [ "Show Profiled" slime-profiled-functions ,C ] + "--" + [ "Report" slime-profile-report ,C ] + [ "Reset Counters" slime-profile-reset ,C ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Lookup Documentation..." slime-documentation-lookup t ] + [ "Apropos..." slime-apropos ,C ] + [ "Apropos all..." slime-apropos-all ,C ] + [ "Apropos Package..." slime-apropos-package ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] + ))) + +(defvar slime-sldb-easy-menu + (let ((C '(slime-connected-p))) + `("SLDB" + [ "Next Frame" sldb-down t ] + [ "Previous Frame" sldb-up t ] + [ "Toggle Frame Details" sldb-toggle-details t ] + [ "Next Frame (Details)" sldb-details-down t ] + [ "Previous Frame (Details)" sldb-details-up t ] + "--" + [ "Eval Expression..." slime-interactive-eval ,C ] + [ "Eval in Frame..." sldb-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sldb-inspect-in-frame ,C ] + [ "Inspect Condition Object" sldb-inspect-condition ,C ] + "--" + [ "Restart Frame" sldb-restart-frame ,C ] + [ "Return from Frame..." sldb-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sldb-continue ,C ] + [ "Abort" sldb-abort ,C ] + [ "Step" sldb-step ,C ] + [ "Step next" sldb-next ,C ] + [ "Step out" sldb-out ,C ] + ) + "--" + [ "Quit (throw)" sldb-quit ,C ] + [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ]))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) + +(defun slime-sldb-add-easy-menu () + (easy-menu-define menubar-slime-sldb + sldb-mode-map "SLDB" slime-sldb-easy-menu) + (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)) + +(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu) + + +;;;; Cheat Sheet + +(defvar + slime-cheat-sheet-table + '((:title + "Editing lisp code" + :map slime-mode-map + :bindings ((slime-eval-defun "Evaluate current top level form") + (slime-compile-defun "Compile current top level form") + (slime-interactive-eval "Prompt for form and eval it") + (slime-compile-and-load-file "Compile and load current file") + (slime-sync-package-and-default-directory + "Synch default package and directory with current buffer") + (slime-next-note "Next compiler note") + (slime-previous-note "Previous compiler note") + (slime-remove-notes "Remove notes") + slime-documentation-lookup)) + (:title "Completion" + :map slime-mode-map + :bindings (slime-indent-and-complete-symbol + slime-fuzzy-complete-symbol)) + (:title + "Within SLDB buffers" + :map sldb-mode-map + :bindings ((sldb-default-action "Do 'whatever' with thing at point") + (sldb-toggle-details "Toggle frame details visualization") + (sldb-quit "Quit to REPL") + (sldb-abort "Invoke ABORT restart") + (sldb-continue "Invoke CONTINUE restart (if available)") + (sldb-show-source "Jump to frame's source code") + (sldb-eval-in-frame "Evaluate in frame at point") + (sldb-inspect-in-frame + "Evaluate in frame at point and inspect result"))) + (:title + "Within the Inspector" + :map slime-inspector-mode-map + :bindings ((slime-inspector-next-inspectable-object + "Jump to next inspectable object") + (slime-inspector-operate-on-point + "Inspect object or execute action at point") + (slime-inspector-reinspect "Reinspect current object") + (slime-inspector-pop "Return to previous object") + ;;(slime-inspector-copy-down "Send object at point to REPL") + (slime-inspector-toggle-verbose "Toggle verbose mode") + (slime-inspector-quit "Quit"))) + (:title + "Finding Definitions" + :map slime-mode-map + :bindings (slime-edit-definition + slime-pop-find-definition-stack)))) + +(defun slime-cheat-sheet () + (interactive) + (switch-to-buffer-other-frame + (get-buffer-create (slime-buffer-name :cheat-sheet))) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert + "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n") + (dolist (mode slime-cheat-sheet-table) + (let ((title (cl-getf mode :title)) + (mode-map (cl-getf mode :map)) + (mode-keys (cl-getf mode :bindings))) + (insert title) + (insert ":\n") + (insert (make-string (1+ (length title)) ?-)) + (insert "\n") + (let ((keys '()) + (descriptions '())) + (dolist (func mode-keys) + ;; func is eithor the function name or a list (NAME DESCRIPTION) + (push (if (symbolp func) + (prin1-to-string func) + (cl-second func)) + descriptions) + (let ((all-bindings (where-is-internal (if (symbolp func) + func + (cl-first func)) + (symbol-value mode-map))) + (key-bindings '())) + (dolist (binding all-bindings) + (when (and (vectorp binding) + (integerp (aref binding 0))) + (push binding key-bindings))) + (push (mapconcat 'key-description key-bindings " or ") keys))) + (cl-loop with desc-length = (apply 'max (mapcar 'length descriptions)) + for key in (nreverse keys) + for desc in (nreverse descriptions) + do (insert desc) + do (insert (make-string (- desc-length (length desc)) ? )) + do (insert " => ") + do (insert (if (string= "" key) + "" + key)) + do (insert "\n") + finally do (insert "\n"))))) + (setq buffer-read-only t) + (goto-char (point-min))) + + +;;;; Utilities (no not Paul Graham style) + +;; XXX: unused function +(defun slime-intersperse (element list) + "Intersperse ELEMENT between each element of LIST." + (if (null list) + '() + (cons (car list) + (cl-mapcan (lambda (x) (list element x)) (cdr list))))) + +;;; FIXME: this looks almost slime `slime-alistify', perhaps the two +;;; functions can be merged. +(defun slime-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (reverse (mapcar #'reverse accumulator))))) + +(defun slime-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +;;;;; Misc. + +(defun slime-length= (seq n) + "Return (= (length SEQ) N)." + (cl-etypecase seq + (list + (cond ((zerop n) (null seq)) + ((let ((tail (nthcdr (1- n) seq))) + (and tail (null (cdr tail))))))) + (sequence + (= (length seq) n)))) + +(defun slime-length> (seq n) + "Return (> (length SEQ) N)." + (cl-etypecase seq + (list (nthcdr n seq)) + (sequence (> (length seq) n)))) + +(defun slime-trim-whitespace (str) + (let ((start (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str)) + + (end (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str + :from-end t))) + (if start + (substring str start (1+ end)) + ""))) + +;;;;; Buffer related + +(defun slime-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + +(defun slime-column-max () + (save-excursion + (goto-char (point-min)) + (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;;; CL symbols vs. Elisp symbols. + +(defun slime-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\\([^:]*\\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun slime-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\\([^:]*\\):" n) + (match-string 1 n) + default))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified string for SYMBOL-OR-NAME. +If SYMBOL-OR-NAME doesn't already have a package prefix the +current package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (slime-current-package))) + ;; package is a string like ":cl-user" + ;; or "CL-USER", or "\"CL-USER\"". + (if package + (slime-pretty-package-name package) + "CL-USER")) + (slime-cl-symbol-name s))))) + +;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) + +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (declare (indent 0)) + (let ((pointvar (cl-gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(defun slime-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+), +and skips comments." + (dotimes (_i (or count 1)) + (slime-forward-cruft) + (forward-sexp))) + +(defconst slime-reader-conditionals-regexp + ;; #!+, #!- are SBCL specific reader-conditional syntax. + ;; We need this for the source files of SBCL itself. + (regexp-opt '("#+" "#-" "#!+" "#!-"))) + +(defun slime-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (looking-at slime-reader-conditionals-regexp) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (slime-eval-feature-expression + (condition-case e + (read (current-buffer)) + (invalid-read-syntax + (signal 'slime-unknown-feature-expression (cdr e))))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (slime-forward-sexp))))) + +(defun slime-forward-cruft () + "Move forward over whitespace, comments, reader conditionals." + (while (slime-point-moves-p (skip-chars-forward " \t\n") + (forward-comment (buffer-size)) + (inline (slime-forward-reader-conditional))))) + +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(put 'slime-incorrect-feature-expression + 'error-conditions '(slime-incorrect-feature-expression error)) + +(put 'slime-unknown-feature-expression + 'error-conditions '(slime-unknown-feature-expression + slime-incorrect-feature-expression + error)) + +;; FIXME: let it crash +;; FIXME: the length=1 constraint is bogus +(defun slime-eval-feature-expression (e) + "Interpret a reader conditional expression." + (cond ((symbolp e) + (memq (slime-keywordify e) (slime-lisp-features))) + ((and (consp e) (symbolp (car e))) + (funcall (let ((head (slime-keywordify (car e)))) + (cl-case head + (:and #'cl-every) + (:or #'cl-some) + (:not + (lexical-let ((feature-expression e)) + (lambda (f l) + (cond + ((slime-length= l 0) t) + ((slime-length= l 1) (not (apply f l))) + (t (signal 'slime-incorrect-feature-expression + feature-expression)))))) + (t (signal 'slime-unknown-feature-expression head)))) + #'slime-eval-feature-expression + (cdr e))) + (t (signal 'slime-incorrect-feature-expression e)))) + +;;;;; Extracting Lisp forms from the buffer or user + +(defun slime-defun-at-point () + "Return the text of the defun at point." + (apply #'buffer-substring-no-properties + (slime-region-for-defun-at-point))) + +(defun slime-region-for-defun-at-point () + "Return the start and end position of defun at point." + (save-excursion + (save-match-data + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (list (point) end))))) + +(defun slime-beginning-of-symbol () + "Move to the beginning of the CL-style symbol at point." + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + (when (> (point) 2000) (- (point) 2000)) + t)) + (re-search-forward "\\=#[-+.<|]" nil t) + (when (and (looking-at "@") (eq (char-before) ?\,)) + (forward-char))) + +(defun slime-end-of-symbol () + "Move to the end of the CL-style symbol at point." + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) + +(put 'slime-symbol 'end-op 'slime-end-of-symbol) +(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) + +(defun slime-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (slime-beginning-of-symbol) (point))) + +(defun slime-symbol-end-pos () + (save-excursion (slime-end-of-symbol) (point))) + +(defun slime-bounds-of-symbol-at-point () + "Return the bounds of the symbol around point. +The returned bounds are either nil or non-empty." + (let ((bounds (bounds-of-thing-at-point 'slime-symbol))) + (if (and bounds + (< (car bounds) + (cdr bounds))) + bounds))) + +(defun slime-symbol-at-point () + "Return the name of the symbol at point, otherwise nil." + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((bounds (slime-bounds-of-symbol-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-bounds-of-sexp-at-point () + "Return the bounds sexp at point as a pair (or nil)." + (or (slime-bounds-of-symbol-at-point) + (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp))) + +(defun slime-sexp-at-point () + "Return the sexp at point as a string, otherwise nil." + (let ((bounds (slime-bounds-of-sexp-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-sexp-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-sexp-at-point) (user-error "No expression at point"))) + +(defun slime-string-at-point () + "Returns the string at point as a string, otherwise nil." + (let ((sexp (slime-sexp-at-point))) + (if (and sexp + (eql (char-syntax (aref sexp 0)) ?\")) + sexp + nil))) + +(defun slime-string-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-string-at-point) (error "No string at point."))) + +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;; slime.el in pretty colors + +(cl-loop for sym in (list 'slime-def-connection-var + 'slime-define-channel-type + 'slime-define-channel-method + 'define-slime-contrib + 'slime-defun-if-undefined + 'slime-defmacro-if-undefined) + for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + sym) + do (font-lock-add-keywords + 'emacs-lisp-mode + `((,regexp (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +;;;; target manipulation (used by slime-presentations, slime-media, +;;;; slime-repl and slime-buffer-streams, at +;;;; least) + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers. +The markers indicate where output should be inserted.") + +(defun slime-output-target-marker (target) + "Return the marker where output for TARGET should be inserted." + (gethash target slime-output-target-to-marker)) + +(defun slime-emit-to-target (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +;;;; Finishing up + +(eval-when-compile + (require 'bytecomp)) + +(defun slime--byte-compile (symbol) + (require 'bytecomp) ;; tricky interaction between autoload and let. + (let ((byte-compile-warnings '())) + (byte-compile symbol))) + +(defun slime--compile-hotspots () + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (byte-code-function-p (symbol-function sym)) + (slime--byte-compile sym))) + (t (error "%S is not fbound" sym)))) + '(slime-alistify + slime-log-event + slime-events-buffer + slime-process-available-input + slime-dispatch-event + slime-net-filter + slime-net-have-input-p + slime-net-decode-length + slime-net-read + slime-print-apropos + slime-insert-propertized + slime-beginning-of-symbol + slime-end-of-symbol + slime-eval-feature-expression + slime-forward-sexp + slime-forward-cruft + slime-forward-reader-conditional))) + +(slime--compile-hotspots) + +(add-to-list 'load-path (expand-file-name "contrib" slime-path)) + +(run-hooks 'slime-load-hook) +(provide 'slime) + +(slime-setup) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; indent-tabs-mode: nil +;; coding: latin-1-unix +;; End: +;;; slime.el ends here diff --git a/elpa/slime-20200319.1939/slime.elc b/elpa/slime-20200319.1939/slime.elc new file mode 100644 index 00000000..99b87796 Binary files /dev/null and b/elpa/slime-20200319.1939/slime.elc differ diff --git a/elpa/slime-20200319.1939/slime.info b/elpa/slime-20200319.1939/slime.info new file mode 100644 index 00000000..4b992d9d --- /dev/null +++ b/elpa/slime-20200319.1939/slime.info @@ -0,0 +1,3740 @@ +This is slime.info, produced by makeinfo version 6.5 from slime.texi. + +Written by Luke Gorrie and others. + + This file has been placed in the public domain. +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* SLIME: (slime). Superior Lisp Interaction Mode for Emacs. +END-INFO-DIR-ENTRY + + +File: slime.info, Node: Top, Next: Introduction, Up: (dir) + +SLIME +***** + +SLIME is the “Superior Lisp Interaction Mode for Emacs”. This is the +manual for version 2.24. (Last updated March 23, 2020) + + Written by Luke Gorrie and others. + + This file has been placed in the public domain. + +* Menu: + +* Introduction:: +* Getting started:: +* SLIME mode:: +* Debugger:: +* Misc:: +* Customization:: +* Tips and Tricks:: +* Contributed Packages:: +* Credits:: +* Key Index:: +* Command Index:: +* Variable Index:: + + — The Detailed Node Listing — + +Getting started + +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: + +Downloading SLIME + +* Git:: +* Git Incantations:: + +Setup Tuning + +* Basic customization:: +* Multiple Lisps:: +* Loading Swank faster:: + +Using SLIME mode + +* User-interface conventions:: +* Evaluation:: +* Compilation:: +* Completion:: +* Finding definitions:: +* Documentation:: +* Cross-reference:: +* Macro-expansion:: +* Disassembly:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +* Semantic indentation:: +* Reader conditionals:: + +User-interface conventions + +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +* Key bindings:: + +SLDB: the SLIME debugger + +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Stepping:: +* Miscellaneous:: + +Misc + +* slime-selector:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: + +Customization + +* Emacs-side customization:: +* Lisp-side:: + +Emacs-side + +* Hooks:: + +Lisp-side (Swank) + +* Communication style:: +* Other configurables:: + +Tips and Tricks + +* Connecting to a remote lisp:: +* Global IO Redirection:: +* Auto-SLIME:: + +Connecting to a remote lisp + +* Setting up the lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: + +Contributed Packages + +* Loading Contribs:: +* REPL:: +* slime-mrepl:: +* inferior-slime-mode:: +* Compound Completion:: +* Fuzzy Completion:: +* slime-autodoc-mode:: +* ASDF:: +* Banner:: +* Editing Commands:: +* Fancy Inspector:: +* Presentations:: +* Typeout frames:: +* TRAMP:: +* Documentation Links:: +* Xref and Class Browser:: +* Highlight Edits:: +* Scratch Buffer:: +* SLIME Trace Dialog:: +* slime-sprof:: +* slime-fancy:: +* Quicklisp:: + +REPL: the “top level” + +* REPL commands:: +* Input Navigation:: +* Shortcuts:: + + + +File: slime.info, Node: Introduction, Next: Getting started, Prev: Top, Up: Top + +1 Introduction +************** + +SLIME is the “Superior Lisp Interaction Mode for Emacs.” + + SLIME extends Emacs with support for interactive programming in +Common Lisp. The features are centered around ‘slime-mode’, an Emacs +minor-mode that complements the standard ‘lisp-mode’. While ‘lisp-mode’ +supports editing Lisp source files, ‘slime-mode’ adds support for +interacting with a running Common Lisp process for compilation, +debugging, documentation lookup, and so on. + + The ‘slime-mode’ programming environment follows the example of +Emacs’s native Emacs Lisp environment. We have also included good ideas +from similar systems (such as ILISP) and some new ideas of our own. + + SLIME is constructed from two parts: a user-interface written in +Emacs Lisp, and a supporting server program written in Common Lisp. The +two sides are connected together with a socket and communicate using an +RPC-like protocol. + + The Lisp server is primarily written in portable Common Lisp. The +required implementation-specific functionality is specified by a +well-defined interface and implemented separately for each Lisp +implementation. This makes SLIME readily portable. + + +File: slime.info, Node: Getting started, Next: SLIME mode, Prev: Introduction, Up: Top + +2 Getting started +***************** + +This chapter tells you how to get SLIME up and running. + +* Menu: + +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: + + +File: slime.info, Node: Platforms, Next: Downloading, Up: Getting started + +2.1 Supported Platforms +======================= + +SLIME supports a wide range of operating systems and Lisp +implementations. SLIME runs on Unix systems, Mac OSX, and Microsoft +Windows. GNU Emacs versions 24 and 23.4 are supported. _XEmacs is not +supported anymore_. + + The supported Lisp implementations, roughly ordered from the +best-supported, are: + + • CMU Common Lisp (CMUCL), 19d or newer + • Steel Bank Common Lisp (SBCL), 1.0 or newer + • Clozure Common Lisp (CCL), version 1.3 or newer + • LispWorks, version 4.3 or newer + • Allegro Common Lisp (ACL), version 6 or newer + • CLISP, version 2.35 or newer + • Armed Bear Common Lisp (ABCL) + • Corman Common Lisp, version 2.51 or newer with the patches from + ) + • Scieneer Common Lisp (SCL), version 1.2.7 or newer + • Embedded Common Lisp (ECL) + + Most features work uniformly across implementations, but some are +prone to variation. These include the precision of placing +compiler-note annotations, XREF support, and fancy debugger commands +(like “restart frame”). + + +File: slime.info, Node: Downloading, Next: Installation, Prev: Platforms, Up: Getting started + +2.2 Downloading SLIME +===================== + +You can choose between using a released version of SLIME or accessing +our Git repository directly. You can download the latest released +version from our website: + + + + We recommend that users who participate in the ‘slime-devel’ mailing +list use the Git version of the code. + +* Menu: + +* Git:: +* Git Incantations:: + + +File: slime.info, Node: Git, Next: Git Incantations, Up: Downloading + +2.2.1 Downloading from Git +-------------------------- + +SLIME is available from the Git repository on ‘github.com’. You have +the option to use either the very latest code or the tagged +‘FAIRLY-STABLE’ snapshot. + + The latest version tends to have more features and fewer bugs than +the ‘FAIRLY-STABLE’ version, but it can be unstable during times of +major surgery. As a rule-of-thumb recommendation we suggest that if you +follow the ‘slime-devel’ mailing list then you’re better off with the +latest version (we’ll send a note when it’s undergoing major hacking). +If you don’t follow the mailing list you won’t know the status of the +latest code, so tracking ‘FAIRLY-STABLE’ or using a released version is +the safe option. + + If you download from Git then remember to ‘git pull’ occasionally. +Improvements are continually being committed, and the ‘FAIRLY-STABLE’ +tag is moved forward from time to time. + + +File: slime.info, Node: Git Incantations, Prev: Git, Up: Downloading + +2.2.2 Git incantations +---------------------- + +To download the very latest SLIME you first configure your ‘GitROOT’ and +login to the repository. + + git clone https://github.com/slime/slime.git + + You might substitute ‘https’ for ‘http’ if you’re having problems +with that protocol. + + If you want to hack on SLIME, use Github’s _fork_ functionality and +submit a _pull request_. Be sure to first read the CONTRIBUTING.md file +first. + + +File: slime.info, Node: Installation, Next: Running, Prev: Downloading, Up: Getting started + +2.3 Installation +================ + +The easiest way to install and keep SLIME up-to-date is using Emacs’s +built-in package manager. SLIME is available from the MELPA repository. +After setting up the MELPA repository, SLIME can be installed via ‘M-x +package-install RET slime RET’. You should then define your default +Lisp in your ‘.emacs’ as follows: + + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + + At this point, you should be ready to start *note running SLIME: +Running. + + This is the minimal configuration with the fewest frills. If the +basic setup is working, you can try additional modules (*note Loading +Contribs::). + +2.3.1 Installing from Git +------------------------- + +If you’d rather install SLIME directly from its git repository, you will +need to add a few extra lines in your ‘.emacs’: + + ;; _Setup load-path, autoloads and your lisp system_ + ;; _Not needed if you install SLIME via MELPA_ + (add-to-list 'load-path "~/dir/to/cloned/slime") + (require 'slime-autoloads) + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + + You may optionally byte-compile SLIME using ‘make compile +contrib-compile’. + + +File: slime.info, Node: Running, Next: Setup Tuning, Prev: Installation, Up: Getting started + +2.4 Running SLIME +================= + +SLIME is started with the Emacs command ‘M-x slime’. This uses the +‘inferior-lisp’ package to start a Lisp process, loads and starts the +Lisp-side server (known as “Swank”), and establishes a socket connection +between Emacs and Lisp. Finally a REPL buffer is created where you can +enter Lisp expressions for evaluation. + + At this point SLIME is up and running and you can start exploring. + + +File: slime.info, Node: Setup Tuning, Prev: Running, Up: Getting started + +2.5 Setup Tuning +================ + +This section explains ways to perform basic extensions to SLIME, and how +to configure SLIME for multiple Lisp systems and how to reduce SLIME’s +startup time. + + Please proceed with this section only if your basic setup works. If +you are happy with the basic setup, skip this section. + + For contrib modules *note Loading Contribs::. + +* Menu: + +* Basic customization:: +* Multiple Lisps:: +* Loading Swank faster:: + + +File: slime.info, Node: Basic customization, Next: Multiple Lisps, Up: Setup Tuning + +2.5.1 Basic customization +------------------------- + +Once you have the basic no-frills setup working, you can enhance your +SLIME installation with bundled extensions: + + ;; _Setup load-path, autoloads and your lisp system_ + (add-to-list 'load-path "~/dir/to/cloned/slime") + (require 'slime-autoloads) + ;; _Also setup the slime-fancy contrib_ + (add-to-list 'slime-contribs 'slime-fancy) + + See *note Loading Contribs:: for more information on SLIME’s contrib +system. + + To customize a particular binding in one of SLIME’s keymaps, you can +add one of the following to your init file: + + (add-hook 'slime-load-hook + (lambda () + (define-key slime-prefix-map (kbd "M-h") 'slime-documentation-lookup))) + + The former technique works only for SLIME’s core keymaps, not it’s +contribs’. For those you can use the latter form which works for any +Emacs library. See also *note Customization:: for more advanced +configuration options. + + +File: slime.info, Node: Multiple Lisps, Next: Loading Swank faster, Prev: Basic customization, Up: Setup Tuning + +2.5.2 Multiple Lisps +-------------------- + +By default, the command ‘M-x slime’ starts the program specified with +‘inferior-lisp-program’. If you invoke ‘M-x slime’ with a prefix +argument, Emacs prompts for the program which should be started instead. +If you need that frequently or if the command involves long filenames +it’s more convenient to set the ‘slime-lisp-implementations’ variable in +your ‘.emacs’. For example here we define two programs: + + (setq slime-lisp-implementations + '((cmucl ("cmucl" "-quiet")) + (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) + + This variable holds a list of programs and if you invoke SLIME with a +negative prefix argument, ‘M-- M-x slime’, you can select a program from +that list. When called without a prefix, either the name specified in +‘slime-default-lisp’, or the first item of the list will be used. The +elements of the list should look like + + (NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV) + +‘NAME’ + is a symbol and is used to identify the program. +‘PROGRAM’ + is the filename of the program. Note that the filename can contain + spaces. +‘PROGRAM-ARGS’ + is a list of command line arguments. +‘CODING-SYSTEM’ + the coding system for the connection. (*note + slime-net-coding-system::)x +‘INIT’ + should be a function which takes two arguments: a filename and a + character encoding. The function should return a Lisp expression + as a string which instructs Lisp to start the Swank server and to + write the port number to the file. At startup, SLIME starts the + Lisp process and sends the result of this function to Lisp’s + standard input. As default, ‘slime-init-command’ is used. An + example is shown in *note Loading Swank faster: init-example. +‘INIT-FUNCTION’ + should be a function which takes no arguments. It is called after + the connection is established. (See also *note + slime-connected-hook::.) +‘ENV’ + specifies a list of environment variables for the subprocess. E.g. + (sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl" + "--core" "/home/me/sbcl-cvs/output/sbcl.core") + :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/")) + initializes ‘SBCL_HOME’ in the subprocess. + + +File: slime.info, Node: Loading Swank faster, Prev: Multiple Lisps, Up: Setup Tuning + +2.5.3 Loading Swank faster +-------------------------- + +For SBCL, we recommend that you create a custom core file with socket +support and POSIX bindings included because those modules take the most +time to load. To create such a core, execute the following steps: + + shell$ sbcl + * (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) + * (save-lisp-and-die "sbcl.core-for-slime") + + After that, add something like this to your ‘.emacs’: + + (setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-for-slime")))) + + For maximum startup speed you can include the Swank server directly +in a core file. The disadvantage of this approach is that the setup is +a bit more involved and that you need to create a new core file when you +want to update SLIME or SBCL. The steps to execute are: + + shell$ sbcl + * (load ".../slime/swank-loader.lisp") + * (swank-loader:dump-image "sbcl.core-with-swank") + +Then add this to your ‘.emacs’: + + (setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-with-swank") + :init (lambda (port-file _) + (format "(swank:start-server %S)\n" port-file))))) + +Similar setups should also work for other Lisp implementations. + + +File: slime.info, Node: SLIME mode, Next: Debugger, Prev: Getting started, Up: Top + +3 Using Slime mode +****************** + +SLIME’s commands are provided via ‘slime-mode’, a minor-mode used in +conjunction with Emacs’s ‘lisp-mode’. This chapter describes the +‘slime-mode’ and its relatives. + +* Menu: + +* User-interface conventions:: +* Evaluation:: +* Compilation:: +* Completion:: +* Finding definitions:: +* Documentation:: +* Cross-reference:: +* Macro-expansion:: +* Disassembly:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +* Semantic indentation:: +* Reader conditionals:: + + +File: slime.info, Node: User-interface conventions, Next: Evaluation, Up: SLIME mode + +3.1 User-interface conventions +============================== + +To use SLIME comfortably it is important to understand a few “global” +user-interface characteristics. The most important principles are +described in this section. + +* Menu: + +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +* Key bindings:: + + +File: slime.info, Node: Temporary buffers, Next: Inferior-lisp, Up: User-interface conventions + +3.1.1 Temporary buffers +----------------------- + +Some SLIME commands create temporary buffers to display their results. +Although these buffers usually have their own special-purpose +major-modes, certain conventions are observed throughout. + + Temporary buffers can be dismissed by pressing ‘q’. This kills the +buffer and restores the window configuration as it was before the buffer +was displayed. Temporary buffers can also be killed with the usual +commands like ‘kill-buffer’, in which case the previous window +configuration won’t be restored. + + Pressing ‘RET’ is supposed to “do the most obvious useful thing.” For +instance, in an apropos buffer this prints a full description of the +symbol at point, and in an XREF buffer it displays the source code for +the reference at point. This convention is inherited from Emacs’s own +buffers for apropos listings, compilation results, etc. + + Temporary buffers containing Lisp symbols use ‘slime-mode’ in +addition to any special mode of their own. This makes the usual SLIME +commands available for describing symbols, looking up function +definitions, and so on. + + Initial focus of those “description” buffers depends on the variable +‘slime-description-autofocus’. If ‘nil’ (the default), description +buffers do not receive focus automatically, and vice versa. + + +File: slime.info, Node: Inferior-lisp, Next: Multithreading, Prev: Temporary buffers, Up: User-interface conventions + +3.1.2 ‘*inferior-lisp*’ buffer +------------------------------ + +SLIME internally uses the ‘comint’ package to start Lisp processes. +This has a few user-visible consequences, some good and some +not-so-terribly. To avoid confusion it is useful to understand the +interactions. + + The buffer ‘*inferior-lisp*’ contains the Lisp process’s own +top-level. This direct access to Lisp is useful for troubleshooting, +and some degree of SLIME integration is available using the +inferior-slime-mode. Many people load the better integrated SLIME REPL +contrib module (*note REPL::) and ignore the ‘*inferior-lisp*’ buffer. +(*note Loading Contribs:: for information on how to enable the REPL.) + + +File: slime.info, Node: Multithreading, Next: Key bindings, Prev: Inferior-lisp, Up: User-interface conventions + +3.1.3 Multithreading +-------------------- + +If the Lisp system supports multithreading, SLIME spawns a new thread +for each request, e.g., ‘C-x C-e’ creates a new thread to evaluate the +expression. An exception to this rule are requests from the REPL: all +commands entered in the REPL buffer are evaluated in a dedicated REPL +thread. + + Some complications arise with multithreading and special variables. +Non-global special bindings are thread-local, e.g., changing the value +of a let bound special variable in one thread has no effect on the +binding of the variables with the same name in other threads. This +makes it sometimes difficult to change the printer or reader behaviour +for new threads. The variable ‘swank:*default-worker-thread-bindings*’ +was introduced for such situations: instead of modifying the global +value of a variable, add a binding the +‘swank:*default-worker-thread-bindings*’. E.g., with the following +code, new threads will read floating point values as doubles by default: + + (push '(*read-default-float-format* . double-float) + swank:*default-worker-thread-bindings*). + + +File: slime.info, Node: Key bindings, Prev: Multithreading, Up: User-interface conventions + +3.1.4 Key bindings +------------------ + +In general we try to make our key bindings fit with the overall Emacs +style. We also have the following somewhat unusual convention of our +own: when entering a three-key sequence, the final key can be pressed +either with control or unmodified. For example, the +‘slime-describe-symbol’ command is bound to ‘C-c C-d d’, but it also +works to type ‘C-c C-d C-d’. We’re simply binding both key sequences +because some people like to hold control for all three keys and others +don’t, and with the two-key prefix we’re not afraid of running out of +keys. + + There is one exception to this rule, just to trip you up. We never +bind ‘C-h’ anywhere in a key sequence, so ‘C-c C-d C-h’ doesn’t do the +same thing as ‘C-c C-d h’. This is because Emacs has a built-in default +so that typing a prefix followed by ‘C-h’ will display all bindings +starting with that prefix, so ‘C-c C-d C-h’ will actually list the +bindings for all documentation commands. This feature is just a bit too +useful to clobber! + + “Are you deliberately spiting Emacs’s brilliant online help + facilities? The gods will be angry!” + +This is a brilliant piece of advice. The Emacs online help facilities +are your most immediate, up-to-date and complete resource for keybinding +information. They are your friends: + +‘C-h k ’ + ‘describe-key’ “What does this key do?” + Describes current function bound to ‘’ for focus buffer. + +‘C-h b’ + ‘describe-bindings’ “Exactly what bindings are available?” + Lists the current key-bindings for the focus buffer. + +‘C-h m’ + ‘describe-mode’ “Tell me all about this mode” + Shows all the available major mode keys, then the minor mode keys, + for the modes of the focus buffer. + +‘C-h l’ + ‘view-lossage’ “Woah, what key chord did I just do?” + Shows you the literal sequence of keys you’ve pressed in order. + + _Note:_ In this documentation the designation ‘C-h’ is a “canonical +key” which might actually mean Ctrl-h, or F1, or whatever you have +‘help-command’ bound to in your ‘.emacs’. Here is a common situation: + + (global-set-key [f1] 'help-command) + (global-set-key "\C-h" 'delete-backward-char) + +In this situation everywhere you see ‘C-h’ in the documentation you +would substitute ‘F1’. + + You can assign or change default key bindings globally using the +‘global-set-key’ function in your ‘~/.emacs’ file like this: + (global-set-key "\C-c s" 'slime-selector) +which binds ‘C-c s’ to the function ‘slime-selector’. + + Alternatively, if you want to assign or change a key binding in just +a particular slime mode, you can use the ‘define-key’ function in your +‘~/.emacs’ file like this: + (define-key slime-repl-mode-map (kbd "C-c ;") + 'slime-insert-balanced-comments) +which binds ‘C-c ;’ to the function ‘slime-insert-balanced-comments’ in +the REPL buffer. + + +File: slime.info, Node: Evaluation, Next: Compilation, Prev: User-interface conventions, Up: SLIME mode + +3.2 Evaluation commands +======================= + +These commands each evaluate a Common Lisp expression in a different +way. Usually they mimic commands for evaluating Emacs Lisp code. By +default they show their results in the echo area, but a prefix argument +causes the results to be inserted in the current buffer. + +‘C-x C-e’ +‘M-x slime-eval-last-expression’ + + Evaluate the expression before point and show the result in the + echo area. + +‘C-M-x’ +‘M-x slime-eval-defun’ + Evaluate the current toplevel form and show the result in the echo + area. ‘C-M-x’ treats ‘defvar’ expressions specially. Normally, + evaluating a ‘defvar’ expression does nothing if the variable it + defines already has a value. But ‘C-M-x’ unconditionally resets + the variable to the initial value specified in the ‘defvar’ + expression. This special feature is convenient for debugging Lisp + programs. + + If ‘C-M-x’ or ‘C-x C-e’ is given a numeric argument, it inserts the +value into the current buffer, rather than displaying it in the echo +area. + +‘C-c :’ +‘M-x slime-interactive-eval’ + Evaluate an expression read from the minibuffer. + +‘C-c C-r’ +‘M-x slime-eval-region’ + Evaluate the region. + +‘C-c C-p’ +‘M-x slime-pprint-eval-last-expression’ + Evaluate the expression before point and pretty-print the result in + a fresh buffer. + +‘C-c E’ +‘M-x slime-edit-value’ + Edit the value of a setf-able form in a new buffer ‘*Edit
*’. + The value is inserted into a temporary buffer for editing and then + set in Lisp when committed with ‘C-c C-c’. + +‘C-c C-u’ +‘M-x slime-undefine-function’ + Undefine the function, with ‘fmakunbound’, for the symbol at point. + + +File: slime.info, Node: Compilation, Next: Completion, Prev: Evaluation, Up: SLIME mode + +3.3 Compilation commands +======================== + +SLIME has fancy commands for compiling functions, files, and packages. +The fancy part is that notes and warnings offered by the Lisp compiler +are intercepted and annotated directly onto the corresponding +expressions in the Lisp source buffer. (Give it a try to see what this +means.) + +‘C-c C-c’ +‘M-x slime-compile-defun’ + Compile the top-level form at point. The region blinks shortly to + give some feedback which part was chosen. + + With (positive) prefix argument the form is compiled with maximal + debug settings (‘C-u C-c C-c’). With negative prefix argument it + is compiled for speed (‘M-- C-c C-c’). If a numeric argument is + passed set debug or speed settings to it depending on its sign. + + The code for the region is executed after compilation. In + principle, the command writes the region to a file, compiles that + file, and loads the resulting code. + +‘C-c C-k’ +‘M-x slime-compile-and-load-file’ + Compile and load the current buffer’s source file. If the + compilation step fails, the file is not loaded. It’s not always + easy to tell whether the compilation failed: occasionally you may + end up in the debugger during the load step. + + With (positive) prefix argument the file is compiled with maximal + debug settings (‘C-u C-c C-k’). With negative prefix argument it + is compiled for speed (‘M-- C-c C-k’). If a numeric argument is + passed set debug or speed settings to it depending on its sign. + +‘C-c M-k’ +‘M-x slime-compile-file’ + Compile (but don’t load) the current buffer’s source file. + +‘C-c C-l’ +‘M-x slime-load-file’ + Load a Lisp file. This command uses the Common Lisp LOAD function. + +‘M-x slime-compile-region’ + Compile the selected region. + + The annotations are indicated as underlining on source forms. The +compiler message associated with an annotation can be read either by +placing the mouse over the text or with the selection commands below. + +‘M-n’ +‘M-x slime-next-note’ + Move the point to the next compiler note and displays the note. + +‘M-p’ +‘M-x slime-previous-note’ + Move the point to the previous compiler note and displays the note. + +‘C-c M-c’ +‘M-x slime-remove-notes’ + Remove all annotations from the buffer. + +‘C-x `’ +‘M-x next-error’ + Visit the next-error message. This is not actually a SLIME command + but SLIME creates a hidden buffer so that most of the Compilation + mode commands (*note (emacs)Compilation Mode::) work similarly for + Lisp as for batch compilers. + + +File: slime.info, Node: Completion, Next: Finding definitions, Prev: Compilation, Up: SLIME mode + +3.4 Completion commands +======================= + +Completion commands are used to complete a symbol or form based on what +is already present at point. Classical completion assumes an exact +prefix and gives choices only where branches may occur. Fuzzy +completion tries harder. + +‘M-TAB’ +‘M-x slime-complete-symbol’ + Complete the symbol at point. Note that three styles of completion + are available in SLIME; the default is similar to normal Emacs + completion (*note slime-completion-at-point-functions::). + + +File: slime.info, Node: Finding definitions, Next: Documentation, Prev: Completion, Up: SLIME mode + +3.5 Finding definitions (“Meta-Point” commands). +================================================ + +The familiar ‘M-.’ command is provided. For generic functions this +command finds all methods, and with some systems it does other fancy +things (like tracing structure accessors to their ‘DEFSTRUCT’ +definition). + +‘M-.’ +‘M-x slime-edit-definition’ + Go to the definition of the symbol at point. + +‘M-,’ +‘M-*’ +‘M-x slime-pop-find-definition-stack’ + Go back to the point where ‘M-.’ was invoked. This gives + multi-level backtracking when ‘M-.’ has been used several times. + +‘C-x 4 .’ +‘M-x slime-edit-definition-other-window’ + Like ‘slime-edit-definition’ but switches to the other window to + edit the definition in. + +‘C-x 5 .’ +‘M-x slime-edit-definition-other-frame’ + Like ‘slime-edit-definition’ but opens another frame to edit the + definition in. + +‘M-x slime-edit-definition-with-etags’ + Use an ETAGS table to find definition at point. + + +File: slime.info, Node: Documentation, Next: Cross-reference, Prev: Finding definitions, Up: SLIME mode + +3.6 Documentation commands +========================== + +SLIME’s online documentation commands follow the example of Emacs Lisp. +The commands all share the common prefix ‘C-c C-d’ and allow the final +key to be modified or unmodified (*note Key bindings::.) + +‘SPC’ +‘M-x slime-space’ + The space key inserts a space, but also looks up and displays the + argument list for the function at point, if there is one. + +‘C-c C-d d’ +‘M-x slime-describe-symbol’ + Describe the symbol at point. + +‘C-c C-d f’ +‘M-x slime-describe-function’ + Describe the function at point. + +‘C-c C-d A’ +‘M-x slime-apropos’ + Perform an apropos search on Lisp symbol names for a regular + expression match and display their documentation strings. By + default the external symbols of all packages are searched. With a + prefix argument you can choose a specific package and whether to + include unexported symbols. + +‘C-c C-d z’ +‘M-x slime-apropos-all’ + Like ‘slime-apropos’ but also includes internal symbols by default. + +‘C-c C-d p’ +‘M-x slime-apropos-package’ + Show apropos results of all symbols in a package. This command is + for browsing a package at a high-level. With package-name + completion it also serves as a rudimentary Smalltalk-ish + image-browser. + +‘C-c C-d h’ +‘M-x slime-hyperspec-lookup’ + Lookup the symbol at point in the ‘Common Lisp Hyperspec’. This + uses the familiar ‘hyperspec.el’ to show the appropriate section in + a web browser. The Hyperspec is found either on the Web or in + ‘common-lisp-hyperspec-root’, and the browser is selected by + ‘browse-url-browser-function’. + + Note: this is one case where ‘C-c C-d h’ is _not_ the same as ‘C-c + C-d C-h’. + +‘C-c C-d ~’ +‘M-x hyperspec-lookup-format’ + Lookup a _format character_ in the ‘Common Lisp Hyperspec’. + +‘C-c C-d #’ +‘M-x hyperspec-lookup-reader-macro’ + Lookup a _reader macro_ in the ‘Common Lisp Hyperspec’. + + +File: slime.info, Node: Cross-reference, Next: Macro-expansion, Prev: Documentation, Up: SLIME mode + +3.7 Cross-reference commands +============================ + +SLIME’s cross-reference commands are based on the support provided by +the Lisp system, which varies widely between Lisps. For systems with no +built-in XREF support SLIME queries a portable XREF package, which is +taken from the ‘CMU AI Repository’ and bundled with SLIME. + + Each command operates on the symbol at point, or prompts if there is +none. With a prefix argument they always prompt. You can either enter +the key bindings as shown here or with the control modified on the last +key, *Note Key bindings::. + +* Menu: + +* Xref buffer commands:: + +‘C-c C-w c’ +‘M-x slime-who-calls’ + Show function callers. + +‘C-c C-w w’ +‘M-x slime-calls-who’ + Show all known callees. + +‘C-c C-w r’ +‘M-x slime-who-references’ + Show references to global variable. + +‘C-c C-w b’ +‘M-x slime-who-binds’ + Show bindings of a global variable. + +‘C-c C-w s’ +‘M-x slime-who-sets’ + Show assignments to a global variable. + +‘C-c C-w m’ +‘M-x slime-who-macroexpands’ + Show expansions of a macro. + +‘M-x slime-who-specializes’ + Show all known methods specialized on a class. + + There are also “List callers/callees” commands. These operate by +rummaging through function objects on the heap at a low-level to +discover the call graph. They are only available with some Lisp +systems, and are most useful as a fallback when precise XREF information +is unavailable. + +‘C-c <’ +‘M-x slime-list-callers’ + List callers of a function. + +‘C-c >’ +‘M-x slime-list-callees’ + List callees of a function. + + +File: slime.info, Node: Xref buffer commands, Up: Cross-reference + +3.7.1 Xref buffer commands +-------------------------- + +Commands available in Xref buffers + +‘RET’ +‘M-x slime-show-xref’ + Show definition at point in the other window. Do not leave Xref + buffer. + +‘Space’ +‘M-x slime-goto-xref’ + Show definition at point in the other window and close Xref buffer. + +‘C-c C-c’ +‘M-x slime-recompile-xref’ + Recompile definition at point. + +‘C-c C-k’ +‘M-x slime-recompile-all-xrefs’ + Recompile all definitions. + + +File: slime.info, Node: Macro-expansion, Next: Disassembly, Prev: Cross-reference, Up: SLIME mode + +3.8 Macro-expansion commands +============================ + +‘C-c C-m’ +‘M-x slime-expand-1’ + Macroexpand (or compiler-macroexpand) the expression starting at + point once. If invoked with a prefix argument use macroexpand + instead or macroexpand-1 (or compiler-macroexpand instead of + compiler-macroexpand-1). + +‘M-x slime-macroexpand-1’ + Macroexpand the expression starting at point once. If invoked with + a prefix argument, use macroexpand instead of macroexpand-1. + +‘C-c M-m’ +‘M-x slime-macroexpand-all’ + Fully macroexpand the expression starting at point. + +‘M-x slime-compiler-macroexpand-1’ + Display the compiler-macro expansion of sexp starting at point. + +‘M-x slime-compiler-macroexpand’ + Repeatedly expand compiler macros of sexp starting at point. + + For additional minor-mode commands and discussion, *note +slime-macroexpansion-minor-mode::. + + +File: slime.info, Node: Disassembly, Next: Recovery, Prev: Macro-expansion, Up: SLIME mode + +3.9 Disassembly commands +======================== + +‘C-c M-d’ +‘M-x slime-disassemble-symbol’ + Disassemble the function definition of the symbol at point. + +‘C-c C-t’ +‘M-x slime-toggle-trace-fdefinition’ + Toggle tracing of the function at point. If invoked with a prefix + argument, read additional information, like which particular method + should be traced. + +‘M-x slime-untrace-all’ + Untrace all functions. + + +File: slime.info, Node: Recovery, Next: Inspector, Prev: Disassembly, Up: SLIME mode + +3.10 Abort/Recovery commands +============================ + +‘C-c C-b’ +‘M-x slime-interrupt’ + Interrupt Lisp (send ‘SIGINT’). + +‘M-x slime-restart-inferior-lisp’ + Restart the ‘inferior-lisp’ process. + +‘C-c ~’ +‘M-x slime-sync-package-and-default-directory’ + Synchronize the current package and working directory from Emacs to + Lisp. + +‘C-c M-p’ +‘M-x slime-repl-set-package’ + Set the current package of the REPL. + +‘M-x slime-cd’ + Set the current directory of the Lisp process. This also changes + the current directory of the REPL buffer. + +‘M-x slime-pwd’ + Print the current directory of the Lisp process. + + +File: slime.info, Node: Inspector, Next: Profiling, Prev: Recovery, Up: SLIME mode + +3.11 Inspector commands +======================= + +The SLIME inspector is a Emacs-based alternative to the standard +‘INSPECT’ function. The inspector presents objects in Emacs buffers +using a combination of plain text, hyperlinks to related objects. + + The inspector can easily be specialized for the objects in your own +programs. For details see the ‘inspect-for-emacs’ generic function in +‘swank/backend.lisp’. + +‘C-c I’ +‘M-x slime-inspect’ + Inspect the value of an expression entered in the minibuffer. + + The standard commands available in the inspector are: + +‘RET’ +‘M-x slime-inspector-operate-on-point’ + If point is on a value then recursively call the inspector on that + value. If point is on an action then call that action. + +‘d’ +‘M-x slime-inspector-describe’ + Describe the slot at point. + +‘e’ +‘M-x slime-inspector-eval’ + Evaluate an expression in the context of the inspected object. The + variable ‘*’ will be bound to the inspected object. + +‘v’ +‘M-x slime-inspector-toggle-verbose’ + Toggle between verbose and terse mode. Default is determined by + ‘swank:*inspector-verbose*’. + +‘l’ +‘M-x slime-inspector-pop’ + Go back to the previous object (return from ‘RET’). + +‘n’ +‘M-x slime-inspector-next’ + The inverse of ‘l’. Also bound to ‘SPC’. + +‘g’ +‘M-x slime-inspector-reinspect’ + Reinspect. + +‘q’ +‘M-x slime-inspector-quit’ + Dismiss the inspector buffer. + +‘p’ +‘M-x slime-inspector-pprint’ + Pretty print in another buffer object at point. + +‘.’ +‘M-x slime-inspector-show-source’ + Find source of object at point. + +‘>’ +‘M-x slime-inspector-fetch-all’ + Fetch all inspector contents and go to the end. + +‘M-RET’ +‘M-x slime-inspector-copy-down’ + Store the value under point in the variable ‘*’. This can then be + used to access the object in the REPL. + +‘TAB, M-x slime-inspector-next-inspectable-object’ +‘S-TAB, M-x slime-inspector-previous-inspectable-object’ + + Jump to the next and previous inspectable object respectively. + + +File: slime.info, Node: Profiling, Next: Other, Prev: Inspector, Up: SLIME mode + +3.12 Profiling commands +======================= + +The profiling commands are based on CMUCL’s profiler. These are simple +wrappers around functions which usually print something to the output +buffer. + +‘M-x slime-toggle-profile-fdefinition’ + Toggle profiling of a function. +‘M-x slime-profile-package’ + Profile all functions in a package. +‘M-x slime-profile-by-substring’ + Profile all functions which names contain a substring. +‘M-x slime-unprofile-all’ + Unprofile all functions. +‘M-x slime-profile-report’ + Report profiler data. +‘M-x slime-profile-reset’ + Reset profiler data. +‘M-x slime-profiled-functions’ + Show list of currently profiled functions. + + +File: slime.info, Node: Other, Next: Semantic indentation, Prev: Profiling, Up: SLIME mode + +3.13 Shadowed Commands +====================== + +‘C-c C-a, M-x slime-nop’ +‘C-c C-v, M-x slime-nop’ + This key-binding is shadowed from inf-lisp. + + +File: slime.info, Node: Semantic indentation, Next: Reader conditionals, Prev: Other, Up: SLIME mode + +3.14 Semantic indentation +========================= + +SLIME automatically discovers how to indent the macros in your Lisp +system. To do this the Lisp side scans all the macros in the system and +reports to Emacs all the ones with ‘&body’ arguments. Emacs then +indents these specially, putting the first arguments four spaces in and +the “body” arguments just two spaces, as usual. + + This should “just work.” If you are a lucky sort of person you +needn’t read the rest of this section. + + To simplify the implementation, SLIME doesn’t distinguish between +macros with the same symbol-name but different packages. This makes it +fit nicely with Emacs’s indentation code. However, if you do have +several macros with the same symbol-name then they will all be indented +the same way, arbitrarily using the style from one of their arglists. +You can find out which symbols are involved in collisions with: + + (swank:print-indentation-lossage) + + If a collision causes you irritation, don’t have a nervous breakdown, +just override the Elisp symbol’s ‘common-lisp-indent-function’ property +to your taste. SLIME won’t override your custom settings, it just tries +to give you good defaults. + + A more subtle issue is that imperfect caching is used for the sake of +performance. (1) + + In an ideal world, Lisp would automatically scan every symbol for +indentation changes after each command from Emacs. However, this is too +expensive to do every time. Instead Lisp usually just scans the symbols +whose home package matches the one used by the Emacs buffer where the +request comes from. That is sufficient to pick up the indentation of +most interactively-defined macros. To catch the rest we make a full +scan of every symbol each time a new Lisp package is created between +commands – that takes care of things like new systems being loaded. + + You can use ‘M-x slime-update-indentation’ to force all symbols to be +scanned for indentation information. + + ---------- Footnotes ---------- + + (1) _Of course_ we made sure it was actually too slow before making +the ugly optimization. + + +File: slime.info, Node: Reader conditionals, Prev: Semantic indentation, Up: SLIME mode + +3.15 Reader conditional fontification +===================================== + +SLIME automatically evaluates reader-conditional expressions, like +‘#+linux’, in source buffers and “grays out” code that will be skipped +for the current Lisp connection. + + +File: slime.info, Node: Debugger, Next: Misc, Prev: SLIME mode, Up: Top + +4 SLDB: the SLIME debugger +************************** + +SLIME has a custom Emacs-based debugger called SLDB. Conditions +signalled in the Lisp system invoke SLDB in Emacs by way of the Lisp +‘*DEBUGGER-HOOK*’. + + SLDB pops up a buffer when a condition is signalled. The buffer +displays a description of the condition, a list of restarts, and a +backtrace. Commands are offered for invoking restarts, examining the +backtrace, and poking around in stack frames. + +* Menu: + +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Stepping:: +* Miscellaneous:: + + +File: slime.info, Node: Examining frames, Next: Restarts, Up: Debugger + +4.1 Examining frames +==================== + +Commands for examining the stack frame at point. + +‘t’ +‘M-x sldb-toggle-details’ + Toggle display of local variables and ‘CATCH’ tags. + +‘v’ +‘M-x sldb-show-source’ + View the frame’s current source expression. The expression is + presented in the Lisp source file’s buffer. + +‘e’ +‘M-x sldb-eval-in-frame’ + Evaluate an expression in the frame. The expression can refer to + the available local variables in the frame. + +‘d’ +‘M-x sldb-pprint-eval-in-frame’ + Evaluate an expression in the frame and pretty-print the result in + a temporary buffer. + +‘D’ +‘M-x sldb-disassemble’ + Disassemble the frame’s function. Includes information such as the + instruction pointer within the frame. + +‘i’ +‘M-x sldb-inspect-in-frame’ + Inspect the result of evaluating an expression in the frame. + +‘C-c C-c’ +‘M-x sldb-recompile-frame-source’ + Recompile frame. ‘C-u C-c C-c’ for recompiling with maximum debug + settings. + + +File: slime.info, Node: Restarts, Next: Frame Navigation, Prev: Examining frames, Up: Debugger + +4.2 Invoking restarts +===================== + +‘a’ +‘M-x sldb-abort’ + Invoke the ‘ABORT’ restart. + +‘q’ +‘M-x sldb-quit’ + “Quit” – For SLIME evaluation requests, invoke a restart which + restores to a known program state. For errors in other threads, + see *note *SLDB-QUIT-RESTART*::. + +‘c’ +‘M-x sldb-continue’ + Invoke the ‘CONTINUE’ restart. + +‘0 ... 9’ + Invoke a restart by number. + + Restarts can also be invoked by pressing ‘RET’ or ‘Mouse-2’ on them +in the buffer. + + +File: slime.info, Node: Frame Navigation, Next: Stepping, Prev: Restarts, Up: Debugger + +4.3 Navigating between frames +============================= + +‘n, M-x sldb-down’ +‘p, M-x sldb-up’ + Move between frames. + +‘M-n, M-x sldb-details-down’ +‘M-p, M-x sldb-details-up’ + Move between frames “with sugar”: hide the details of the original + frame and display the details and source code of the next. Sugared + motion makes you see the details and source code for the current + frame only. + +‘>’ +‘M-x sldb-end-of-backtrace’ + Fetch the entire backtrace and go to the last frame. + +‘<’ +‘M-x sldb-beginning-of-backtrace’ + Goto the first frame. + + +File: slime.info, Node: Stepping, Next: Miscellaneous, Prev: Frame Navigation, Up: Debugger + +4.4 Stepping +============ + +Stepping is not available in all implementations and works very +differently in those in which it is available. + +‘s’ +‘M-x sldb-step’ + Step to the next expression in the frame. For CMUCL that means, + set a breakpoint at all those code locations in the current code + block which are reachable from the current code location. + +‘x’ +‘M-x sldb-next’ + Step to the next form in the current function. + +‘o’ +‘M-x sldb-out’ + Stop single-stepping temporarily, but resume it once the current + function returns. + + +File: slime.info, Node: Miscellaneous, Prev: Stepping, Up: Debugger + +4.5 Miscellaneous Commands +========================== + +‘r’ +‘M-x sldb-restart-frame’ + Restart execution of the frame with the same arguments it was + originally called with. (This command is not available in all + implementations.) + +‘R’ +‘M-x sldb-return-from-frame’ + Return from the frame with a value entered in the minibuffer. + (This command is not available in all implementations.) + +‘B’ +‘M-x sldb-break-with-default-debugger’ + Exit SLDB and debug the condition using the Lisp system’s default + debugger. + +‘C’ +‘M-x sldb-inspect-condition’ + Inspect the condition currently being debugged. + +‘:’ +‘M-x slime-interactive-eval’ + Evaluate an expression entered in the minibuffer. +‘A’ +‘M-x sldb-break-with-system-debugger’ + Attach debugger (e.g. gdb) to the current lisp process. + + +File: slime.info, Node: Misc, Next: Customization, Prev: Debugger, Up: Top + +5 Misc +****** + +* Menu: + +* slime-selector:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: + + +File: slime.info, Node: slime-selector, Next: slime-macroexpansion-minor-mode, Up: Misc + +5.1 ‘slime-selector’ +==================== + +The ‘slime-selector’ command is for quickly switching to important +buffers: the REPL, SLDB, the Lisp source you were just hacking, etc. +Once invoked the command prompts for a single letter to specify which +buffer it should display. Here are some of the options: + +‘?’ + A help buffer listing all ‘slime-selectors’’s available buffers. +‘r’ + The REPL buffer for the current SLIME connection. +‘d’ + The most recently activated SLDB buffer for the current connection. +‘l’ + The most recently visited ‘lisp-mode’ source buffer. +‘s’ + The ‘*slime-scratch*’ buffer (*note slime-scratch::). +‘c’ + SLIME connections buffer (*note Multiple connections::). +‘n’ + Cycle to the next Lisp connection (*note Multiple connections::). +‘t’ + SLIME threads buffer (*note Multiple connections::). + + ‘slime-selector’ doesn’t have a key binding by default but we suggest +that you assign it a global one. You can bind it to ‘C-c s’ like this: + + (global-set-key "\C-cs" 'slime-selector) + +And then you can switch to the REPL from anywhere with ‘C-c s r’. + + The macro ‘def-slime-selector-method’ can be used to define new +buffers for ‘slime-selector’ to find. + + +File: slime.info, Node: slime-macroexpansion-minor-mode, Next: Multiple connections, Prev: slime-selector, Up: Misc + +5.2 slime-macroexpansion-minor-mode +=================================== + +Within a slime macroexpansion buffer some extra commands are provided +(these commands are always available but are only bound to keys in a +macroexpansion buffer). + +‘C-c C-m’ +‘M-x slime-macroexpand-1-inplace’ + Just like slime-macroexpand-1 but the original form is replaced + with the expansion. + +‘g’ +‘M-x slime-macroexpand-1-inplace’ + The last macroexpansion is performed again, the current contents of + the macroexpansion buffer are replaced with the new expansion. + +‘q’ +‘M-x slime-temp-buffer-quit’ + Close the expansion buffer. + +‘C-_’ +‘M-x slime-macroexpand-undo’ + Undo last macroexpansion operation. + + +File: slime.info, Node: Multiple connections, Prev: slime-macroexpansion-minor-mode, Up: Misc + +5.3 Multiple connections +======================== + +SLIME is able to connect to multiple Lisp processes at the same time. +The ‘M-x slime’ command, when invoked with a prefix argument, will offer +to create an additional Lisp process if one is already running. This is +often convenient, but it requires some understanding to make sure that +your SLIME commands execute in the Lisp that you expect them to. + + Some buffers are tied to specific Lisp processes. Each Lisp +connection has its own REPL buffer, and all expressions entered or SLIME +commands invoked in that buffer are sent to the associated connection. +Other buffers created by SLIME are similarly tied to the connections +they originate from, including SLDB buffers, apropos result listings, +and so on. These buffers are the result of some interaction with a Lisp +process, so commands in them always go back to that same process. + + Commands executed in other places, such as ‘slime-mode’ source +buffers, always use the “default” connection. Usually this is the most +recently established connection, but this can be reassigned via the +“connection list” buffer: + +‘C-c C-x c’ +‘M-x slime-list-connections’ + Pop up a buffer listing the established connections. It is also + available by the typing ‘c’ from the SLIME selector (*note + slime-selector::). + +‘C-c C-x n’ +‘M-x slime-cycle-connections’ + Change current Lisp connection by cycling through all connections. + It is also available by the typing ‘n’ from the SLIME selector + (*note slime-selector::). + +‘C-c C-x t’ +‘M-x slime-list-threads’ + Pop up a buffer listing the current threads. It is also available + by the typing ‘t’ from the SLIME selector (*note slime-selector::). + + The buffer displayed by ‘slime-list-connections’ gives a one-line +summary of each connection. The summary shows the connection’s serial +number, the name of the Lisp implementation, and other details of the +Lisp process. The current “default” connection is indicated with an +asterisk. + + The commands available in the connection-list buffer are: + +‘RET’ +‘M-x slime-goto-connection’ + Pop to the REPL buffer of the connection at point. + +‘d’ +‘M-x slime-connection-list-make-default’ + Make the connection at point the “default” connection. It will + then be used for commands in ‘slime-mode’ source buffers. + +‘g’ +‘M-x slime-update-connection-list’ + Update the connection list in the buffer. + +‘q’ +‘M-x slime-temp-buffer-quit’ + Quit the connection list (kill buffer, restore window + configuration). + +‘R’ +‘M-x slime-restart-connection-at-point’ + Restart the Lisp process for the connection at point. + +‘M-x slime-connect’ + Connect to a running Swank server. + +‘M-x slime-disconnect’ + Disconnect all connections. + +‘M-x slime-abort-connection’ + Abort the current attempt to connect. + + +File: slime.info, Node: Customization, Next: Tips and Tricks, Prev: Misc, Up: Top + +6 Customization +*************** + +* Menu: + +* Emacs-side customization:: +* Lisp-side:: + + +File: slime.info, Node: Emacs-side customization, Next: Lisp-side, Up: Customization + +6.1 Emacs-side +============== + +The Emacs part of SLIME can be configured with the Emacs ‘customize’ +system, just use ‘M-x customize-group slime RET’. Because the customize +system is self-describing, we only cover a few important or obscure +configuration options here in the manual. + +‘slime-truncate-lines’ + The value to use for ‘truncate-lines’ in line-by-line summary + buffers popped up by SLIME. This is ‘t’ by default, which ensures + that lines do not wrap in backtraces, apropos listings, and so on. + It can however cause information to spill off the screen. + +‘slime-completion-at-point-functions’ + A list of functions used for completion of Lisp symbols. This + works as the standard ‘completion-at-point-functions’ (*note + (elisp)Completion in Buffers::). Three completion styles are + available: ‘slime-simple-completion-at-point’, + ‘slime-complete-symbol*’ (*note Compound Completion::), and + ‘slime-fuzzy-complete-symbol’ (*note Fuzzy Completion::). + + The default is ‘slime-simple-completion-at-point’, which completes + in the usual Emacs way. + +‘slime-filename-translations’ + This variable controls filename translation between Emacs and the + Lisp system. It is useful if you run Emacs and Lisp on separate + machines which don’t share a common file system or if they share + the filesystem but have different layouts, as is the case with + SMB-based file sharing. + +‘slime-net-coding-system’ + If you want to transmit Unicode characters between Emacs and the + Lisp system, you should customize this variable. E.g., if you use + SBCL, you can set: + (setq slime-net-coding-system 'utf-8-unix) + To actually display Unicode characters you also need appropriate + fonts, otherwise the characters will be rendered as hollow boxes. + If you are using Allegro CL and GNU Emacs, you can also use + ‘emacs-mule-unix’ as coding system. GNU Emacs has often nicer + fonts for the latter encoding. (Different encodings can be used + for different Lisps, see *note Multiple Lisps::.) + +* Menu: + +* Hooks:: + + +File: slime.info, Node: Hooks, Up: Emacs-side customization + +6.1.1 Hooks +----------- + +‘slime-mode-hook’ + This hook is run each time a buffer enters ‘slime-mode’. It is + most useful for setting buffer-local configuration in your Lisp + source buffers. An example use is to enable ‘slime-autodoc-mode’ + (*note slime-autodoc-mode::). + +‘slime-connected-hook’ + This hook is run when SLIME establishes a connection to a Lisp + server. An example use is to create a Typeout frame (*Note Typeout + frames::.) + +‘sldb-hook’ + This hook is run after SLDB is invoked. The hook functions are + called from the SLDB buffer after it is initialized. An example + use is to add ‘sldb-print-condition’ to this hook, which makes all + conditions debugged with SLDB be recorded in the REPL buffer. + + +File: slime.info, Node: Lisp-side, Prev: Emacs-side customization, Up: Customization + +6.2 Lisp-side (Swank) +===================== + +The Lisp server side of SLIME (known as “Swank”) offers several +variables to configure. The initialization file ‘~/.swank.lisp’ is +automatically evaluated at startup and can be used to set these +variables. + +* Menu: + +* Communication style:: +* Other configurables:: + + +File: slime.info, Node: Communication style, Next: Other configurables, Up: Lisp-side + +6.2.1 Communication style +------------------------- + +The most important configurable is ‘SWANK:*COMMUNICATION-STYLE*’, which +specifies the mechanism by which Lisp reads and processes protocol +messages from Emacs. The choice of communication style has a global +influence on SLIME’s operation. + + The available communication styles are: + +‘NIL’ + This style simply loops reading input from the communication socket + and serves SLIME protocol events as they arise. The simplicity + means that the Lisp cannot do any other processing while under + SLIME’s control. + +‘:FD-HANDLER’ + This style uses the classical Unix-style “‘select()’-loop.” Swank + registers the communication socket with an event-dispatching + framework (such as ‘SERVE-EVENT’ in CMUCL and SBCL) and receives a + callback when data is available. In this style requests from Emacs + are only detected and processed when Lisp enters the event-loop. + This style is simple and predictable. + +‘:SIGIO’ + This style uses “signal-driven I/O” with a ‘SIGIO’ signal handler. + Lisp receives requests from Emacs along with a signal, causing it + to interrupt whatever it is doing to serve the request. This style + has the advantage of responsiveness, since Emacs can perform + operations in Lisp even while it is busy doing other things. It + also allows Emacs to issue requests concurrently, e.g. to send one + long-running request (like compilation) and then interrupt that + with several short requests before it completes. The disadvantages + are that it may conflict with other uses of ‘SIGIO’ by Lisp code, + and it may cause untold havoc by interrupting Lisp at an awkward + moment. + +‘:SPAWN’ + This style uses multiprocessing support in the Lisp system to + execute each request in a separate thread. This style has similar + properties to ‘:SIGIO’, but it does not use signals and all + requests issued by Emacs can be executed in parallel. + + The default request handling style is chosen according to the +capabilities of your Lisp system. The general order of preference is +‘:SPAWN’, then ‘:SIGIO’, then ‘:FD-HANDLER’, with ‘NIL’ as a last +resort. You can check the default style by calling +‘SWANK-BACKEND::PREFERRED-COMMUNICATION-STYLE’. You can also override +the default by setting ‘SWANK:*COMMUNICATION-STYLE*’ in your Swank init +file. + + +File: slime.info, Node: Other configurables, Prev: Communication style, Up: Lisp-side + +6.2.2 Other configurables +------------------------- + +These Lisp variables can be configured via your ‘~/.swank.lisp’ file: + +‘SWANK:*CONFIGURE-EMACS-INDENTATION*’ + This variable controls whether indentation styles for + ‘&body’-arguments in macros are discovered and sent to Emacs. It + is enabled by default. + +‘SWANK:*GLOBALLY-REDIRECT-IO*’ + When T this causes the standard streams (‘*standard-output*’, etc) + to be globally redirected to the REPL in Emacs. + + When ‘:STARTED-FROM-EMACS’ (default) redirects the output when the + lisp is launched from emacs (i.e. ‘M-x slime’), but not from ‘M-x + slime-connect’. + + When ‘NIL’ these streams are only temporarily redirected to Emacs + using dynamic bindings while handling requests. Note that + ‘*standard-input*’ is currently never globally redirected into + Emacs, because it can interact badly with the Lisp’s native REPL by + having it try to read from the Emacs one. + +‘SWANK:*GLOBAL-DEBUGGER*’ + When true (the default) this causes ‘*DEBUGGER-HOOK*’ to be + globally set to ‘SWANK:SWANK-DEBUGGER-HOOK’ and thus for SLIME to + handle all debugging in the Lisp image. This is for debugging + multithreaded and callback-driven applications. + +‘SWANK:*SLDB-QUIT-RESTART*’ + This variable names the restart that is invoked when pressing ‘q’ + (*note sldb-quit::) in SLDB. For SLIME evaluation requests this is + _unconditionally_ bound to a restart that returns to a safe point. + This variable is supposed to customize what ‘q’ does if an + application’s thread lands into the debugger (see + ‘SWANK:*GLOBAL-DEBUGGER*’). + (setf swank:*sldb-quit-restart* 'sb-thread:terminate-thread) + +‘SWANK:*BACKTRACE-PRINTER-BINDINGS*’ +‘SWANK:*MACROEXPAND-PRINTER-BINDINGS*’ +‘SWANK:*SLDB-PRINTER-BINDINGS*’ +‘SWANK:*SWANK-PPRINT-BINDINGS*’ + These variables can be used to customize the printer in various + situations. The values of the variables are association lists of + printer variable names with the corresponding value. E.g., to + enable the pretty printer for formatting backtraces in SLDB, you + can use: + (push '(*print-pretty* . t) swank:*sldb-printer-bindings*). + +‘SWANK:*USE-DEDICATED-OUTPUT-STREAM*’ + This variable controls whether to use an unsafe efficiency hack for + sending printed output from Lisp to Emacs. The default is ‘nil’, + don’t use it, and is strongly recommended to keep. + + When ‘t’, a separate socket is established solely for Lisp to send + printed output to Emacs through, which is faster than sending the + output in protocol-messages to Emacs. However, as nothing can be + guaranteed about the timing between the dedicated output stream and + the stream of protocol messages, the output of a Lisp command can + arrive before or after the corresponding REPL results. Thus output + and REPL results can end up in the wrong order, or even + interleaved, in the REPL buffer. Using a dedicated output stream + also makes it more difficult to communicate to a Lisp running on a + remote host via SSH (*note Connecting to a remote lisp::). + +‘SWANK:*DEDICATED-OUTPUT-STREAM-PORT*’ + When ‘*USE-DEDICATED-OUTPUT-STREAM*’ is ‘t’ the stream will be + opened on this port. The default value, ‘0’, means that the stream + will be opened on some random port. + +‘SWANK:*LOG-EVENTS*’ + Setting this variable to ‘t’ causes all protocol messages exchanged + with Emacs to be printed to ‘*TERMINAL-IO*’. This is useful for + low-level debugging and for observing how SLIME works “on the + wire.” The output of ‘*TERMINAL-IO*’ can be found in your Lisp + system’s own listener, usually in the buffer ‘*inferior-lisp*’. + + +File: slime.info, Node: Tips and Tricks, Next: Contributed Packages, Prev: Customization, Up: Top + +7 Tips and Tricks +***************** + +* Menu: + +* Connecting to a remote lisp:: +* Global IO Redirection:: +* Auto-SLIME:: + + +File: slime.info, Node: Connecting to a remote lisp, Next: Global IO Redirection, Up: Tips and Tricks + +7.1 Connecting to a remote lisp +=============================== + +One of the advantages of the way SLIME is implemented is that we can +easily run the Emacs side (slime.el) on one machine and the lisp backend +(swank) on another. The basic idea is to start up lisp on the remote +machine, load swank and wait for incoming SLIME connections. On the +local machine we start up emacs and tell SLIME to connect to the remote +machine. The details are a bit messier but the underlying idea is that +simple. + +* Menu: + +* Setting up the lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: + + +File: slime.info, Node: Setting up the lisp image, Next: Setting up Emacs, Up: Connecting to a remote lisp + +7.1.1 Setting up the lisp image +------------------------------- + +When you want to load swank without going through the normal, Emacs +based, process just load the ‘swank-loader.lisp’ file. Just execute + + (load "/path/to/swank-loader.lisp") + (swank-loader:init) + + inside a running lisp image(1). Now all we need to do is startup our +swank server. The first example assumes we’re using the default +settings. + + (swank:create-server) + + Since we’re going to be tunneling our connection via ssh(2) and we’ll +only have one port open we want to tell swank to not use an extra +connection for output (this is actually the default in current SLIME): + + (setf swank:*use-dedicated-output-stream* nil) + + If you need to do anything particular (like be able to reconnect to +swank after you’re done), look into ‘swank:create-server’’s other +arguments. Some of these arguments are + +‘:PORT’ + Port number for the server to listen on (default: 4005). +‘:STYLE’ + See *Note Communication style::. +‘:DONT-CLOSE’ + Boolean indicating if the server will continue to accept + connections after the first one (default: ‘NIL’). For + “long-running” lisp processes to which you want to be able to + connect from time to time, specify ‘:dont-close t’ +‘:CODING-SYSTEM’ + String designating the encoding to be used to communicate between + the Emacs and Lisp. + + So the more complete example will be + (swank:create-server :port 4005 :dont-close t :coding-system "utf-8-unix") + On the emacs side you will use something like + (setq slime-net-coding-system 'utf-8-unix) + (slime-connect "localhost" 4005)) + to connect to this lisp image from the same machine. + + ---------- Footnotes ---------- + + (1) SLIME also provides an ASDF system definition which does the same +thing + + (2) there is a way to connect without an ssh tunnel, but it has the +side-effect of giving the entire world access to your lisp image, so +we’re not going to talk about it + + +File: slime.info, Node: Setting up Emacs, Next: Setting up pathname translations, Prev: Setting up the lisp image, Up: Connecting to a remote lisp + +7.1.2 Setting up Emacs +---------------------- + +Now we need to create the tunnel between the local machine and the +remote machine. + + ssh -L4005:localhost:4005 username@remote.example.com + + That ssh invocation creates an ssh tunnel between the port 4005 on +our local machine and the port 4005 on the remote machine(1). + + Finally we can start SLIME: + + M-x slime-connect RET RET + + The ‘RET RET’ sequence just means that we want to use the default +host (‘localhost’) and the default port (‘4005’). Even though we’re +connecting to a remote machine the ssh tunnel fools Emacs into thinking +it’s actually ‘localhost’. + + ---------- Footnotes ---------- + + (1) By default swank listens for incoming connections on port 4005, +had we passed a ‘:port’ parameter to ‘swank:create-server’ we’d be using +that port number instead + + +File: slime.info, Node: Setting up pathname translations, Prev: Setting up Emacs, Up: Connecting to a remote lisp + +7.1.3 Setting up pathname translations +-------------------------------------- + +One of the main problems with running swank remotely is that Emacs +assumes the files can be found using normal filenames. if we want +things like ‘slime-compile-and-load-file’ (‘C-c C-k’) and +‘slime-edit-definition’ (‘M-.’) to work correctly we need to find a way +to let our local Emacs refer to remote files. + + There are, mainly, two ways to do this. The first is to mount, using +NFS or similar, the remote machine’s hard disk on the local machine’s +file system in such a fashion that a filename like +‘/opt/project/source.lisp’ refers to the same file on both machines. +Unfortunately NFS is usually slow, often buggy, and not always feasible, +fortunately we have an ssh connection and Emacs’ ‘tramp-mode’ can do the +rest. (See *note TRAMP User Manual: (tramp)Top.) + + What we do is teach Emacs how to take a filename on the remote +machine and translate it into something that tramp can understand and +access (and vice versa). Assuming the remote machine’s host name is +‘remote.example.com’, ‘cl:machine-instance’ returns “remote” and we +login as the user “user” we can use ‘slime-tramp’ contrib to setup the +proper translations by simply doing: + + (add-to-list 'slime-filename-translations + (slime-create-filename-translator + :machine-instance "remote" + :remote-host "remote.example.com" + :username "user")) + + +File: slime.info, Node: Global IO Redirection, Next: Auto-SLIME, Prev: Connecting to a remote lisp, Up: Tips and Tricks + +7.2 Globally redirecting all IO to the REPL +=========================================== + +When connecting via ‘M-x slime-connect’ SLIME does not change +‘*standard-output*’ and friends outside of the REPL. If you have any +other threads which call ‘format’, ‘write-string’, etc. that output +will be seen only in the ‘*inferior-lisp*’ buffer or on the terminal, +more often than not this is inconvenient. So, if you want code such as +this: + + (run-in-new-thread + (lambda () + (write-line "In some random thread.~%" *standard-output*))) + + to send its output to SLIME’s repl buffer, as opposed to +‘*inferior-lisp*’, set ‘swank:*globally-redirect-io*’ to T in +‘~/.swank.lisp’ + + But when started using ‘M-x slime’ the streams are redirected by +default. + + +File: slime.info, Node: Auto-SLIME, Prev: Global IO Redirection, Up: Tips and Tricks + +7.3 Connecting to SLIME automatically +===================================== + +To make SLIME connect to your lisp whenever you open a lisp file just +add this to your ‘.emacs’: + + (add-hook 'slime-mode-hook + (lambda () + (unless (slime-connected-p) + (save-excursion (slime))))) + + +File: slime.info, Node: Contributed Packages, Next: Credits, Prev: Tips and Tricks, Up: Top + +8 Contributed Packages +********************** + +In version 2.1 we moved some functionality to separate packages. This +chapter tells you how to load contrib modules and describes what the +particular packages do. + +* Menu: + +* Loading Contribs:: +* REPL:: +* slime-mrepl:: +* inferior-slime-mode:: +* Compound Completion:: +* Fuzzy Completion:: +* slime-autodoc-mode:: +* ASDF:: +* Banner:: +* Editing Commands:: +* Fancy Inspector:: +* Presentations:: +* Typeout frames:: +* TRAMP:: +* Documentation Links:: +* Xref and Class Browser:: +* Highlight Edits:: +* Scratch Buffer:: +* SLIME Trace Dialog:: +* slime-sprof:: +* SLIME Enhanced M-.:: +* slime-fancy:: +* Quicklisp:: + + +File: slime.info, Node: Loading Contribs, Next: REPL, Up: Contributed Packages + +8.1 Loading Contrib Packages +============================ + +Contrib packages aren’t loaded by default. You have to modify your +setup a bit so that Emacs knows where to find them and which of them to +load. Generally, you set the variable ‘slime-contribs’ with the list of +package-names that you want to use. For example, a setup to load the +‘slime-scratch’ and ‘slime-editing-commands’ packages looks like: + + ;; _Setup load-path and autoloads_ + (add-to-list 'load-path "~/dir/to/cloned/slime") + (require 'slime-autoloads) + + ;; _Set your lisp system and some contribs_ + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") + (setq slime-contribs '(slime-scratch slime-editing-commands)) + + After starting SLIME, the commands of both packages should be +available. + + The REPL and ‘slime-fancy’ modules deserve special mention. Many +users consider the REPL (*note REPL::) essential while ‘slime-fancy’ +(*note slime-fancy::) loads the REPL and almost all of the popular +contribs. So, if you aren’t sure what to choose start with: + + (setq slime-contribs '(slime-repl)) ; repl only + + If you like what you see try this: + + (setq slime-contribs '(slime-fancy)) ; almost everything + +8.1.1 Loading and unloading “on the fly” +---------------------------------------- + +We recommend that you setup contribs _before_ starting SLIME via ‘M-x +slime’, but if you want to enable more contribs _after_ you do that, you +can set the ‘slime-contribs’ variable to another value and call ‘M-x +slime-setup’. Note this though: + + • If you’ve removed contribs from the list they won’t be unloaded + automatically. + • If you have more than one SLIME connection currently active, you + must manually repeat the ‘slime-setup’ step for each of them. + + Short of restarting Emacs, a reasonable way of unloading contribs is +by calling an Emacs Lisp function whose name is obtained by adding +‘-unload’ to the contrib’s name, for every contrib you wish to unload. +So, to remove ‘slime-repl’, you must call ‘slime-repl-unload’. Because +the unload function will only, if ever, unload the Emacs Lisp side of +the contrib, you may also need to restart your lisps. + + +File: slime.info, Node: REPL, Next: slime-mrepl, Prev: Loading Contribs, Up: Contributed Packages + +8.2 REPL: the “top level” +========================= + +SLIME uses a custom Read-Eval-Print Loop (REPL, also known as a “top +level”, or listener). The REPL user-interface is written in Emacs Lisp, +which gives more Emacs-integration than the traditional ‘comint’-based +Lisp interaction: + + • Conditions signalled in REPL expressions are debugged with SLDB. + • Return values are distinguished from printed output by separate + Emacs faces (colours). + • Emacs manages the REPL prompt with markers. This ensures that Lisp + output is inserted in the right place, and doesn’t get mixed up + with user input. + + To load the REPL use ‘(add-to-list 'slime-contribs 'slime-repl)’ in +your ‘.emacs’. + +‘C-c C-z’ +‘M-x slime-switch-to-output-buffer’ + Select the output buffer, preferably in a different window. + +‘C-c C-y’ +‘M-x slime-call-defun’ + Insert a call to the function defined around point into the REPL. + +‘C-c C-j’ +‘M-x slime-eval-last-expression-in-repl’ + Inserts the last expression to the REPL and evaluates it there. + Switches to the current package of the source buffer for the + duration. If used with a prefix argument, doesn’t switch back + afterwards. + +* Menu: + +* REPL commands:: +* Input Navigation:: +* Shortcuts:: + + +File: slime.info, Node: REPL commands, Next: Input Navigation, Up: REPL + +8.2.1 REPL commands +------------------- + +‘RET’ +‘M-x slime-repl-return’ + Evaluate the current input in Lisp if it is complete. If + incomplete, open a new line and indent. If a prefix argument is + given then the input is evaluated without checking for + completeness. + +‘C-RET’ +‘M-x slime-repl-closing-return’ + Close any unmatched parenthesis and then evaluate the current input + in Lisp. Also bound to ‘M-RET’. + +‘TAB’ +‘M-x slime-indent-and-complete-symbol’ + Indent the current line and perform symbol completion. + +‘C-j’ +‘M-x slime-repl-newline-and-indent’ + Open and indent a new line. + +‘C-a’ +‘M-x slime-repl-bol’ + Go to the beginning of the line, but stop at the REPL prompt. + +‘C-c C-c’ +‘M-x slime-interrupt’ + Interrupt the Lisp process with ‘SIGINT’. + +‘C-c M-o’ +‘M-x slime-repl-clear-buffer’ + Clear the entire buffer, leaving only a prompt. + +‘C-c C-o’ +‘M-x slime-repl-clear-output’ + Remove the output and result of the previous expression from the + buffer. + + +File: slime.info, Node: Input Navigation, Next: Shortcuts, Prev: REPL commands, Up: REPL + +8.2.2 Input navigation +---------------------- + +The input navigation (a.k.a. history) commands are modelled after +‘coming’-mode. Be careful if you are used to Bash-like keybindings: +‘M-p’ and ‘M-n’ use the current input as search pattern and only work +Bash-like if the current line is empty. ‘C-’ and ‘C-’ work like +the up and down keys in Bash. + +‘C-, M-x slime-repl-forward-input’ +‘C-, M-x slime-repl-backward-input’ + Go to the next/previous history item. + +‘M-n, M-x slime-repl-next-input’ +‘M-p, M-x slime-repl-previous-input’ + Search the next/previous item in the command history using the + current input as search pattern. If ‘M-n’/‘M-n’ is typed two times + in a row, the second invocation uses the same search pattern (even + if the current input has changed). + +‘M-s, M-x slime-repl-next-matching-input’ +‘M-r, M-x slime-repl-previous-matching-input’ + Search forward/reverse through command history with regex + +‘C-c C-n, M-x slime-repl-next-prompt’ +‘C-c C-p, M-x slime-repl-previous-prompt’ + Move between the current and previous prompts in the REPL buffer. + Pressing RET on a line with old input copies that line to the + newest prompt. + + The variable ‘slime-repl-wrap-history’ controls wrap around +behaviour, i.e. whether cycling should restart at the beginning of the +history if the end is reached. + + +File: slime.info, Node: Shortcuts, Prev: Input Navigation, Up: REPL + +8.2.3 Shortcuts +--------------- + +“Shortcuts” are a special set of REPL commands that are invoked by name. +To invoke a shortcut you first press ‘,’ (comma) at the REPL prompt and +then enter the shortcut’s name when prompted. + + Shortcuts deal with things like switching between directories and +compiling and loading Lisp systems. The set of shortcuts is listed +below, and you can also use the ‘help’ shortcut to list them +interactively. + +‘change-directory (aka !d, cd)’ + Change the current directory. + +‘change-package (aka !p, in, in-package)’ + Change the current package. + +‘compile-and-load (aka cl)’ + Compile (if necessary) and load a lisp file. + +‘defparameter (aka !)’ + Define a new global, special, variable. + +‘disconnect’ + Disconnect all connections. + +‘help (aka ?)’ + Display the help. + +‘pop-directory (aka -d)’ + Pop the current directory. + +‘pop-package (aka -p)’ + Pop the top of the package stack. + +‘push-directory (aka +d, pushd)’ + Push a new directory onto the directory stack. + +‘push-package (aka +p)’ + Push a package onto the package stack. + +‘pwd’ + Show the current directory. + +‘quit’ + Quit the current Lisp. + +‘resend-form’ + Resend the last form. + +‘restart-inferior-lisp’ + Restart *inferior-lisp* and reconnect SLIME. + +‘sayoonara’ + Quit all Lisps and close all SLIME buffers. + + +File: slime.info, Node: slime-mrepl, Next: inferior-slime-mode, Prev: REPL, Up: Contributed Packages + +8.3 Multiple REPLs +================== + +The ‘slime-mrepl’ package adds support for multiple listener buffers. +The command ‘M-x slime-new-mrepl’ creates a new buffer. In a +multi-threaded Lisp, each listener is associated with a separate thread. +In a single-threaded Lisp it’s also possible to create multiple listener +buffers but the commands are executed sequentially by the same process. + + +File: slime.info, Node: inferior-slime-mode, Next: Compound Completion, Prev: slime-mrepl, Up: Contributed Packages + +8.4 ‘inferior-slime-mode’ +========================= + +The ‘inferior-slime-mode’ is a minor mode is intended to use with the +‘*inferior-lisp*’ lisp buffer. It provides some of the SLIME commands, +like symbol completion and documentation lookup. It also tracks the +current directory of the Lisp process. To install it, add something +like this to user ‘.emacs’: + + (add-to-list 'slime-contribs 'inferior-slime) + +‘M-x inferior-slime-mode’ + Turns inferior-slime-mode on or off. + + The variable ‘inferior-slime-mode-map’ contains the extra +keybindings. + + +File: slime.info, Node: Compound Completion, Next: Fuzzy Completion, Prev: inferior-slime-mode, Up: Contributed Packages + +8.5 Compound Completion +======================= + +The package ‘slime-c-p-c’ provides a different symbol completion +algorithm, which performs completion “in parallel” over the +hyphen-delimited sub-words of a symbol name. (1) Formally this means +that “‘a-b-c’” can complete to any symbol matching the regular +expression “‘^a.*-b.*-c.*’” (where “dot” matches anything but a hyphen). +Examples give a more intuitive feeling: + • ‘m-v-b’ completes to ‘multiple-value-bind’. + • ‘w-open’ is ambiguous: it completes to either ‘with-open-file’ or + ‘with-open-stream’. The symbol is expanded to the longest common + completion (‘with-open-’) and the point is placed at the first + point of ambiguity, which in this case is the end. + • ‘w--stream’ completes to ‘with-open-stream’. + + The variable ‘slime-c-p-c-unambiguous-prefix-p’ specifies where point +should be placed after completion. E.g. the possible completions for +‘f-o’ are ‘finish-output’ and ‘force-output’. By the default point is +moved after the ‘f’, because that is the unambiguous prefix. If +‘slime-c-p-c-unambiguous-prefix-p’ is nil, point moves to the end of the +inserted text, after the ‘o’ in this case. + + In addition, ‘slime-c-p-c’ provides completion for character names +(mostly useful for Unicode-aware implementations): + + CL-USER> #\Sp + + Here SLIME will usually complete the character to ‘#\Space’, but in a +Unicode-aware implementation, this might provide the following +completions: + Space Space + Sparkle Spherical_Angle + Spherical_Angle_Opening_Left Spherical_Angle_Opening_Up + + The package ‘slime-c-p-c’ also provides context-sensitive completion +for keywords. Example: + + CL-USER> (find 1 '(1 2 3) :s + + Here SLIME will complete ‘:start’, rather than suggesting all +ever-interned keywords starting with ‘:s’. + +‘C-c C-s’ +‘M-x slime-complete-form’ + Looks up and inserts into the current buffer the argument list for + the function at point, if there is one. More generally, the + command completes an incomplete form with a template for the + missing arguments. There is special code for discovering extra + keywords of generic functions and for handling ‘make-instance’, + ‘defmethod’, and many other functions. Examples: + + (subseq "abc" + --inserts--> start [end]) + (find 17 + --inserts--> sequence :from-end from-end :test test + :test-not test-not :start start :end end + :key key) + (find 17 '(17 18 19) :test #'= + --inserts--> :from-end from-end + :test-not test-not :start start :end end + :key key) + (defclass foo () ((bar :initarg :bar))) + (defmethod print-object + --inserts--> (object stream) + body...) + (defmethod initialize-instance :after ((object foo) &key blub)) + (make-instance 'foo + --inserts--> :bar bar :blub blub initargs...) + + ---------- Footnotes ---------- + + (1) This style of completion is modelled on ‘completer.el’ by Chris +McConnell. That package is bundled with ILISP. + + +File: slime.info, Node: Fuzzy Completion, Next: slime-autodoc-mode, Prev: Compound Completion, Up: Contributed Packages + +8.6 Fuzzy Completion +==================== + +The package ‘slime-fuzzy’ implements yet another symbol completion +heuristic. + +‘C-c M-i’ +‘M-x slime-fuzzy-complete-symbol’ + Presents a list of likely completions to choose from for an + abbreviation at point. If you set the variable + ‘slime-complete-symbol-function’ to this command, fuzzy completion + will also be used for ‘M-TAB’. + +8.6.1 The Algorithm +------------------- + +It attempts to complete a symbol all at once, instead of in pieces. For +example, “mvb” will find “‘multiple-value-bind’” and “norm-df” will find +“‘least-positive-normalized-double-float’”. + + The algorithm tries to expand every character in various ways and +rates the list of possible completions with the following heuristic. + + Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at the +beginning of a string are scored highest. Letters after a word +separator such as #\- are scored next highest. Letters at the end of a +string or before a suffix letter at the end of a string are scored +medium, and letters anywhere else are scored low. + + If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter’s value, it will use that percentage instead. + + Finally, a small scaling factor is applied to favor shorter matches, +all other things being equal. + +8.6.2 Duplicate Symbols +----------------------- + +In case a symbol is accessible via several packages, duplicate symbol +filter specified via ‘*fuzzy-duplicate-symbol-filter*’ swank variable is +applied. ‘:nearest-package’ value specifies that only symbols in the +package with highest score should be kept. ‘:home-package’ specifies +that only the match that represents the home package of the symbol is +used, and ‘:all’ value specifies that duplicate symbol filter mode +should be turned off. + + To specify a custom filter, set ‘*fuzzy-duplicate-symbol-filter*’ to +a function accepting three arguments: the name of package being +examined, the list of names of all packages being examined with packages +with highest matching score listed first and an ‘equal’ hash-table that +is shared between calls to the function and can be used for +deduplication purposes. The function should return a deduplication +filter function which accepts a symbol and returns true if the symbol +should be kept. + + For example, the effect of ‘:nearest-package’ can be also achieved by +specifying the following custom filter in ‘~/.swank.lisp’: + (setf *fuzzy-duplicate-symbol-filter* + (lambda (cur-package all-packages dedup-table) + (declare (ignore cur-package all-packages)) + (lambda (symbol) + (unless (gethash (symbol-name symbol) dedup-table) + (setf (gethash (symbol-name symbol) dedup-table) t))))) + And instead of ‘:home-package’, the following can be used: + (setf *fuzzy-duplicate-symbol-filter* + (lambda (cur-package all-packages dedup-table) + (declare (ignore dedup-table)) + (let ((packages (mapcar #'find-package + (remove cur-package all-packages)))) + (lambda (symbol) + (not (member (symbol-package symbol) packages)))))) + + +File: slime.info, Node: slime-autodoc-mode, Next: ASDF, Prev: Fuzzy Completion, Up: Contributed Packages + +8.7 ‘slime-autodoc-mode’ +======================== + +Autodoc mode is an additional minor-mode for automatically showing +information about symbols near the point. For function names the +argument list is displayed, and for global variables, the value. +Autodoc is implemented by means of ‘eldoc-mode’ of Emacs. + + The mode can be enabled by default in your ‘~/.emacs’: + (add-to-list 'slime-contribs 'slime-autodoc) + +‘M-x slime-arglist NAME’ + Show the argument list of the function NAME. + +‘M-x slime-autodoc-mode’ + Toggles autodoc-mode on or off according to the argument, and + toggles the mode when invoked without argument. +‘C-c C-d a’ +‘M-x slime-autodoc-manually’ + Like slime-autodoc, but when called twice, or after slime-autodoc + was already automatically called, display multiline arglist. + + If the variable ‘slime-use-autodoc-mode’ is set (default), Emacs +starts a timer, otherwise the information is only displayed after +pressing SPC. + + If ‘slime-autodoc-use-multiline-p’ is set to non-nil, allow long +autodoc messages to resize echo area display. + + ‘slime-autodoc-mode-string’ is a string that will be displayed in the +mode line when autodoc-mode is enabled, or nil, if you prefer no +indication. You can customize this variable. + + +File: slime.info, Node: ASDF, Next: Banner, Prev: slime-autodoc-mode, Up: Contributed Packages + +8.8 ASDF +======== + +ASDF is a popular “system construction tool”. The package ‘slime-asdf’ +provides some commands to load and compile such systems from Emacs. +ASDF itself is not included with SLIME; you have to load that yourself +into your Lisp. In particular, you must load ASDF before you connect, +otherwise you will get errors about missing symbols. + +‘M-x slime-load-system NAME’ + Compile and load an ASDF system. The default system name is taken + from the first file matching *.asd in the current directory. +‘M-x slime-reload-system NAME’ + Recompile and load an ASDF system without recompiling its + dependencies. +‘M-x slime-open-system NAME &optional LOAD’ + Open all files in a system, optionally load it if LOAD is non-nil. +‘M-x slime-browse-system NAME’ + Browse files in a system using Dired. +‘M-x slime-delete-system-fasls NAME’ + Delete FASLs produced by compiling a system. +‘M-x slime-rgrep-system NAME REGEXP’ + Run ‘rgrep’ on the base directory of an ASDF system. +‘M-x slime-isearch-system NAME’ + Run ‘isearch-forward’ on the files of an ASDF system. +‘M-x slime-query-replace-system NAME FROM TO &OPTIONAL DELIMITED’ + Run ‘query-replace’ on an ASDF system. + The package also installs some new REPL shortcuts (*note +Shortcuts::): + +‘load-system’ + Compile (as needed) and load an ASDF system. +‘reload-system’ + Recompile and load an ASDF system. +‘compile-system’ + Compile (but not load) an ASDF system. +‘force-compile-system’ + Recompile (but not load) an ASDF system. +‘force-load-system’ + Recompile and load an ASDF system. +‘open-system’ + Open all files in a system. +‘browse-system’ + Browse files in a system using Dired. +‘delete-system-fasls’ + Delete FASLs produced by compiling a system. + + +File: slime.info, Node: Banner, Next: Editing Commands, Prev: ASDF, Up: Contributed Packages + +8.9 Banner +========== + +The package ‘slime-banner’ installs a window header line ( *note +(elisp)Header Lines::.) in the REPL buffer. It also runs an animation +at startup. + + By setting the variable ‘slime-startup-animation’ to nil you can +disable the animation respectively with the variable +‘slime-header-line-p’ the header line. + + +File: slime.info, Node: Editing Commands, Next: Fancy Inspector, Prev: Banner, Up: Contributed Packages + +8.10 Editing Commands +===================== + +The package ‘slime-editing-commands’ provides some commands to edit Lisp +expressions. + +‘C-c M-q’ +‘M-x slime-reindent-defun’ + Re-indents the current defun, or refills the current paragraph. If + point is inside a comment block, the text around point will be + treated as a paragraph and will be filled with ‘fill-paragraph’. + Otherwise, it will be treated as Lisp code, and the current defun + will be reindented. If the current defun has unbalanced parens, an + attempt will be made to fix it before reindenting. + +‘C-c C-]’ +‘M-x slime-close-all-parens-in-sexp’ + Balance parentheses of open s-expressions at point. Insert enough + right parentheses to balance unmatched left parentheses. Delete + extra left parentheses. Reformat trailing parentheses + Lisp-stylishly. + + If REGION is true, operate on the region. Otherwise operate on the + top-level sexp before point. + +‘M-x slime-insert-balanced-comments’ + Insert a set of balanced comments around the s-expression + containing the point. If this command is invoked repeatedly + (without any other command occurring between invocations), the + comment progressively moves outward over enclosing expressions. If + invoked with a positive prefix argument, the s-expression arg + expressions out is enclosed in a set of balanced comments. + +‘M-C-a’ +‘M-x slime-beginning-of-defun’ +‘M-C-e’ +‘M-x slime-end-of-defun’ + + +File: slime.info, Node: Fancy Inspector, Next: Presentations, Prev: Editing Commands, Up: Contributed Packages + +8.11 Fancy Inspector +==================== + +An alternative to default inspector is provided by the package +‘slime-fancy-inspector’. This inspector knows a lot about CLOS objects +and methods. It provides many “actions” that can be selected to invoke +Lisp code on the inspected object. For example, to present a generic +function the inspector shows the documentation in plain text and +presents each method with both a hyperlink to inspect the method object +and a “remove method” action that you can invoke interactively. The +key-bindings are the same as for the basic inspector (*note +Inspector::). + + +File: slime.info, Node: Presentations, Next: Typeout frames, Prev: Fancy Inspector, Up: Contributed Packages + +8.12 Presentations +================== + +A “presentation”(1) in SLIME is a region of text associated with a Lisp +object. Right-clicking on the text brings up a menu with operations for +the particular object. Some operations, like inspecting, are available +for all objects, but the object may also have specialized operations. +For instance, pathnames have a dired operation. + + More importantly, it is possible to cut and paste presentations +(i.e., Lisp objects, not just their printed presentation), using all +standard Emacs commands. This way it is possible to cut and paste the +results of previous computations in the REPL. This is of particular +importance for unreadable objects. + + The package ‘slime-presentations’ installs presentations in the REPL, +i.e. the results of evaluation commands become presentations. In this +way, presentations generalize the use of the standard Common Lisp REPL +history variables ‘*’, ‘**’, ‘***’. Example: + + CL-USER> (find-class 'standard-class) + _#_ + CL-USER> + + Presentations appear in red color in the buffer. (In this manual, we +indicate the presentations _like this_.) Using standard Emacs commands, +the presentation can be copied to a new input in the REPL: + + CL-USER> (eql '_#_ + '_#_) + _T_ + + Note that standard evaluation and quoting rules still apply. So if a +presentation is a list, it needs to be quoted in an evaluated context to +avoid treating it as a function call: + + CL-USER> (list (find-class 'standard-class) 2 3 4) + _(# 2 3 4)_ + CL-USER> _(# 2 3 4)_ + ; Funcall of # which is a non-function. + ; Evaluation aborted. + CL-USER> '_(# 2 3 4)_ + (# 2 3 4) + + When you copy an incomplete presentation or edit the text within a +presentation, the presentation changes to plain text, losing the +association with a Lisp object. In the buffer, this is indicated by +changing the color of the text from red to black. This can be undone. + + Presentations are also available in the inspector (all inspectable +parts are presentations) and the debugger (all local variables are +presentations). This makes it possible to evaluate expressions in the +REPL using objects that appear in local variables of some active +debugger frame; this can be more convenient than using ‘M-x +sldb-eval-in-frame’. *Warning:* The presentations that stem from the +inspector and debugger are only valid as long as the corresponding +buffers are open. Using them later can cause errors or confusing +behavior. + + For some Lisp implementations you can also install the package +‘slime-presentation-streams’, which enables presentations on the Lisp +‘*standard-output*’ stream and similar streams. This means that not +only results of computations, but also some objects that are printed to +the standard output (as a side-effect of the computation) are associated +with presentations. Currently, all unreadable objects and pathnames get +printed as presentations. + + CL-USER> (describe (find-class 'standard-object)) + _#_ is an instance of + _#_: + The following slots have :INSTANCE allocation: + PLIST NIL + FLAGS 1 + DIRECT-METHODS ((_#_ + ... + + Again, this makes it possible to inspect and copy-paste these +objects. + + In addition to the standard Emacs commands, there are several +keyboard commands, a menu-bar menu, and a context menu to operate on +presentations. We describe the keyboard commands below; they are also +shown in the menu-bar menu. + +‘C-c C-v SPC’ +‘M-x slime-mark-presentation’ + If point is within a presentation, move point to the beginning of + the presentation and mark to the end of the presentation. This + makes it possible to copy the presentation. + +‘C-c C-v w’ +‘M-x slime-copy-presentation-at-point-to-kill-ring’ + If point is within a presentation, copy the surrounding + presentation to the kill ring. + +‘C-c C-v r’ +‘M-x slime-copy-presentation-at-point-to-repl’ + If point is within a presentation, copy the surrounding + presentation to the REPL. + +‘C-c C-v d’ +‘M-x slime-describe-presentation-at-point’ + If point is within a presentation, describe the associated object. + +‘C-c C-v i’ +‘M-x slime-inspect-presentation-at-point’ + If point is within a presentation, inspect the associated object + with the SLIME inspector. + +‘C-c C-v n’ +‘M-x slime-next-presentation’ + Move point to the next presentation in the buffer. + +‘C-c C-v p’ +‘M-x slime-previous-presentation’ + Move point to the previous presentation in the buffer. + + Similar operations are also possible from the context menu of every +presentation. Using ‘mouse-3’ on a presentation, the context menu opens +and offers various commands. For some objects, specialized commands are +also offered. Users can define additional specialized commands by +defining a method for ‘swank::menu-choices-for-presentation’. + + *Warning:* On Lisp implementations without weak hash tables, all +objects associated with presentations are protected from garbage +collection. If your Lisp image grows too large because of that, use +‘C-c C-v M-o’ (‘slime-clear-presentations’) to remove these +associations. You can also use the command ‘C-c M-o’ +(‘slime-repl-clear-buffer’), which both clears the REPL buffer and +removes all associations of objects with presentations. + + *Warning:* Presentations can confuse new users. + + CL-USER> (cons 1 2) + _(1 . 2)_ + CL-USER> (eq '_(1 . 2)_ '_(1 . 2)_) + _T_ + + One could have expected ‘NIL’ here, because it looks like two fresh +cons cells are compared regarding object identity. However, in the +example the presentation ‘_(1 . 2)_’ was copied twice to the REPL. Thus +‘EQ’ is really invoked with the same object, namely the cons cell that +was returned by the first form entered in the REPL. + + ---------- Footnotes ---------- + + (1) Presentations are a feature originating from the Lisp machines. +It was possible to define ‘present’ methods specialized to various +devices, e.g. to draw an object to bitmapped screen or to write some +text to a character stream. + + +File: slime.info, Node: Typeout frames, Next: TRAMP, Prev: Presentations, Up: Contributed Packages + +8.13 Typeout frames +=================== + +A “typeout frame” is a special Emacs frame which is used instead of the +echo area (minibuffer) to display messages from SLIME commands. This is +an optional feature. The advantage of a typeout frame over the echo +area is that it can hold more text, it can be scrolled, and its contents +don’t disappear when you press a key. All potentially long messages are +sent to the typeout frame, such as argument lists, macro expansions, and +so on. + +‘M-x slime-ensure-typeout-frame’ + Ensure that a typeout frame exists, creating one if necessary. + + If the typeout frame is closed then the echo area will be used again +as usual. + + To have a typeout frame created automatically at startup you should +load the ‘slime-typeout-frame’ package. (*note Loading Contribs::.) + + The variable ‘slime-typeout-frame-properties’ specifies the height +and possibly other properties of the frame. Its value is passed to +‘make-frame’. (*note (elisp)Creating Frames::.) + + +File: slime.info, Node: TRAMP, Next: Documentation Links, Prev: Typeout frames, Up: Contributed Packages + +8.14 TRAMP +========== + +The package ‘slime-tramp’ provides some functions to set up filename +translations for TRAMP. (*note Setting up pathname translations::) + + +File: slime.info, Node: Documentation Links, Next: Xref and Class Browser, Prev: TRAMP, Up: Contributed Packages + +8.15 Documentation Links +======================== + +For certain error messages, SBCL includes references to the ANSI +Standard or the SBCL User Manual. The ‘slime-references’ package turns +those references into clickable links. This makes finding the +referenced section of the HyperSpec much easier. + + +File: slime.info, Node: Xref and Class Browser, Next: Highlight Edits, Prev: Documentation Links, Up: Contributed Packages + +8.16 Xref and Class Browser +=========================== + +A rudimentary class browser is provided by the ‘slime-xref-browser’ +package. + +‘M-x slime-browse-classes’ + This command asks for a class name and displays inheritance tree of + for the class. + +‘M-x slime-browse-xrefs’ + This command prompts for a symbol and the kind of cross reference, + e.g. callers. The cross reference tree rooted at the symbol is + then then displayed. + + +File: slime.info, Node: Highlight Edits, Next: Scratch Buffer, Prev: Xref and Class Browser, Up: Contributed Packages + +8.17 Highlight Edits +==================== + +‘slime-highlight-edits’ is a minor mode to highlight those regions in a +Lisp source file which are modified. This is useful to quickly find +those functions which need to be recompiled (with ‘C-c C-c’) + +‘M-x slime-highlight-edits-mode’ + Turns ‘slime-highlight-edits-mode’ on or off. + + +File: slime.info, Node: Scratch Buffer, Next: SLIME Trace Dialog, Prev: Highlight Edits, Up: Contributed Packages + +8.18 Scratch Buffer +=================== + +The SLIME scratch buffer, in contrib package ‘slime-scratch’, imitates +Emacs’ usual ‘*scratch*’ buffer. If ‘slime-scratch-file’ is set, it is +used to back the scratch buffer, making it persistent. The buffer is +like any other Lisp buffer, except for the command bound to ‘C-j’. + +‘C-j’ +‘M-x slime-eval-print-last-expression’ + Evaluate the expression sexp before point and insert print value + into the current buffer. + +‘M-x slime-scratch’ + Create a ‘*slime-scratch*’ buffer. In this buffer you can enter + Lisp expressions and evaluate them with ‘C-j’, like in Emacs’s + ‘*scratch*’ buffer. + + +File: slime.info, Node: SLIME Trace Dialog, Next: slime-sprof, Prev: Scratch Buffer, Up: Contributed Packages + +8.19 SLIME Trace Dialog +======================= + +The SLIME Trace Dialog, in package ‘slime-trace-dialog’, is a tracing +facility, similar to Common Lisp’s ‘trace’, but interactive rather than +purely textual. It is an Emacs 24-only contrib. + + You use it just like you would regular ‘trace’: after tracing a +function, calling it causes interesting information about that +particular call to be reported. + + However, instead of printing the trace results to the the +‘*trace-output*’ stream (usually the REPL), the SLIME Trace Dialog +collects and stores them in your lisp environment until, on user’s +request, they are fetched into Emacs and displayed in a dialog-like +interactive view. + + To use this contrib, add it to ‘slime-contribs’ in your ‘~/.emacs’, +either directly by setting up ‘slime-fancy’ (*note slime-fancy::). + + ;; setting up 'slime-fancy would also have worked + (add-to-list 'slime-contribs 'slime-trace-dialog) + + After starting up SLIME, SLIME’s Trace Dialog installs a _Trace_ menu +in the menu-bar of any ‘slime-mode’ buffer and adds two new commands, +with respective key-bindings: + +‘C-c M-t’ +‘M-x slime-trace-dialog-toggle-trace’ + If point is on a symbol name, toggle tracing of its function + definition. If point is not on a symbol, prompt user for a + function. + + With a ‘C-u’ prefix argument, and if your lisp implementation + allows it, attempt to decipher lambdas, methods and other + complicated function signatures. + + The function is traced for the SLIME Trace Dialog only, i.e. it is + not found in the list returned by Common Lisp’s ‘trace’. + +‘C-c T’ +‘M-x slime-trace-dialog’ + Pop to the interactive SLIME Trace Dialog buffer associated with + the current connection (*note Multiple connections::). + + Consider the (useless) program: + + (defun foo (n) (if (plusp n) (* n (bar (1- n))) 1)) + (defun bar (n) (if (plusp n) (* n (foo (1- n))) 1)) + + After tracing both ‘foo’ and ‘bar’ with ‘C-c M-t’, calling call ‘(foo +2)’ and moving to the trace dialog with ‘C-c T’, we are presented with +this buffer. + + Traced specs (2) [refresh] + [untrace all] + [untrace] common-lisp-user::bar + [untrace] common-lisp-user::foo + + Trace collection status (3/3) [refresh] + [clear] + + 0 - common-lisp-user::foo + | > 2 + | < 2 + 1 `--- common-lisp-user::bar + | > 1 + | < 1 + 2 `-- common-lisp-user::foo + > 0 + < 1 + + The dialog is divided into sections displaying the functions already +traced, the trace collection progress and the actual trace tree that +follow your program’s logic. The most important key-bindings in this +buffer are: + +‘g’ +‘M-x slime-trace-dialog-fetch-status’ + Update information on the trace collection and traced specs. +‘G’ +‘M-x slime-trace-dialog-fetch-traces’ + Fetch the next batch of outstanding (not fetched yet) traces. With + a ‘C-u’ prefix argument, repeat until no more outstanding traces. +‘C-k’ +‘M-x slime-trace-dialog-clear-fetched-traces’ + Prompt for confirmation, then clear all traces, both fetched and + outstanding. + + The arguments and return values below each entry are interactive +buttons. Clicking them opens the inspector (*note Inspector::). +Invoking ‘M-RET’ (‘slime-trace-dialog-copy-down-to-repl’) returns them +to the REPL for manipulation (*note REPL::). The number left of each +entry indicates its absolute position in the calling order, which might +differ from display order in case multiple threads call the same traced +function. + + ‘slime-trace-dialog-hide-details-mode’ hides arguments and return +values so you can concentrate on the calling logic. Additionally, +‘slime-trace-dialog-autofollow-mode’ will automatically display +additional detail about an entry when the cursor moves over it. + + +File: slime.info, Node: slime-sprof, Next: SLIME Enhanced M-., Prev: SLIME Trace Dialog, Up: Contributed Packages + +8.20 ‘slime-sprof’ +================== + +‘slime-sprof’ is a package for integrating SBCL’s statistical profiler, +sb-sprof. + + The variable ‘slime-sprof-exclude-swank’ controls whether to display +swank functions. The default value is NIL. + +‘M-x slime-sprof-start’ + Start profiling. + +‘M-x slime-sprof-stop’ + Stop profiling. +‘M-x slime-sprof-report’ + Report results of the profiling. + + The following keys are defined in slime-sprof-browser mode: + +‘RET’ +‘M-x slime-sprof-browser-toggle’ + Expand / collapse function details (callers, calls to) +‘v’ +‘M-x slime-sprof-browser-view-source’ + View function sources. +‘d’ +‘M-x slime-sprof-browser-disassemble-function’ + Disassemble function. +‘s’ +‘M-x slime-sprof-toggle-swank-exclusion’ + Toggle exclusion of swank functions from the report. + + +File: slime.info, Node: SLIME Enhanced M-., Next: slime-fancy, Prev: slime-sprof, Up: Contributed Packages + +8.21 SLIME Enhanced M-. +======================= + +‘slime-mdot-fu’ enables meta-point to jump to local variables bound with +‘let’ and ‘let*’, in addition to function bindings declared with ‘flet’ +and ‘labels’, via ‘slime-edit-local-definition’. + + +File: slime.info, Node: slime-fancy, Next: Quicklisp, Prev: SLIME Enhanced M-., Up: Contributed Packages + +8.22 Meta package: ‘slime-fancy’ +================================ + +‘slime-fancy’ is a meta package which loads a combination of the most +popular packages. + + +File: slime.info, Node: Quicklisp, Prev: slime-fancy, Up: Contributed Packages + +8.23 Quicklisp +============== + +The package ‘slime-quicklisp’ adds support for loading Quicklisp systems +in the REPL buffer. In order for this to work, Quicklisp should have +already been loaded in the Lisp implementation. Refer to + for Quicklisp installation details. + + The package installs the following REPL shortcuts (*note +Shortcuts::): + +‘quicklisp-quickload (aka ql)’ + Load a Quicklisp system. + + +File: slime.info, Node: Credits, Next: Key Index, Prev: Contributed Packages, Up: Top + +9 Credits +********* + +_The soppy ending..._ + +Hackers of the good hack +======================== + +SLIME is an Extension of SLIM by Eric Marsden. At the time of writing, +the authors and code-contributors of SLIME are: + +Helmut Eller Tobias C. Rittweiler Stas Boukarev +Luke Gorrie Matthias Koeppe Luís Oliveira +Nikodemus Siivola Marco Baringer João Távora +Alan Ruttenberg Henry Harrington Mark Evenson +Christophe Rhodes Edi Weitz Martin Simmons +Juho Snellman Attila Lendvai Peter Seibel +Geo Carncross Douglas Crosher Daniel Kochmanski +Gábor Melis Daniel Barlow Wolfgang Jenkner +Stelian Ionescu Michael Weber Didier Verna +Lawrence Mitchell Anton Kovalenko Terje Norderhaug +Jan Moringen Brian Downing Bill Clementson +Andras Simon Adlai Chandrasekhar Zach Beane +Ivan Shvedunov Francois-Rene Rideau Espen Wiborg +António Menezes Leitão Utz-Uwe Haus Thomas Schilling +Thomas F. Burdick Takehiko Abe Sébastien Villemot +Richard M Kreuter Raymond Toy Matthew Danish +Mark Harig James Bielman Harald Hanche-Olsen +Ariel Badichi Andreas Fuchs Willem Broekema +Taylor R. Campbell Phil Hargett Paulo Madeira +Lars Magne John Paul Wallington Joerg Hoehle +Ingebrigtsen +David Reitter Bryan O’Connor Alexander Artemenko +Alan Shutko Ursa americanus Travis Cross + kermodei +Tobias Rittweiler Tiago Maduro-Dias Stefan Kamphausen +Sean O’Rourke Robert Lehr Robert E. Brown +Philipp Marek Peter S. Housel Nathan Trapuzzano +Nathan Bird Luís Borges de Jouni K Seppanen + Oliveira +Jon Oddie Ivan Toshkov Ian Eslick +Geoff Wozniak Gary King Fice T +Eric Blood Eduardo Muñoz Douglas Katzman +Christophe Junke Christian Schafmeister Christian Lynbech +Chris Capel Charles Zhang Bjørn Nordbø +Bart Botta Anton Vodonosov Alexey Dejneka +Alan Caulkins Yu-Chiang Hsu Yaroslav Kavenchuk +YOKOTA Yuki Wolfgang Mederle Wojciech Kaczmarek +William Bland Vitaly Mayatskikh Tomas Zellerin +Tom Pierce Tim Daly Jr. Syohei YOSHIDA +Sven Van Caekenberghe Svein Ove Aas Steve Smith +StanisBaw Halik Sergey Kostyaev Samuel Freilich +Russell McManus Russ Tyndall Rui Patrocínio +Robert P. Goldman Robert Macomber Robert Brown +Reini Urban R. Matthew Emerson Peter Feigl +Peter Pawel Ostrowski Paul Donnelly +Paul Collins Olof-Joachim Frahm Neil Van Dyke +NIIMI Satoshi Mészáros Levente Mikel Bancroft +Michał Herda Michael White Matthew Kennedy +Matthew D. Swank Matt Pillsbury Masayuki Onjo +Mark Wooding Mark Karpov Mark H. David +Marco Monteiro Lynn Quam Levente Mészáros +Leo Liu Lasse Rasinen Knut Olav Bøhmer +Kai Kaminski Julian Stecklina Juergen Gmeiner +Jon Allen Boone John Stracke John Smith +Johan Bockgård Joe Robertson Jim Newton +Javier Olaechea Jan Rychter James McIlree +Jack Pugmire Ivan Sokolov Ivan Boldyrev +Ignas Mikalajunas Hannu Koivisto Graham Dobbins +Gerd Flaig Gail Zacharias Frederic Brunel +Eric Timmons Dustin Long Dmitry Igrishin +Deokhwan Kim Denis Budyak Daniel Koning +Daniel Kochmański Dan Weinreb Dan Pierson +Cyrus Harmon Chris Schafmeister Cecil Westerhof +Brian Mastenbrook Brandon Bergren Bozhidar Batsov +Bob Halley Barry Fishman B.Scott Michel +Angelo Rossi Andrew Myers Aleksandar Bakic +Alain Picard Adam Bozanich + + ... not counting the bundled code from ‘hyperspec.el’, ‘CLOCC’, and +the ‘CMU AI Repository’. + + Many people on the ‘slime-devel’ mailing list have made non-code +contributions to SLIME. Life is hard though: you gotta send code to get +your name in the manual. ‘:-)’ + +Thanks! +======= + +We’re indebted to the good people of ‘common-lisp.net’ for their hosting +and help, and for rescuing us from “Sourceforge hell.” + + Implementors of the Lisps that we support have been a great help. +We’d like to thank the CMUCL maintainers for their helpful answers, +Craig Norvell and Kevin Layer at Franz providing Allegro CL licenses for +SLIME development, and Peter Graves for his help to get SLIME running +with ABCL. + + Most of all we’re happy to be working with the Lisp implementors +who’ve joined in the SLIME development: Dan Barlow and Christophe Rhodes +of SBCL, Gary Byers of OpenMCL, and Martin Simmons of LispWorks. Thanks +also to Alain Picard and Memetrics for funding Martin’s initial work on +the LispWorks backend! + + +File: slime.info, Node: Key Index, Next: Command Index, Prev: Credits, Up: Top + +Key (Character) Index +********************* + +[index] +* Menu: + +* .: Inspector. (line 61) +* :: Miscellaneous. (line 28) +* <: Frame Navigation. (line 23) +* >: Inspector. (line 65) +* > <1>: Frame Navigation. (line 19) +* a: Restarts. (line 8) +* A: Miscellaneous. (line 31) +* B: Miscellaneous. (line 19) +* c: Restarts. (line 18) +* C: Miscellaneous. (line 24) +* C-: Input Navigation. (line 14) +* C-: Input Navigation. (line 14) +* C-a: REPL commands. (line 28) +* C-c :: Evaluation. (line 33) +* C-c <: Cross-reference. (line 55) +* C-c >: Cross-reference. (line 59) +* C-c C-a: Other. (line 8) +* C-c C-b: Recovery. (line 8) +* C-c C-c: Compilation. (line 14) +* C-c C-c <1>: Xref buffer commands. + (line 19) +* C-c C-c <2>: Examining frames. (line 38) +* C-c C-c <3>: REPL commands. (line 32) +* C-c C-d #: Documentation. (line 59) +* C-c C-d A: Documentation. (line 25) +* C-c C-d a: slime-autodoc-mode. (line 22) +* C-c C-d d: Documentation. (line 17) +* C-c C-d f: Documentation. (line 21) +* C-c C-d h: Documentation. (line 44) +* C-c C-d p: Documentation. (line 37) +* C-c C-d z: Documentation. (line 33) +* C-c C-d ~: Documentation. (line 55) +* C-c C-j: REPL. (line 31) +* C-c C-k: Compilation. (line 28) +* C-c C-k <1>: Xref buffer commands. + (line 23) +* C-c C-l: Compilation. (line 44) +* C-c C-m: Macro-expansion. (line 8) +* C-c C-m <1>: slime-macroexpansion-minor-mode. + (line 12) +* C-c C-n: Input Navigation. (line 29) +* C-c C-o: REPL commands. (line 40) +* C-c C-p: Evaluation. (line 41) +* C-c C-p <1>: Input Navigation. (line 29) +* C-c C-r: Evaluation. (line 37) +* C-c C-s: Compound Completion. (line 48) +* C-c C-t: Disassembly. (line 12) +* C-c C-u: Evaluation. (line 52) +* C-c C-v: Other. (line 8) +* C-c C-v d: Presentations. (line 107) +* C-c C-v i: Presentations. (line 111) +* C-c C-v n: Presentations. (line 116) +* C-c C-v p: Presentations. (line 120) +* C-c C-v r: Presentations. (line 102) +* C-c C-v SPC: Presentations. (line 91) +* C-c C-v w: Presentations. (line 97) +* C-c C-w b: Cross-reference. (line 34) +* C-c C-w c: Cross-reference. (line 22) +* C-c C-w m: Cross-reference. (line 42) +* C-c C-w r: Cross-reference. (line 30) +* C-c C-w s: Cross-reference. (line 38) +* C-c C-w w: Cross-reference. (line 26) +* C-c C-x c: Multiple connections. + (line 27) +* C-c C-x n: Multiple connections. + (line 33) +* C-c C-x t: Multiple connections. + (line 39) +* C-c C-y: REPL. (line 27) +* C-c C-z: REPL. (line 23) +* C-c C-]: Editing Commands. (line 20) +* C-c E: Evaluation. (line 46) +* C-c I: Inspector. (line 16) +* C-c M-c: Compilation. (line 63) +* C-c M-d: Disassembly. (line 8) +* C-c M-i: Fuzzy Completion. (line 11) +* C-c M-k: Compilation. (line 40) +* C-c M-m: Macro-expansion. (line 19) +* C-c M-o: REPL commands. (line 36) +* C-c M-p: Recovery. (line 20) +* C-c M-q: Editing Commands. (line 11) +* C-c M-t: SLIME Trace Dialog. (line 32) +* C-c T: SLIME Trace Dialog. (line 45) +* C-c ~: Recovery. (line 15) +* C-j: REPL commands. (line 24) +* C-j <1>: Scratch Buffer. (line 13) +* C-k: SLIME Trace Dialog. (line 89) +* C-M-x: Evaluation. (line 19) +* C-RET: REPL commands. (line 15) +* C-x 4 .: Finding definitions. (line 23) +* C-x 5 .: Finding definitions. (line 28) +* C-x C-e: Evaluation. (line 13) +* C-x `: Compilation. (line 67) +* C-_: slime-macroexpansion-minor-mode. + (line 26) +* d: Inspector. (line 27) +* d <1>: Examining frames. (line 24) +* D: Examining frames. (line 29) +* d <2>: Multiple connections. + (line 56) +* d <3>: slime-sprof. (line 30) +* e: Inspector. (line 31) +* e <1>: Examining frames. (line 19) +* g: Inspector. (line 49) +* g <1>: slime-macroexpansion-minor-mode. + (line 17) +* g <2>: Multiple connections. + (line 61) +* g <3>: SLIME Trace Dialog. (line 82) +* G: SLIME Trace Dialog. (line 85) +* i: Examining frames. (line 34) +* l: Inspector. (line 41) +* M-,: Finding definitions. (line 18) +* M-.: Finding definitions. (line 13) +* M-C-a: Editing Commands. (line 38) +* M-C-e: Editing Commands. (line 40) +* M-n: Compilation. (line 55) +* M-n <1>: Frame Navigation. (line 12) +* M-n <2>: Input Navigation. (line 18) +* M-p: Compilation. (line 59) +* M-p <1>: Frame Navigation. (line 12) +* M-p <2>: Input Navigation. (line 18) +* M-r: Input Navigation. (line 25) +* M-RET: Inspector. (line 69) +* M-s: Input Navigation. (line 25) +* M-TAB: Completion. (line 13) +* n: Inspector. (line 45) +* n <1>: Frame Navigation. (line 8) +* o: Stepping. (line 21) +* p: Inspector. (line 57) +* p <1>: Frame Navigation. (line 8) +* q: Inspector. (line 53) +* q <1>: Restarts. (line 12) +* q <2>: slime-macroexpansion-minor-mode. + (line 22) +* q <3>: Multiple connections. + (line 65) +* r: Miscellaneous. (line 8) +* R: Miscellaneous. (line 14) +* R <1>: Multiple connections. + (line 70) +* RET: Xref buffer commands. + (line 10) +* RET <1>: Inspector. (line 22) +* RET <2>: Multiple connections. + (line 52) +* RET <3>: REPL commands. (line 8) +* RET <4>: slime-sprof. (line 24) +* s: Stepping. (line 11) +* s <1>: slime-sprof. (line 33) +* S-TAB: Inspector. (line 74) +* Space: Xref buffer commands. + (line 15) +* SPC: Documentation. (line 12) +* t: Examining frames. (line 10) +* TAB: Inspector. (line 74) +* TAB <1>: REPL commands. (line 20) +* v: Inspector. (line 36) +* v <1>: Examining frames. (line 14) +* v <2>: slime-sprof. (line 27) +* x: Stepping. (line 17) + + +File: slime.info, Node: Command Index, Next: Variable Index, Prev: Key Index, Up: Top + +Command and Function Index +************************** + +[index] +* Menu: + +* hyperspec-lookup-format: Documentation. (line 55) +* hyperspec-lookup-reader-macro: Documentation. (line 59) +* inferior-slime-mode: inferior-slime-mode. (line 15) +* next-error: Compilation. (line 67) +* sldb-abort: Restarts. (line 8) +* sldb-beginning-of-backtrace: Frame Navigation. (line 23) +* sldb-break-with-default-debugger: Miscellaneous. (line 19) +* sldb-break-with-system-debugger: Miscellaneous. (line 31) +* sldb-continue: Restarts. (line 18) +* sldb-details-down: Frame Navigation. (line 12) +* sldb-details-up: Frame Navigation. (line 12) +* sldb-disassemble: Examining frames. (line 29) +* sldb-down: Frame Navigation. (line 8) +* sldb-end-of-backtrace: Frame Navigation. (line 19) +* sldb-eval-in-frame: Examining frames. (line 19) +* sldb-inspect-condition: Miscellaneous. (line 24) +* sldb-inspect-in-frame: Examining frames. (line 34) +* sldb-next: Stepping. (line 17) +* sldb-out: Stepping. (line 21) +* sldb-pprint-eval-in-frame: Examining frames. (line 24) +* sldb-quit: Restarts. (line 12) +* sldb-recompile-frame-source: Examining frames. (line 38) +* sldb-restart-frame: Miscellaneous. (line 8) +* sldb-return-from-frame: Miscellaneous. (line 14) +* sldb-show-source: Examining frames. (line 14) +* sldb-step: Stepping. (line 11) +* sldb-toggle-details: Examining frames. (line 10) +* sldb-up: Frame Navigation. (line 8) +* slime-abort-connection: Multiple connections. + (line 79) +* slime-apropos: Documentation. (line 25) +* slime-apropos-all: Documentation. (line 33) +* slime-apropos-package: Documentation. (line 37) +* slime-arglist NAME: slime-autodoc-mode. (line 15) +* slime-autodoc-manually: slime-autodoc-mode. (line 22) +* slime-autodoc-mode: slime-autodoc-mode. (line 18) +* slime-beginning-of-defun: Editing Commands. (line 38) +* slime-browse-classes: Xref and Class Browser. + (line 10) +* slime-browse-system NAME: ASDF. (line 21) +* slime-browse-xrefs: Xref and Class Browser. + (line 14) +* slime-call-defun: REPL. (line 27) +* slime-calls-who: Cross-reference. (line 26) +* slime-cd: Recovery. (line 23) +* slime-close-all-parens-in-sexp: Editing Commands. (line 20) +* slime-compile-and-load-file: Compilation. (line 28) +* slime-compile-defun: Compilation. (line 14) +* slime-compile-file: Compilation. (line 40) +* slime-compile-region: Compilation. (line 47) +* slime-compiler-macroexpand: Macro-expansion. (line 25) +* slime-compiler-macroexpand-1: Macro-expansion. (line 22) +* slime-complete-form: Compound Completion. (line 48) +* slime-complete-symbol: Completion. (line 13) +* slime-connect: Multiple connections. + (line 73) +* slime-connection-list-make-default: Multiple connections. + (line 56) +* slime-copy-presentation-at-point-to-kill-ring: Presentations. + (line 97) +* slime-copy-presentation-at-point-to-repl: Presentations. (line 102) +* slime-cycle-connections: Multiple connections. + (line 33) +* slime-delete-system-fasls NAME: ASDF. (line 23) +* slime-describe-function: Documentation. (line 21) +* slime-describe-presentation-at-point: Presentations. (line 107) +* slime-describe-symbol: Documentation. (line 17) +* slime-disassemble-symbol: Disassembly. (line 8) +* slime-disconnect: Multiple connections. + (line 76) +* slime-edit-definition: Finding definitions. (line 13) +* slime-edit-definition-other-frame: Finding definitions. (line 28) +* slime-edit-definition-other-window: Finding definitions. (line 23) +* slime-edit-definition-with-etags: Finding definitions. (line 32) +* slime-edit-value: Evaluation. (line 46) +* slime-end-of-defun: Editing Commands. (line 40) +* slime-ensure-typeout-frame: Typeout frames. (line 15) +* slime-eval-defun: Evaluation. (line 19) +* slime-eval-last-expression: Evaluation. (line 13) +* slime-eval-last-expression-in-repl: REPL. (line 31) +* slime-eval-print-last-expression: Scratch Buffer. (line 13) +* slime-eval-region: Evaluation. (line 37) +* slime-expand-1: Macro-expansion. (line 8) +* slime-fuzzy-complete-symbol: Fuzzy Completion. (line 11) +* slime-goto-connection: Multiple connections. + (line 52) +* slime-goto-xref: Xref buffer commands. + (line 15) +* slime-highlight-edits-mode: Highlight Edits. (line 11) +* slime-hyperspec-lookup: Documentation. (line 44) +* slime-indent-and-complete-symbol: REPL commands. (line 20) +* slime-insert-balanced-comments: Editing Commands. (line 29) +* slime-inspect: Inspector. (line 16) +* slime-inspect-presentation-at-point: Presentations. (line 111) +* slime-inspector-copy-down: Inspector. (line 69) +* slime-inspector-describe: Inspector. (line 27) +* slime-inspector-eval: Inspector. (line 31) +* slime-inspector-fetch-all: Inspector. (line 65) +* slime-inspector-next: Inspector. (line 45) +* slime-inspector-next-inspectable-object: Inspector. (line 74) +* slime-inspector-operate-on-point: Inspector. (line 22) +* slime-inspector-pop: Inspector. (line 41) +* slime-inspector-pprint: Inspector. (line 57) +* slime-inspector-previous-inspectable-object: Inspector. (line 74) +* slime-inspector-quit: Inspector. (line 53) +* slime-inspector-reinspect: Inspector. (line 49) +* slime-inspector-show-source: Inspector. (line 61) +* slime-inspector-toggle-verbose: Inspector. (line 36) +* slime-interactive-eval: Evaluation. (line 33) +* slime-interactive-eval <1>: Miscellaneous. (line 28) +* slime-interrupt: Recovery. (line 8) +* slime-interrupt <1>: REPL commands. (line 32) +* slime-isearch-system NAME: ASDF. (line 27) +* slime-list-callees: Cross-reference. (line 59) +* slime-list-callers: Cross-reference. (line 55) +* slime-list-connections: Multiple connections. + (line 27) +* slime-list-threads: Multiple connections. + (line 39) +* slime-load-file: Compilation. (line 44) +* slime-load-system NAME: ASDF. (line 13) +* slime-macroexpand-1: Macro-expansion. (line 14) +* slime-macroexpand-1-inplace: slime-macroexpansion-minor-mode. + (line 12) +* slime-macroexpand-1-inplace <1>: slime-macroexpansion-minor-mode. + (line 17) +* slime-macroexpand-all: Macro-expansion. (line 19) +* slime-macroexpand-undo: slime-macroexpansion-minor-mode. + (line 26) +* slime-mark-presentation: Presentations. (line 91) +* slime-next-note: Compilation. (line 55) +* slime-next-presentation: Presentations. (line 116) +* slime-nop: Other. (line 8) +* slime-nop <1>: Other. (line 8) +* slime-open-system NAME &optional LOAD: ASDF. (line 19) +* slime-pop-find-definition-stack: Finding definitions. (line 18) +* slime-pprint-eval-last-expression: Evaluation. (line 41) +* slime-previous-note: Compilation. (line 59) +* slime-previous-presentation: Presentations. (line 120) +* slime-profile-by-substring: Profiling. (line 15) +* slime-profile-package: Profiling. (line 13) +* slime-profile-report: Profiling. (line 19) +* slime-profile-reset: Profiling. (line 21) +* slime-profiled-functions: Profiling. (line 23) +* slime-pwd: Recovery. (line 27) +* slime-query-replace-system NAME FROM TO &OPTIONAL DELIMITED: ASDF. + (line 29) +* slime-recompile-all-xrefs: Xref buffer commands. + (line 23) +* slime-recompile-xref: Xref buffer commands. + (line 19) +* slime-reindent-defun: Editing Commands. (line 11) +* slime-reload-system NAME: ASDF. (line 16) +* slime-remove-notes: Compilation. (line 63) +* slime-repl-backward-input: Input Navigation. (line 14) +* slime-repl-bol: REPL commands. (line 28) +* slime-repl-clear-buffer: REPL commands. (line 36) +* slime-repl-clear-output: REPL commands. (line 40) +* slime-repl-closing-return: REPL commands. (line 15) +* slime-repl-forward-input: Input Navigation. (line 14) +* slime-repl-newline-and-indent: REPL commands. (line 24) +* slime-repl-next-input: Input Navigation. (line 18) +* slime-repl-next-matching-input: Input Navigation. (line 25) +* slime-repl-next-prompt: Input Navigation. (line 29) +* slime-repl-previous-input: Input Navigation. (line 18) +* slime-repl-previous-matching-input: Input Navigation. (line 25) +* slime-repl-previous-prompt: Input Navigation. (line 29) +* slime-repl-return: REPL commands. (line 8) +* slime-repl-set-package: Recovery. (line 20) +* slime-restart-connection-at-point: Multiple connections. + (line 70) +* slime-restart-inferior-lisp: Recovery. (line 11) +* slime-rgrep-system NAME REGEXP: ASDF. (line 25) +* slime-scratch: Scratch Buffer. (line 17) +* slime-show-xref: Xref buffer commands. + (line 10) +* slime-space: Documentation. (line 12) +* slime-sprof-browser-disassemble-function: slime-sprof. (line 30) +* slime-sprof-browser-toggle: slime-sprof. (line 24) +* slime-sprof-browser-view-source: slime-sprof. (line 27) +* slime-sprof-report: slime-sprof. (line 18) +* slime-sprof-start: slime-sprof. (line 13) +* slime-sprof-stop: slime-sprof. (line 16) +* slime-sprof-toggle-swank-exclusion: slime-sprof. (line 33) +* slime-switch-to-output-buffer: REPL. (line 23) +* slime-sync-package-and-default-directory: Recovery. (line 15) +* slime-temp-buffer-quit: slime-macroexpansion-minor-mode. + (line 22) +* slime-temp-buffer-quit <1>: Multiple connections. + (line 65) +* slime-toggle-profile-fdefinition: Profiling. (line 11) +* slime-toggle-trace-fdefinition: Disassembly. (line 12) +* slime-trace-dialog: SLIME Trace Dialog. (line 45) +* slime-trace-dialog-clear-fetched-traces: SLIME Trace Dialog. + (line 89) +* slime-trace-dialog-fetch-status: SLIME Trace Dialog. (line 82) +* slime-trace-dialog-fetch-traces: SLIME Trace Dialog. (line 85) +* slime-trace-dialog-toggle-trace: SLIME Trace Dialog. (line 32) +* slime-undefine-function: Evaluation. (line 52) +* slime-unprofile-all: Profiling. (line 17) +* slime-untrace-all: Disassembly. (line 17) +* slime-update-connection-list: Multiple connections. + (line 61) +* slime-who-binds: Cross-reference. (line 34) +* slime-who-calls: Cross-reference. (line 22) +* slime-who-macroexpands: Cross-reference. (line 42) +* slime-who-references: Cross-reference. (line 30) +* slime-who-sets: Cross-reference. (line 38) +* slime-who-specializes: Cross-reference. (line 45) + + +File: slime.info, Node: Variable Index, Prev: Command Index, Up: Top + +Variable and Concept Index +************************** + +[index] +* Menu: + +* ASCII: Emacs-side customization. + (line 35) +* Character Encoding: Emacs-side customization. + (line 35) +* Compilation: Compilation. (line 6) +* Compiling Functions: Compilation. (line 12) +* Completion: Completion. (line 6) +* Contribs: Loading Contribs. (line 6) +* Contributions: Loading Contribs. (line 6) +* Cross-referencing: Cross-reference. (line 6) +* Debugger: Debugger. (line 6) +* inferior-lisp-program: Installation. (line 27) +* inferior-slime-mode-map: inferior-slime-mode. (line 17) +* Input History: Input Navigation. (line 6) +* LATIN-1: Emacs-side customization. + (line 35) +* Listener: REPL. (line 6) +* load-path: Installation. (line 27) +* Macros: Macro-expansion. (line 6) +* Meta-dot: Finding definitions. (line 6) +* Methods: Fancy Inspector. (line 6) +* Plugins: Loading Contribs. (line 6) +* Presentations: Presentations. (line 6) +* Shortcuts: Shortcuts. (line 6) +* sldb-hook: Hooks. (line 17) +* slime-autodoc-mode-string: slime-autodoc-mode. (line 32) +* slime-autodoc-use-multiline-p: slime-autodoc-mode. (line 29) +* slime-completion-at-point-functions: Emacs-side customization. + (line 17) +* slime-connected-hook: Hooks. (line 12) +* slime-default-lisp: Multiple Lisps. (line 17) +* slime-description-autofocus: Temporary buffers. (line 27) +* slime-filename-translations: Emacs-side customization. + (line 28) +* slime-header-line-p: Banner. (line 10) +* slime-lisp-implementations: Multiple Lisps. (line 13) +* slime-mode-hook: Hooks. (line 6) +* slime-net-coding-system: Emacs-side customization. + (line 35) +* slime-repl-wrap-history: Input Navigation. (line 33) +* slime-startup-animation: Banner. (line 10) +* slime-use-autodoc-mode: slime-autodoc-mode. (line 25) +* Stepping: Stepping. (line 6) +* SWANK:*BACKTRACE-PRINTER-BINDINGS*: Other configurables. (line 42) +* SWANK:*COMMUNICATION-STYLE*: Communication style. (line 6) +* SWANK:*CONFIGURE-EMACS-INDENTATION*: Other configurables. (line 8) +* SWANK:*DEDICATED-OUTPUT-STREAM-PORT*: Other configurables. (line 69) +* SWANK:*GLOBAL-DEBUGGER*: Other configurables. (line 27) +* SWANK:*GLOBALLY-REDIRECT-IO*: Other configurables. (line 13) +* SWANK:*LOG-EVENTS*: Other configurables. (line 74) +* SWANK:*MACROEXPAND-PRINTER-BINDINGS*: Other configurables. (line 42) +* SWANK:*SLDB-PRINTER-BINDINGS*: Other configurables. (line 42) +* SWANK:*SLDB-QUIT-RESTART*: Other configurables. (line 33) +* SWANK:*SWANK-PPRINT-BINDINGS*: Other configurables. (line 42) +* SWANK:*USE-DEDICATED-OUTPUT-STREAM*: Other configurables. (line 53) +* Symbol Completion: Completion. (line 6) +* TAGS: Finding definitions. (line 6) +* TRAMP: TRAMP. (line 6) +* Typeout Frame: Typeout frames. (line 6) +* Unicode: Emacs-side customization. + (line 35) +* UTF-8: Emacs-side customization. + (line 35) +* xref: Cross-reference. (line 6) + + + +Tag Table: +Node: Top285 +Node: Introduction2525 +Node: Getting started3806 +Node: Platforms4080 +Node: Downloading5278 +Node: Git5779 +Node: Git Incantations6797 +Node: Installation7327 +Node: Running8593 +Node: Setup Tuning9136 +Node: Basic customization9667 +Node: Multiple Lisps10733 +Node: Loading Swank faster13227 +Ref: init-example14320 +Node: SLIME mode14609 +Node: User-interface conventions15207 +Node: Temporary buffers15616 +Node: Inferior-lisp17069 +Node: Multithreading17894 +Node: Key bindings19139 +Ref: describe-key20605 +Ref: describe-bindings20748 +Ref: describe-mode20891 +Ref: view-lossage21075 +Node: Evaluation22270 +Node: Compilation24175 +Node: Completion26934 +Node: Finding definitions27565 +Node: Documentation28705 +Node: Cross-reference30872 +Node: Xref buffer commands32609 +Node: Macro-expansion33168 +Node: Disassembly34189 +Node: Recovery34734 +Node: Inspector35503 +Node: Profiling37741 +Node: Other38538 +Node: Semantic indentation38791 +Ref: Semantic indentation-Footnote-140922 +Node: Reader conditionals41017 +Node: Debugger41368 +Node: Examining frames42008 +Node: Restarts43140 +Ref: sldb-quit43354 +Node: Frame Navigation43781 +Node: Stepping44481 +Node: Miscellaneous45153 +Node: Misc46092 +Node: slime-selector46279 +Node: slime-macroexpansion-minor-mode47661 +Node: Multiple connections48516 +Node: Customization51576 +Node: Emacs-side customization51751 +Ref: slime-completion-at-point-functions52444 +Ref: slime-net-coding-system53335 +Node: Hooks54008 +Ref: slime-connected-hook54373 +Node: Lisp-side54857 +Node: Communication style55267 +Node: Other configurables57829 +Ref: *SLDB-QUIT-RESTART*59227 +Node: Tips and Tricks61818 +Node: Connecting to a remote lisp62043 +Node: Setting up the lisp image62748 +Ref: Setting up the lisp image-Footnote-164636 +Ref: Setting up the lisp image-Footnote-264716 +Node: Setting up Emacs64892 +Ref: Setting up Emacs-Footnote-165728 +Node: Setting up pathname translations65908 +Node: Global IO Redirection67549 +Node: Auto-SLIME68482 +Node: Contributed Packages68903 +Node: Loading Contribs69652 +Node: REPL71974 +Node: REPL commands73389 +Node: Input Navigation74550 +Node: Shortcuts76074 +Node: slime-mrepl77570 +Node: inferior-slime-mode78078 +Node: Compound Completion78783 +Ref: slime-complete-symbol*78960 +Ref: Compound Completion-Footnote-182212 +Node: Fuzzy Completion82336 +Ref: slime-fuzzy-complete-symbol82589 +Node: slime-autodoc-mode85881 +Node: ASDF87299 +Node: Banner89257 +Node: Editing Commands89703 +Node: Fancy Inspector91330 +Node: Presentations92061 +Ref: Presentations-Footnote-198617 +Node: Typeout frames98858 +Node: TRAMP99982 +Node: Documentation Links100258 +Node: Xref and Class Browser100683 +Node: Highlight Edits101275 +Node: Scratch Buffer101747 +Ref: slime-scratch101909 +Node: SLIME Trace Dialog102564 +Node: slime-sprof106814 +Node: SLIME Enhanced M-.107802 +Node: slime-fancy108184 +Node: Quicklisp108460 +Node: Credits108988 +Node: Key Index114592 +Node: Command Index126382 +Node: Variable Index141624 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/elpa/slime-20200319.1939/start-swank.lisp b/elpa/slime-20200319.1939/start-swank.lisp new file mode 100644 index 00000000..340606cc --- /dev/null +++ b/elpa/slime-20200319.1939/start-swank.lisp @@ -0,0 +1,20 @@ +;;; This file is intended to be loaded by an implementation to +;;; get a running swank server +;;; e.g. sbcl --load start-swank.lisp +;;; +;;; Default port is 4005 + +;;; For additional swank-side configurations see +;;; 6.2 section of the Slime user manual. + +(load (merge-pathnames "swank-loader.lisp" *load-truename*)) + +(swank-loader:init + :delete nil ; delete any existing SWANK packages + :reload nil ; reload SWANK, even if the SWANK package already exists + :load-contribs nil) ; load all contribs + +(swank:create-server :port 4005 + ;; if non-nil the connection won't be closed + ;; after connecting + :dont-close nil) diff --git a/elpa/slime-20200319.1939/swank-loader.lisp b/elpa/slime-20200319.1939/swank-loader.lisp new file mode 100644 index 00000000..fbd34e15 --- /dev/null +++ b/elpa/slime-20200319.1939/swank-loader.lisp @@ -0,0 +1,376 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. +;; E.g.: +;; +;; (load ".../swank-loader.lisp") +;; (setq swank-loader::*fasl-directory* "/tmp/fasl/") +;; (swank-loader:init) + +(cl:defpackage :swank-loader + (:use :cl) + (:export :init + :dump-image + :list-fasls + :*source-directory* + :*fasl-directory* + :*started-from-emacs*)) + +(cl:in-package :swank-loader) + +(defvar *started-from-emacs* nil) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl) + (swank gray)) + #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl) + (swank gray)) + #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl) + (swank gray)) + #+clozure '(metering (swank ccl) (swank gray)) + #+lispworks '((swank lispworks) (swank gray)) + #+allegro '((swank allegro) (swank gray)) + #+clisp '(xref metering (swank clisp) (swank gray)) + #+armedbear '((swank abcl)) + #+cormanlisp '((swank corman) (swank gray)) + #+ecl '((swank ecl) (swank gray)) + #+clasp '((swank clasp) (swank gray)) + #+mkcl '((swank mkcl) (swank gray)) + #+mezzano '((swank mezzano) (swank gray)) + ) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl :mkcl :clasp :mezzano)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix :mezzano)) + +(defparameter *architecture-features* + '(:powerpc :ppc :ppc64 :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64 + :pentium3 :pentium4 + :mips :mipsel + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + +(defun q (s) (read-from-string s)) + +#+ecl +(defun ecl-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) + (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))))) + +#+clasp +(defun clasp-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (core:lisp-implementation-id))) + +(defun lisp-version-string () + #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+(or cormanlisp scl mkcl) (lisp-implementation-version) + #+sbcl (format nil "~a~:[~;-no-threads~]" + (lisp-implementation-version) + #+sb-thread nil + #-sb-thread t) + #+lispworks (lisp-implementation-version) + #+allegro (format nil "~@{~a~}" + excl::*common-lisp-version-number* + (if (string= 'lisp "LISP") "A" "M") ; ANSI vs MoDeRn + (if (member :smp *features*) "s" "") + (if (member :64bit *features*) "-64bit" "") + (excl:ics-target-case + (:-ics "") + (:+ics "-ics"))) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+ecl (ecl-version-string) + #+clasp (clasp-version-string) + #+mezzano (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s)))) + +(defun unique-dir-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun string-starts-with (string prefix) + (string-equal string prefix :end1 (min (length string) (length prefix)))) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "slime.el" *source-directory*) + :if-does-not-exist nil) + (when s + (loop with prefix = ";; Version: " + for line = (read-line s nil :eof) + until (eq line :eof) + when (string-starts-with line prefix) + return (subseq line (length prefix)))))) + +(defun default-fasl-dir () + (merge-pathnames + (make-pathname + :directory `(:relative ".slime" "fasl" + ,@(if (slime-version-string) (list (slime-version-string))) + ,(unique-dir-name))) + (user-homedir-pathname))) + +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + +(defun binary-pathname (src-pathname binary-dir) + "Return the pathname where SRC-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname src-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-dir))) + +(defun handle-swank-load-error (condition context pathname) + (fresh-line *error-output*) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error ~A ~A:~% ~A~%" + context pathname condition))) + +(defun compile-files (files fasl-dir load quiet) + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." + (let ((needs-recompile nil) + (state :unknown)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-bind + ((error (lambda (c) + (ecase state + (:compile (handle-swank-load-error c "compiling" src)) + (:load (handle-swank-load-error c "loading" dest)) + (:unknown (handle-swank-load-error c "???ing" src)))))) + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (ensure-directories-exist dest) + ;; need to recompile SRC, so we'll need to recompile + ;; everything after this too. + (setf needs-recompile t + state :compile) + (or (compile-file src :output-file dest :print nil + :verbose (not quiet)) + ;; An implementation may not necessarily signal a + ;; condition itself when COMPILE-FILE fails (e.g. ECL) + (error "COMPILE-FILE returned NIL."))) + (when load + (setf state :load) + (load dest :verbose (not quiet)))))))) + +#+cormanlisp +(defun compile-files (files fasl-dir load quiet) + "Corman Lisp has trouble with compiled files." + (declare (ignore fasl-dir)) + (when load + (dolist (file files) + (load file :verbose (not quiet) + (force-output))))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (dir) + (load (make-pathname :name "site-init" :type "lisp" + :defaults dir) + :if-does-not-exist nil)) + +(defun src-files (names src-dir) + (mapcar (lambda (name) + (multiple-value-bind (dirs name) + (etypecase name + (symbol (values '() name)) + (cons (values (butlast name) (car (last name))))) + (make-pathname + :directory (append (or (pathname-directory src-dir) + '(:relative)) + (mapcar #'string-downcase dirs)) + :name (string-downcase name) + :type "lisp" + :defaults src-dir))) + names)) + +(defvar *swank-files* + `(packages + (swank backend) ,@*sysdep-files* (swank match) (swank rpc) + swank)) + +(defvar *contribs* + '(swank-util swank-repl + swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf2 asdf3 sbcl ecl) swank-asdf + swank-package-fu + swank-hyperdoc + #+sbcl swank-sbcl-exts + swank-mrepl + swank-trace-dialog + swank-macrostep + swank-quicklisp) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-dir (base-dir) + (append-dir base-dir "contrib")) + +(defun load-swank (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*) + quiet) + (with-compilation-unit () + (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)) + (funcall (q "swank::before-init") + (slime-version-string) + (list (contrib-dir fasl-dir) + (contrib-dir src-dir)))) + +(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir) + (let ((newest (reduce #'max (mapcar #'file-write-date swank-files)))) + (dolist (src contrib-files) + (let ((fasl (binary-pathname src fasl-dir))) + (when (and (probe-file fasl) + (<= (file-write-date fasl) newest)) + (delete-file fasl)))))) + +(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) + (fasl-dir (contrib-dir *fasl-directory*)) + (swank-src-dir *source-directory*) + load quiet) + (let* ((swank-src-files (src-files *swank-files* swank-src-dir)) + (contrib-src-files (src-files *contribs* src-dir))) + (delete-stale-contrib-fasl-files swank-src-files contrib-src-files + fasl-dir) + (compile-files contrib-src-files fasl-dir load quiet))) + +(defun loadup () + (load-swank) + (compile-contribs :load t)) + +(defun setup () + (load-site-init-file *source-directory*) + (load-user-init-file) + (when (#-clisp probe-file + #+clisp ext:probe-directory + (contrib-dir *source-directory*)) + (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))) + (funcall (q "swank::init"))) + +(defun list-swank-packages () + (remove-if-not (lambda (package) + (let ((name (package-name package))) + (and (string-not-equal name "swank-loader") + (string-starts-with name "swank")))) + (list-all-packages))) + +(defun delete-packages (packages) + (dolist (package packages) + (flet ((handle-package-error (c) + (let ((pkgs (set-difference (package-used-by-list package) + packages))) + (when pkgs + (warn "deleting ~a which is used by ~{~a~^, ~}." + package pkgs)) + (continue c)))) + (handler-bind ((package-error #'handle-package-error)) + (delete-package package))))) + +(defun init (&key delete reload load-contribs (setup t) + (quiet (not *load-verbose*)) + from-emacs) + "Load SWANK and initialize some global variables. +If DELETE is true, delete any existing SWANK packages. +If RELOAD is true, reload SWANK, even if the SWANK package already exists. +If LOAD-CONTRIBS is true, load all contribs +If SETUP is true, load user init files and initialize some +global variabes in SWANK." + (when from-emacs + (setf *started-from-emacs* t)) + (when (and delete (find-package :swank)) + (delete-packages (list-swank-packages))) + (cond ((or (not (find-package :swank)) reload) + (load-swank :quiet quiet)) + (t + (warn "Not reloading SWANK. Package already exists."))) + (when load-contribs + (compile-contribs :load t :quiet quiet)) + (when setup + (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank/backend:save-image") filename)) + +(defun list-fasls (&key (include-contribs t) (compile t) + (quiet (not *compile-verbose*))) + "List up SWANK's fasls along with their dependencies." + (flet ((collect-fasls (files fasl-dir) + (when compile + (compile-files files fasl-dir nil quiet)) + (loop for src in files + when (probe-file (binary-pathname src fasl-dir)) + collect it))) + (append (collect-fasls (src-files *swank-files* *source-directory*) + *fasl-directory*) + (when include-contribs + (collect-fasls (src-files *contribs* + (contrib-dir *source-directory*)) + (contrib-dir *fasl-directory*)))))) diff --git a/elpa/slime-20200319.1939/swank.asd b/elpa/slime-20200319.1939/swank.asd new file mode 100644 index 00000000..33e14ff6 --- /dev/null +++ b/elpa/slime-20200319.1939/swank.asd @@ -0,0 +1,36 @@ +;;; -*- lisp -*- + +;; ASDF system definition for loading the Swank server independently +;; of Emacs. +;; +;; This is only useful if you want to start a Swank server in a Lisp +;; processes that doesn't run under Emacs. Lisp processes created by +;; `M-x slime' automatically start the server. + +;; Usage: +;; +;; (require :swank) +;; (swank:create-swank-server PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Swank server is running on localhost:ACTUAL-PORT. You can +;; use `M-x slime-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defclass swank-loader-file (asdf:cl-source-file) ()) + +;;;; after loading run init + +(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) + ;; swank-loader computes its own source/fasl relation based on the + ;; TRUENAME of the loader file, so we need a "manual" CL:LOAD + ;; invocation here. + (load (asdf::component-pathname f)) + ;; After loading, run the swank-loader init routines. + (funcall (read-from-string "swank-loader::init") :reload t)) + +(asdf:defsystem :swank + :default-component-class swank-loader-file + :components ((:file "swank-loader"))) diff --git a/elpa/slime-20200319.1939/swank.lisp b/elpa/slime-20200319.1939/swank.lisp new file mode 100644 index 00000000..dfdde579 --- /dev/null +++ b/elpa/slime-20200319.1939/swank.lisp @@ -0,0 +1,3800 @@ +;;;; swank.lisp --- Server for SLIME commands. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;; This file defines the "Swank" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `swank/backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SWANK/BACKEND' package. + +(in-package :swank) +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +(defvar *backtrace-pprint-dispatch-table* + (let ((table (copy-pprint-dispatch nil))) + (flet ((print-string (stream string) + (cond (*print-escape* + (escape-string string stream + :map '((#\" . "\\\"") + (#\\ . "\\\\") + (#\newline . "\\n") + (#\return . "\\r")))) + (t (write-string string stream))))) + (set-pprint-dispatch 'string #'print-string 0 table) + table))) + +(defvar *backtrace-printer-bindings* + `((*print-pretty* . t) + (*print-readably* . nil) + (*print-level* . 4) + (*print-length* . 6) + (*print-lines* . 1) + (*print-right-margin* . 200) + (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) + "Pretter settings for printing backtraces.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (if (null alist) + (funcall fun) + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun))))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'." + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defmacro defslimefun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + ;; see + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name (symbol-package ',name))))) + +(defun missing-arg () + "A function that the compiler knows will never to return a value. +You can use (MISSING-ARG) as the initform for defstruct slots that +must always be supplied. This way the :TYPE slot option need not +include some arbitrary initial value like NIL." + (error "A required &KEY or &OPTIONAL argument was not supplied.")) + + +;;;; Hooks +;;; +;;; We use Emacs-like `add-hook' and `run-hook' utilities to support +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defun run-hook-until-success (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS, stop if any function returns +a truthy value" + (loop for hook in functions + thereis (apply hook arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(defvar *pre-reply-hook* '() + "Hook run (without arguments) immediately before replying to an RPC.") + +(defvar *after-init-hook* '() + "Hook run after user init files are loaded.") + + +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). This +;;; is also the place where we keep everything that needs to be +;;; freed/closed/killed when we disconnect. + +(defstruct (connection + (:constructor %make-connection) + (:conc-name connection.) + (:print-function print-connection)) + ;; The listening socket. (usually closed) + (socket (missing-arg) :type t :read-only t) + ;; Character I/O stream of socket connection. Read-only to avoid + ;; race conditions during initialization. + (socket-io (missing-arg) :type stream :read-only t) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null)) + ;; Bindings used for this connection (usually streams) + (env '() :type list) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) + ;; A stream where we send REPL results. + (repl-results nil :type (or stream null)) + ;; Cache of macro-indentation information that has been sent to Emacs. + ;; This is used for preparing deltas to update Emacs's knowledge. + ;; Maps: symbol -> indentation-specification + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + (indentation-cache-packages '()) + ;; The communication style used. + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defstruct (singlethreaded-connection (:include connection) + (:conc-name sconn.)) + ;; The SIGINT handler we should restore when the connection is + ;; closed. + saved-sigint-handler + ;; A queue of events. Not all events can be processed in order and + ;; we need a place to stored them. + (event-queue '() :type list) + ;; A counter that is incremented whenever an event is added to the + ;; queue. This is used to detected modifications to the event queue + ;; by interrupts. The counter wraps around. + (events-enqueued 0 :type fixnum)) + +(defstruct (multithreaded-connection (:include connection) + (:conc-name mconn.)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them; the `repl-thread' is the one + ;; that evaluates REPL expressions. The control thread dispatches + ;; all REPL evaluations to the REPL thread and for other requests it + ;; spawns new threads. + reader-thread + control-thread + repl-thread + auto-flush-thread + indentation-cache-thread + ;; List of threads that are currently processing requests. We use + ;; this to find the newest/current thread for an interrupt. In the + ;; future we may store here (thread . request-tag) pairs so that we + ;; can interrupt specific requests. + (active-threads '() :type list) + ) + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defun make-connection (socket stream style) + (let ((conn (funcall (ecase style + (:spawn + #'make-multithreaded-connection) + ((:sigio nil :fd-handler) + #'make-singlethreaded-connection)) + :socket socket + :socket-io stream + :communication-style style))) + (run-hook *new-connection-hook* conn) + (send-to-sentinel `(:add-connection ,conn)) + conn)) + +(defslimefun ping (tag) + tag) + +(defun safe-backtrace () + (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil))))) + +(define-condition swank-error (error) + ((backtrace :initarg :backtrace :reader swank-error.backtrace) + (condition :initarg :condition :reader swank-error.condition)) + (:report (lambda (c s) (princ (swank-error.condition c) s))) + (:documentation "Condition which carries a backtrace.")) + +(defun signal-swank-error (condition &optional (backtrace (safe-backtrace))) + (error 'swank-error :condition condition :backtrace backtrace)) + +(defvar *debug-on-swank-protocol-error* nil + "When non-nil invoke the system debugger on errors that were +signalled during decoding/encoding the wire protocol. Do not set this +to T unless you want to debug swank internals.") + +(defmacro with-swank-error-handler ((connection) &body body) + "Close the connection on internal `swank-error's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-case + (handler-bind ((swank-error + (lambda (condition) + (when *debug-on-swank-protocol-error* + (invoke-default-debugger condition))))) + (progn . ,body)) + (swank-error (condition) + (close-connection ,conn + (swank-error.condition condition) + (swank-error.backtrace condition))))))) + +(defmacro with-panic-handler ((connection) &body body) + "Close the connection on unhandled `serious-condition's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,conn condition (safe-backtrace)) + (abort condition)))) + . ,body)))) + +(add-hook *new-connection-hook* 'notify-backend-of-connection) +(defun notify-backend-of-connection (connection) + (declare (ignore connection)) + (emacs-connected)) + + +;;;; Utilities + + +;;;;; Logging + +(defvar *swank-io-package* + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defvar *log-events* nil) + +(defun init-log-output () + (unless *log-output* + (setq *log-output* (real-output-stream *error-output*)))) + +(add-hook *after-init-hook* 'init-log-output) + +(defun real-input-stream (stream) + (typecase stream + (synonym-stream + (real-input-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-input-stream (two-way-stream-input-stream stream))) + (t stream))) + +(defun real-output-stream (stream) + (typecase stream + (synonym-stream + (real-output-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-output-stream (two-way-stream-output-stream stream))) + (t stream))) + +(defvar *event-history* (make-array 40 :initial-element nil) + "A ring buffer to record events for better error messages.") +(defvar *event-history-index* 0) +(defvar *enable-event-history* t) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (when *enable-event-history* + (setf (aref *event-history* *event-history-index*) + (format nil "~?" format-string args)) + (setf *event-history-index* + (mod (1+ *event-history-index*) (length *event-history*)))) + (when *log-events* + (write-string (escape-non-ascii (format nil "~?" format-string args)) + *log-output*) + (force-output *log-output*))))) + +(defun event-history-to-list () + "Return the list of events (older events first)." + (let ((arr *event-history*) + (idx *event-history-index*)) + (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) + +(defun clear-event-history () + (fill *event-history* nil) + (setq *event-history-index* 0)) + +(defun dump-event-history (stream) + (dolist (e (event-history-to-list)) + (dump-event e stream))) + +(defun dump-event (event stream) + (cond ((stringp event) + (write-string (escape-non-ascii event) stream)) + ((null event)) + (t + (write-string + (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) + stream)))) + +(defun escape-non-ascii (string) + "Return a string like STRING but with non-ascii chars escaped." + (cond ((ascii-string-p string) string) + (t (with-output-to-string (out) + (loop for c across string do + (cond ((ascii-char-p c) (write-char c out)) + (t (format out "\\x~4,'0X" (char-code c))))))))) + +(defun ascii-string-p (o) + (and (stringp o) + (every #'ascii-char-p o))) + +(defun ascii-char-p (c) + (<= (char-code c) 127)) + + +;;;;; Helper macros + +(defmacro dcase (value &body patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "dcase failed: ~S" ,tmp)))))))) + + +;;;; Interrupt handling + +;; Usually we'd like to enter the debugger when an interrupt happens. +;; But for some operations, in particular send&receive, it's crucial +;; that those are not interrupted when the mailbox is in an +;; inconsistent/locked state. Obviously, if send&receive don't work we +;; can't communicate and the debugger will not work. To solve that +;; problem, we try to handle interrupts only at certain safe-points. +;; +;; Whenever an interrupt happens we call the function +;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the +;; debugger, but if interrupts are disabled the interrupt is put in a +;; queue for later processing. At safe-points, we call +;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the +;; debugger if needed. +;; +;; The queue for interrupts is stored in a thread local variable. +;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows +;; interrupts, i.e. the debugger is entered immediately. When we call +;; "user code" or non-problematic code we allow interrupts. When +;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we +;; switch from "user code" to more delicate operations we need to +;; disable interrupts. In particular, interrupts should be disabled +;; for SEND and RECEIVE-IF. + +;; If true execute interrupts, otherwise queue them. +;; Note: `with-connection' binds *pending-slime-interrupts*. +(defvar *slime-interrupts-enabled*) + +(defmacro with-interrupts-enabled% (flag body) + `(progn + ,@(if flag '((check-slime-interrupts))) + (multiple-value-prog1 + (let ((*slime-interrupts-enabled* ,flag)) + ,@body) + ,@(if flag '((check-slime-interrupts)))))) + +(defmacro with-slime-interrupts (&body body) + `(with-interrupts-enabled% t ,body)) + +(defmacro without-slime-interrupts (&body body) + `(with-interrupts-enabled% nil ,body)) + +(defun queue-thread-interrupt (thread function) + (interrupt-thread thread + (lambda () + ;; safely interrupt THREAD + (when (invoke-or-queue-interrupt function) + (wake-thread thread))))) + +(defun invoke-or-queue-interrupt (function) + (log-event "invoke-or-queue-interrupt: ~a~%" function) + (cond ((not (boundp '*slime-interrupts-enabled*)) + (without-slime-interrupts + (funcall function))) + (*slime-interrupts-enabled* + (log-event "interrupts-enabled~%") + (funcall function)) + (t + (setq *pending-slime-interrupts* + (nconc *pending-slime-interrupts* + (list function))) + (cond ((cdr *pending-slime-interrupts*) + (log-event "too many queued interrupts~%") + (with-simple-restart (continue "Continue from interrupt") + (handler-bind ((serious-condition #'invoke-slime-debugger)) + (check-slime-interrupts)))) + (t + (log-event "queue-interrupt: ~a~%" function) + (when *interrupt-queued-handler* + (funcall *interrupt-queued-handler*)) + t))))) + + +;;; FIXME: poor name? +(defmacro with-io-redirection ((connection) &body body) + "Execute BODY I/O redirection to CONNECTION. " + `(with-bindings (connection.env ,connection) + . ,body)) + +;; Thread local variable used for flow-control. +;; It's bound by `with-connection'. +(defvar *send-counter*) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(let ((connection ,connection) + (function (lambda () . ,body))) + (if (eq *emacs-connection* connection) + (funcall function) + (let ((*emacs-connection* connection) + (*pending-slime-interrupts* '()) + (*send-counter* 0)) + (without-slime-interrupts + (with-swank-error-handler (connection) + (with-io-redirection (connection) + (call-with-debugger-hook #'swank-debugger-hook + function)))))))) + +(defun call-with-retry-restart (msg thunk) + (loop (with-simple-restart (retry "~a" msg) + (return (funcall thunk))))) + +(defmacro with-retry-restart ((&key (msg "Retry.")) &body body) + (check-type msg string) + `(call-with-retry-restart ,msg (lambda () ,@body))) + +(defmacro with-struct* ((conc-name get obj) &body body) + (let ((var (gensym))) + `(let ((,var ,obj)) + (macrolet ((,get (slot) + (let ((getter (intern (concatenate 'string + ',(string conc-name) + (string slot)) + (symbol-package ',conc-name)))) + `(,getter ,',var)))) + ,@body)))) + +(defmacro define-special (name doc) + "Define a special variable NAME with doc string DOC. +This is like defvar, but NAME will not be initialized." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc))) + + +;;;;; Sentinel +;;; +;;; The sentinel thread manages some global lists. +;;; FIXME: Overdesigned? + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *servers* '() + "A list ((server-socket port thread) ...) describing the listening sockets. +Used to close sockets on server shutdown or restart.") + +;; FIXME: we simply access the global variable here. We could ask the +;; sentinel thread instead but then we still have the problem that the +;; connection could be closed before we use it. +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (car *connections*)) + +(defun start-sentinel () + (unless (find-registered 'sentinel) + (let ((thread (spawn #'sentinel :name "Swank Sentinel"))) + (register-thread 'sentinel thread)))) + +(defun sentinel () + (catch 'exit-sentinel + (loop (sentinel-serve (receive))))) + +(defun send-to-sentinel (msg) + (let ((sentinel (find-registered 'sentinel))) + (cond (sentinel (send sentinel msg)) + (t (sentinel-serve msg))))) + +(defun sentinel-serve (msg) + (dcase msg + ((:add-connection conn) + (push conn *connections*)) + ((:close-connection connection condition backtrace) + (close-connection% connection condition backtrace) + (sentinel-maybe-exit)) + ((:add-server socket port thread) + (push (list socket port thread) *servers*)) + ((:stop-server key port) + (sentinel-stop-server key port) + (sentinel-maybe-exit)))) + +(defun sentinel-stop-server (key value) + (let ((probe (find value *servers* :key (ecase key + (:socket #'car) + (:port #'cadr))))) + (cond (probe + (setq *servers* (delete probe *servers*)) + (destructuring-bind (socket _port thread) probe + (declare (ignore _port)) + (ignore-errors (close-socket socket)) + (when (and thread + (thread-alive-p thread) + (not (eq thread (current-thread)))) + (ignore-errors (kill-thread thread))))) + (t + (warn "No server for ~s: ~s" key value))))) + +(defun sentinel-maybe-exit () + (when (and (null *connections*) + (null *servers*) + (and (current-thread) + (eq (find-registered 'sentinel) + (current-thread)))) + (register-thread 'sentinel nil) + (throw 'exit-sentinel nil))) + + +;;;;; Misc + +(defun use-threads-p () + (eq (connection.communication-style *emacs-connection*) :spawn)) + +(defun current-thread-id () + (thread-id (current-thread))) + +(declaim (inline ensure-list)) +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + + +;;;;; Symbols + +;; FIXME: this docstring is more confusing than helpful. +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + + +;;;; TCP Server + +(defvar *communication-style* (preferred-communication-style)) + +(defvar *dont-close* nil + "Default value of :dont-close argument to start-server and + create-server.") + +(defparameter *loopback-interface* "localhost") + +(defun start-server (port-file &key (style *communication-style*) + (dont-close *dont-close*)) + "Start the server and write the listen port number to PORT-FILE. +This is the entry point for Emacs." + (setup-server 0 + (lambda (port) (announce-server-port port-file port)) + style dont-close nil)) + +(defun create-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*) + interface + backlog) + "Start a SWANK server on PORT running in STYLE. +If DONT-CLOSE is true then the listen socket will accept multiple +connections, otherwise it will be closed after the first. + +Optionally, an INTERFACE could be specified and swank will bind +the PORT on this interface. By default, interface is \"localhost\"." + (let ((*loopback-interface* (or interface + *loopback-interface*))) + (setup-server port #'simple-announce-function + style dont-close backlog))) + +(defun find-external-format-or-lose (coding-system) + (or (find-external-format coding-system) + (error "Unsupported coding system: ~s" coding-system))) + +(defmacro restart-loop (form &body clauses) + "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's +environment before trying again (by returning normally) or giving up (through an +explicit transfer of control), all within an implicit block named nil. +e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" + `(loop (restart-case (return ,form) ,@clauses))) + +(defun socket-quest (port backlog) + (restart-loop (create-socket *loopback-interface* port :backlog backlog) + (use-value (&optional (new-port (1+ port))) + :report (lambda (stream) (format stream "Try a port other than ~D" port)) + :interactive + (lambda () + (format *query-io* "Enter port (defaults to ~D): " (1+ port)) + (finish-output *query-io*) ; necessary for tunnels + (ignore-errors (list (parse-integer (read-line *query-io*))))) + (setq port new-port)))) + +(defun setup-server (port announce-fn style dont-close backlog) + (init-log-output) + (let* ((socket (socket-quest port backlog)) + (port (local-port socket))) + (funcall announce-fn port) + (labels ((serve () (accept-connections socket style dont-close)) + (note () (send-to-sentinel `(:add-server ,socket ,port + ,(current-thread)))) + (serve-loop () (note) (loop do (serve) while dont-close))) + (ecase style + (:spawn (initialize-multiprocessing + (lambda () + (start-sentinel) + (spawn #'serve-loop :name (format nil "Swank ~s" port))))) + ((:fd-handler :sigio) + (note) + (add-fd-handler socket #'serve)) + ((nil) (serve-loop)))) + port)) + +(defun stop-server (port) + "Stop server running on PORT." + (send-to-sentinel `(:stop-server :port ,port))) + +(defun restart-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*)) + "Stop the server listening on PORT, then start a new SWANK server +on PORT running in STYLE. If DONT-CLOSE is true then the listen socket +will accept multiple connections, otherwise it will be closed after the +first." + (stop-server port) + (sleep 5) + (create-server :port port :style style :dont-close dont-close)) + +(defun accept-connections (socket style dont-close) + (unwind-protect + (let ((client (accept-connection socket :external-format nil + :buffering t))) + (authenticate-client client) + (serve-requests (make-connection socket client style))) + (unless dont-close + (send-to-sentinel `(:stop-server :socket ,socket))))) + +(defun authenticate-client (stream) + (let ((secret (slime-secret))) + (when secret + (set-stream-timeout stream 20) + (let ((first-val (read-packet stream))) + (unless (and (stringp first-val) (string= first-val secret)) + (error "Incoming connection doesn't know the password."))) + (set-stream-timeout stream nil)))) + +(defun slime-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (etypecase connection + (multithreaded-connection + (spawn-threads-for-connection connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil) (simple-serve-requests connection)) + (:sigio (install-sigio-handler connection)) + (:fd-handler (install-fd-handler connection)))))) + +(defun stop-serving-requests (connection) + (etypecase connection + (multithreaded-connection + (cleanup-connection-threads connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil)) + (:sigio (deinstall-sigio-handler connection)) + (:fd-handler (deinstall-fd-handler connection)))))) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *swank-debug-p* + (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (force-output *log-output*))) + + +;;;;; Event Decoding/Encoding + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLIME protocol." + (log-event "decode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (handler-case (read-message stream *swank-io-package*) + (swank-reader-error (c) + `(:reader-error ,(swank-reader-error.packet c) + ,(swank-reader-error.cause c))))))) + +(defun encode-message (message stream) + "Write an S-expression to STREAM using the SLIME protocol." + (log-event "encode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (write-message message *swank-io-package* stream)))) + + +;;;;; Event Processing + +(defvar *sldb-quit-restart* nil + "The restart that will be invoked when the user calls sldb-quit.") + +;; Establish a top-level restart and execute BODY. +;; Execute K if the restart is invoked. +(defmacro with-top-level-restart ((connection k) &body body) + `(with-connection (,connection) + (restart-case + (let ((*sldb-quit-restart* (find-restart 'abort))) + ,@body) + (abort (&optional v) + :report "Return to SLIME's top level." + (declare (ignore v)) + (force-user-output) + ,k)))) + +(defun handle-requests (connection &optional timeout) + "Read and process :emacs-rex requests. +The processing is done in the extent of the toplevel restart." + (with-connection (connection) + (cond (*sldb-quit-restart* + (process-requests timeout)) + (t + (tagbody + start + (with-top-level-restart (connection (go start)) + (process-requests timeout))))))) + +(defun process-requests (timeout) + "Read and process requests from Emacs." + (loop + (multiple-value-bind (event timeout?) + (wait-for-event `(or (:emacs-rex . _) + (:emacs-channel-send . _)) + timeout) + (when timeout? (return)) + (dcase event + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:emacs-channel-send channel (selector &rest args)) + (channel-send channel selector args)))))) + +(defun current-socket-io () + (connection.socket-io *emacs-connection*)) + +(defun close-connection (connection condition backtrace) + (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) + +(defun close-connection% (c condition backtrace) + (let ((*debugger-hook* nil)) + (log-event "close-connection: ~a ...~%" condition) + (format *log-output* "~&;; swank:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) + (stop-serving-requests c) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (ignore-errors (close (connection.dedicated-output c)))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* "~ +;; Event history end.~%~ +;; Backtrace:~%~{~A~%~}~ +;; Connection to Emacs lost. [~%~ +;; condition: ~A~%~ +;; type: ~S~%~ +;; style: ~S]~%" + (loop for (i f) in backtrace collect + (ignore-errors + (format nil "~d: ~a" i (escape-non-ascii f)))) + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (connection.communication-style c))) + (finish-output *log-output*) + (log-event "close-connection ~a ... done.~%" condition))) + +;;;;;; Thread based communication + +(defun read-loop (connection) + (let ((input-stream (connection.socket-io connection)) + (control-thread (mconn.control-thread connection))) + (with-swank-error-handler (connection) + (loop (send control-thread (decode-message input-stream)))))) + +(defun dispatch-loop (connection) + (let ((*emacs-connection* connection)) + (with-panic-handler (connection) + (loop (dispatch-event connection (receive)))))) + +(defgeneric thread-for-evaluation (connection id) + (:documentation "Find or create a thread to evaluate the next request.") + (:method ((connection multithreaded-connection) (id (eql t))) + (spawn-worker-thread connection)) + (:method ((connection multithreaded-connection) (id (eql :find-existing))) + (car (mconn.active-threads connection))) + (:method (connection (id integer)) + (declare (ignorable connection)) + (find-thread id)) + (:method ((connection singlethreaded-connection) id) + (declare (ignorable connection connection id)) + (current-thread))) + +(defun interrupt-worker-thread (connection id) + (let ((thread (thread-for-evaluation connection + (cond ((eq id t) :find-existing) + (t id))))) + (log-event "interrupt-worker-thread: ~a ~a~%" id thread) + (if thread + (etypecase connection + (multithreaded-connection + (queue-thread-interrupt thread #'simple-break)) + (singlethreaded-connection + (simple-break))) + (encode-message (list :debug-condition (current-thread-id) + (format nil "Thread with id ~a not found" + id)) + (current-socket-io))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (with-top-level-restart (connection nil) + (apply #'eval-for-emacs + (cdr (wait-for-event `(:emacs-rex . _))))))) + :name "worker")) + +(defun add-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (push thread (mconn.active-threads connection))) + (singlethreaded-connection))) + +(defun remove-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (setf (mconn.active-threads connection) + (delete thread (mconn.active-threads connection) :count 1))) + (singlethreaded-connection))) + +(defparameter *event-hook* nil) + +(defun dispatch-event (connection event) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "dispatch-event: ~s~%" event) + (or (run-hook-until-success *event-hook* connection event) + (dcase event + ((:emacs-rex form package thread-id id) + (let ((thread (thread-for-evaluation connection thread-id))) + (cond (thread + (add-active-thread connection thread) + (send-event thread `(:emacs-rex ,form ,package ,id))) + (t + (encode-message + (list :invalid-rpc id + (format nil "Thread not found: ~s" thread-id)) + (current-socket-io)))))) + ((:return thread &rest args) + (remove-active-thread connection thread) + (encode-message `(:return ,@args) (current-socket-io))) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread connection thread-id)) + (((:write-string + :debug :debug-condition :debug-activate :debug-return :channel-send + :presentation-start :presentation-end + :new-package :new-features :ed :indentation-update + :eval :eval-no-wait :background-message :inspect :ping + :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay + :write-image :ed-rpc :ed-rpc-no-wait) + &rest _) + (declare (ignore _)) + (encode-message event (current-socket-io))) + (((:emacs-pong :emacs-return :emacs-return-string :ed-rpc-forbidden) + thread-id &rest args) + (send-event (find-thread thread-id) (cons (car event) args))) + ((:emacs-channel-send channel-id msg) + (let ((ch (find-channel channel-id))) + (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))) + ((:reader-error packet condition) + (encode-message `(:reader-error ,packet + ,(safe-condition-message condition)) + (current-socket-io)))))) + + +(defun send-event (thread event) + (log-event "send-event: ~s ~s~%" thread event) + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send thread event)) + (singlethreaded-connection + (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) + (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) + most-positive-fixnum)))))) + +(defun send-to-emacs (event) + "Send EVENT to Emacs." + ;;(log-event "send-to-emacs: ~a" event) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send (mconn.control-thread c) event)) + (singlethreaded-connection + (dispatch-event c event))) + (maybe-slow-down)))) + + +;;;;;; Flow control + +;; After sending N (usually 100) messages we slow down and ping Emacs +;; to make sure that everything we have sent so far was received. + +(defconstant send-counter-limit 100) + +(defun maybe-slow-down () + (let ((counter (incf *send-counter*))) + (when (< send-counter-limit counter) + (setf *send-counter* 0) + (ping-pong)))) + +(defun ping-pong () + (let* ((tag (make-tag)) + (pattern `(:emacs-pong ,tag))) + (send-to-emacs `(:ping ,(current-thread-id) ,tag)) + (wait-for-event pattern))) + + +(defun wait-for-event (pattern &optional timeout) + "Scan the event queue for PATTERN and return the event. +If TIMEOUT is 'nil wait until a matching event is enqued. +If TIMEOUT is 't only scan the queue without waiting. +The second return value is t if the timeout expired before a matching +event was found." + (log-event "wait-for-event: ~s ~s~%" pattern timeout) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (receive-if (lambda (e) (event-match-p e pattern)) timeout)) + (singlethreaded-connection + (wait-for-event/event-loop c pattern timeout)))))) + +(defun wait-for-event/event-loop (connection pattern timeout) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (let ((event (poll-for-event connection pattern))) + (when event (return (car event)))) + (let ((events-enqueued (sconn.events-enqueued connection)) + (ready (wait-for-input (list (current-socket-io)) timeout))) + (cond ((and timeout (not ready)) + (return (values nil t))) + ((or (/= events-enqueued (sconn.events-enqueued connection)) + (eq ready :interrupt)) + ;; rescan event queue, interrupts may enqueue new events + ) + (t + (assert (equal ready (list (current-socket-io)))) + (dispatch-event connection + (decode-message (current-socket-io)))))))) + +(defun poll-for-event (connection pattern) + (let* ((c connection) + (tail (member-if (lambda (e) (event-match-p e pattern)) + (sconn.event-queue c)))) + (when tail + (setf (sconn.event-queue c) + (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) + tail))) + +;;; FIXME: Make this use SWANK-MATCH. +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (case (car pattern) + ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) + (t (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))))) + (t (error "Invalid pattern: ~S" pattern)))) + + + +(defun spawn-threads-for-connection (connection) + (setf (mconn.control-thread connection) + (spawn (lambda () (control-thread connection)) + :name "control-thread")) + connection) + +(defun control-thread (connection) + (with-struct* (mconn. @ connection) + (setf (@ control-thread) (current-thread)) + (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (setf (@ indentation-cache-thread) + (spawn (lambda () (indentation-cache-loop connection)) + :name "swank-indentation-cache-thread")) + (dispatch-loop connection))) + +(defun cleanup-connection-threads (connection) + (let* ((c connection) + (threads (list (mconn.repl-thread c) + (mconn.reader-thread c) + (mconn.control-thread c) + (mconn.auto-flush-thread c) + (mconn.indentation-cache-thread c)))) + (dolist (thread threads) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (ignore-errors (kill-thread thread)))))) + +;;;;;; Signal driven IO + +(defun install-sigio-handler (connection) + (add-sigio-handler (connection.socket-io connection) + (lambda () (process-io-interrupt connection))) + (handle-requests connection t)) + +(defvar *io-interupt-level* 0) + +(defun process-io-interrupt (connection) + (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) + (let ((*io-interupt-level* (1+ *io-interupt-level*))) + (invoke-or-queue-interrupt + (lambda () (handle-requests connection t)))) + (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) + +(defun deinstall-sigio-handler (connection) + (log-event "deinstall-sigio-handler...~%") + (remove-sigio-handlers (connection.socket-io connection)) + (log-event "deinstall-sigio-handler...done~%")) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (add-fd-handler (connection.socket-io connection) + (lambda () (handle-requests connection t))) + (setf (sconn.saved-sigint-handler connection) + (install-sigint-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))))) + (handle-requests connection t)) + +(defun dispatch-interrupt-event (connection) + (with-connection (connection) + (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) + +(defun deinstall-fd-handler (connection) + (log-event "deinstall-fd-handler~%") + (remove-fd-handlers (connection.socket-io connection)) + (install-sigint-handler (sconn.saved-sigint-handler connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (connection) + (unwind-protect + (with-connection (connection) + (call-with-user-break-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))) + (lambda () + (with-simple-restart (close-connection "Close SLIME connection.") + (let* ((stdin (real-input-stream *standard-input*)) + (*standard-input* (make-repl-input-stream connection + stdin))) + (tagbody toplevel + (with-top-level-restart (connection (go toplevel)) + (simple-repl)))))))) + (close-connection connection nil (safe-backtrace)))) + +;; this is signalled when our custom stream thinks the end-of-file is reached. +;; (not when the end-of-file on the socket is reached) +(define-condition end-of-repl-input (end-of-file) ()) + +(defun simple-repl () + (loop + (format t "~a> " (package-string-for-prompt *package*)) + (force-output) + (let ((form (handler-case (read) + (end-of-repl-input () (return))))) + (let ((- form) + (values (multiple-value-list (eval form)))) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + form) + (cond ((null values) (format t "; No values~&")) + (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) + +(defun make-repl-input-stream (connection stdin) + (make-input-stream + (lambda () (repl-input-stream-read connection stdin)))) + +(defun repl-input-stream-read (connection stdin) + (loop + (let* ((socket (connection.socket-io connection)) + (inputs (list socket stdin)) + (ready (wait-for-input inputs))) + (cond ((eq ready :interrupt) + (check-slime-interrupts)) + ((member socket ready) + ;; A Slime request from Emacs is pending; make sure to + ;; redirect IO to the REPL buffer. + (with-simple-restart (process-input "Continue reading input.") + (let ((*sldb-quit-restart* (find-restart 'process-input))) + (with-io-redirection (connection) + (handle-requests connection t))))) + ((member stdin ready) + ;; User typed something into the *inferior-lisp* buffer, + ;; so do not redirect. + (return (read-non-blocking stdin))) + (t (assert (null ready))))))) + +(defun read-non-blocking (stream) + (with-output-to-string (str) + (handler-case + (loop (let ((c (read-char-no-hang stream))) + (unless c (return)) + (write-char c str))) + (end-of-file () (error 'end-of-repl-input :stream stream))))) + + +;;; Channels + +;; FIXME: should be per connection not global. +(defvar *channels* '()) +(defvar *channel-counter* 0) + +(defclass channel () + ((id :reader channel-id) + (thread :initarg :thread :initform (current-thread) :reader channel-thread) + (name :initarg :name :initform nil))) + +(defmethod initialize-instance :after ((ch channel) &key) + (with-slots (id) ch + (setf id (incf *channel-counter*)) + (push (cons id ch) *channels*))) + +(defmethod print-object ((c channel) stream) + (print-unreadable-object (c stream :type t) + (with-slots (id name) c + (format stream "~d ~a" id name)))) + +(defun find-channel (id) + (cdr (assoc id *channels*))) + +(defgeneric channel-send (channel selector args)) + +(defmacro define-channel-method (selector (channel &rest args) &body body) + `(defmethod channel-send (,channel (selector (eql ',selector)) args) + (destructuring-bind ,args args + . ,body))) + +(defun send-to-remote-channel (channel-id msg) + (send-to-emacs `(:channel-send ,channel-id ,msg))) + + + +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +;; FIXME: belongs to swank-repl.lisp +(defun force-user-output () + (force-output (connection.user-io *emacs-connection*))) + +(add-hook *pre-reply-hook* 'force-user-output) + +;; FIXME: belongs to swank-repl.lisp +(defun clear-user-input () + (clear-input (connection.user-input *emacs-connection*))) + +;; FIXME: not thread save. +(defvar *tag-counter* 0) + +(defun make-tag () + (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) + +(defun y-or-n-p-in-emacs (format-string &rest arguments) + "Like y-or-n-p, but ask in the Emacs minibuffer." + (let ((tag (make-tag)) + (question (apply #'format nil format-string arguments))) + (force-output) + (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defun read-from-minibuffer-in-emacs (prompt &optional initial-value) + "Ask user a question in Emacs' minibuffer. Returns \"\" when user +entered nothing, returns NIL when user pressed C-g." + (check-type prompt string) (check-type initial-value (or null string)) + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag + ,prompt ,initial-value)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defstruct (unreadable-result + (:constructor make-unreadable-result (string)) + (:copier nil) + (:print-object + (lambda (object stream) + (print-unreadable-object (object stream :type t) + (princ (unreadable-result-string object) stream))))) + string) + +(defun symbol-name-for-emacs (symbol) + (check-type symbol symbol) + (let ((name (string-downcase (symbol-name symbol)))) + (if (keywordp symbol) + (concatenate 'string ":" name) + name))) + +(defun process-form-for-emacs (form) + "Returns a string which emacs will read as equivalent to +FORM. FORM can contain lists, strings, characters, symbols and +numbers. + +Characters are converted emacs' ? notaion, strings are left +as they are (except for espacing any nested \" chars, numbers are +printed in base 10 and symbols are printed as their symbol-name +converted to lower case." + (etypecase form + (string (format nil "~S" form)) + (cons (format nil "(~A . ~A)" + (process-form-for-emacs (car form)) + (process-form-for-emacs (cdr form)))) + (character (format nil "?~C" form)) + (symbol (symbol-name-for-emacs form)) + (number (let ((*print-base* 10)) + (princ-to-string form))))) + +(defun wait-for-emacs-return (tag) + (let ((event (caddr (wait-for-event `(:emacs-return ,tag result))))) + (dcase event + ((:unreadable value) (make-unreadable-result value)) + ((:ok value) value) + ((:error kind . data) (error "~a: ~{~a~}" kind data)) + ((:abort) (abort)) + ;; only in reply to :ed-rpc{-no-wait} events. + ((:ed-rpc-forbidden fn) (error "ED-RPC forbidden for ~a" fn))))) + +(defun eval-in-emacs (form &optional nowait) + "Eval FORM in Emacs. +`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side." + (cond (nowait + (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) + (t + (force-output) + (let ((tag (make-tag))) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (wait-for-emacs-return tag))))) + +(defun ed-rpc-no-wait (fn &rest args) + "Invoke FN in Emacs (or some lesser editor) and don't wait for the result." + (send-to-emacs `(:ed-rpc-no-wait ,(symbol-name-for-emacs fn) ,@args)) + (values)) + +(defun ed-rpc (fn &rest args) + "Invoke FN in Emacs (or some lesser editor). FN should be defined in +Emacs Lisp via `defslimefun' or otherwise marked as RPCallable." + (let ((tag (make-tag))) + (send-to-emacs `(:ed-rpc ,(current-thread-id) ,tag + ,(symbol-name-for-emacs fn) + ,@args)) + (wait-for-emacs-return tag))) + +(defvar *swank-wire-protocol-version* nil + "The version of the swank/slime communication protocol.") + +(defslimefun connection-info () + "Return a key-value list of the form: +\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) +PID: is the process-id of Lisp process (or nil, depending on the STYLE) +STYLE: the communication style +LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION) +FEATURES: a list of keywords +PACKAGE: a list (&key NAME PROMPT) +VERSION: the protocol version" + (let ((c *emacs-connection*)) + (setq *slime-features* *features*) + `(:pid ,(getpid) :style ,(connection.communication-style c) + :encoding (:coding-systems + ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") + when (find-external-format cs) collect cs)) + :lisp-implementation (:type ,(lisp-implementation-type) + :name ,(lisp-implementation-type-name) + :version ,(lisp-implementation-version) + :program ,(lisp-implementation-program)) + :machine (:instance ,(machine-instance) + :type ,(machine-type) + :version ,(machine-version)) + :features ,(features-for-emacs) + :modules ,*modules* + :package (:name ,(package-name *package*) + :prompt ,(package-string-for-prompt *package*)) + :version ,*swank-wire-protocol-version*))) + +(defun debug-on-swank-error () + (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*)) + *debug-on-swank-protocol-error*) + +(defun (setf debug-on-swank-error) (new-value) + (setf *debug-on-swank-protocol-error* new-value) + (setf *debug-swank-backend* new-value)) + +(defslimefun toggle-debug-on-swank-error () + (setf (debug-on-swank-error) (not (debug-on-swank-error)))) + + +;;;; Reading and printing + +(define-special *buffer-package* + "Package corresponding to slime-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(define-special *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&optional package) &body body) + "Execute BODY with appropriate *package* and *readtable* bindings. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + `(call-with-buffer-syntax ,package (lambda () ,@body))) + +(defun call-with-buffer-syntax (package fun) + (let ((*package* (if package + (guess-buffer-package package) + *buffer-package*))) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (let ((*readtable* *buffer-readtable*)) + (call-with-syntax-hooks fun))))) + +(defmacro without-printing-errors ((&key object stream + (msg "<>")) + &body body) + "Catches errors during evaluation of BODY and prints MSG instead." + `(handler-case (progn ,@body) + (serious-condition () + ,(cond ((and stream object) + (let ((gstream (gensym "STREAM+"))) + `(let ((,gstream ,stream)) + (print-unreadable-object (,object ,gstream :type t + :identity t) + (write-string ,msg ,gstream))))) + (stream + `(write-string ,msg ,stream)) + (object + `(with-output-to-string (s) + (print-unreadable-object (,object s :type t :identity t) + (write-string ,msg s)))) + (t msg))))) + +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable. Handles problems with PRINT-OBJECT methods +gracefully." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (without-printing-errors (:object object :stream nil) + (prin1-to-string object))))) + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (with-buffer-syntax () + (let ((*read-suppress* nil)) + (values (read-from-string string))))) + +(defun parse-string (string package) + "Read STRING in PACKAGE." + (with-buffer-syntax (package) + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #\: string) 1)))) + (values symbol package internp))) + +(defun tokenize-symbol-thoroughly (string) + "This version of TOKENIZE-SYMBOL handles escape characters." + (let ((package nil) + (token (make-array (length string) :element-type 'character + :fill-pointer 0)) + (backslash nil) + (vertical nil) + (internp nil)) + (loop for char across string do + (cond + (backslash + (vector-push-extend char token) + (setq backslash nil)) + ((char= char #\\) ; Quotes next character, even within |...| + (setq backslash t)) + ((char= char #\|) + (setq vertical (not vertical))) + (vertical + (vector-push-extend char token)) + ((char= char #\:) + (cond ((and package internp) + (return-from tokenize-symbol-thoroughly)) + (package + (setq internp t)) + (t + (setq package token + token (make-array (length string) + :element-type 'character + :fill-pointer 0))))) + (t + (vector-push-extend (casify-char char) token)))) + (unless vertical + (values token package (or (not package) internp))))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" + (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" + (untokenize-symbol nil nil \"foo\") ==> \"foo\" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun casify-char (char) + "Convert CHAR accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (if (upper-case-p char) + (char-downcase char) + (char-upcase char))))) + + +(defun find-symbol-with-status (symbol-name status + &optional (package *package*)) + (multiple-value-bind (symbol flag) (find-symbol symbol-name package) + (if (and flag (eq flag status)) + (values symbol flag) + (values nil nil)))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname internalp) + (tokenize-symbol-thoroughly string) + (when sname + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) + (if internalp + (find-symbol sname package) + (find-symbol-with-status sname ':external package)) + (values symbol flag sname package)) + (values nil nil nil nil)))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + ;; STRING comes usually from a (in-package STRING) form. + (ignore-errors + (find-package (let ((*package* *swank-io-package*)) + (read-from-string string))))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (when string + (or (find-package string) + (parse-package string) + (if (find #\! string) ; for SBCL + (guess-package (substitute #\- #\! string)))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defun eval-for-emacs (form buffer-package id) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. +Errors are trapped and invoke our debugger." + (let (ok result condition) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;; (setq result (apply (car form) (cdr form))) + (handler-bind ((t (lambda (c) (setf condition c)))) + (setq result (with-slime-interrupts (eval form)))) + (run-hook *pre-reply-hook*) + (setq ok t)) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort ,(prin1-to-string condition))) + ,id))))) + +(defvar *echo-area-prefix* "=> " + "A prefix that `format-values-for-echo-area' should use.") + +(defun format-values-for-echo-area (values) + (with-buffer-syntax () + (let ((*print-readably* nil)) + (cond ((null values) "; No value") + ((and (integerp (car values)) (null (cdr values))) + (let ((i (car values))) + (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)" + *echo-area-prefix* + i (integer-length i) i i i))) + ((and (typep (car values) 'ratio) + (null (cdr values)) + (ignore-errors + ;; The ratio may be to large to be represented as a single float + (format nil "~A~D (~:*~f)" + *echo-area-prefix* + (car values))))) + (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) + +(defmacro values-to-string (values) + `(format-values-for-echo-area (multiple-value-list ,values))) + +(defslimefun interactive-eval (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (let ((values (multiple-value-list (eval (from-string string))))) + (finish-output) + (format-values-for-echo-area values))))) + +(defslimefun eval-and-grab-output (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (format nil "~{~S~^~%~}" values)))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (finish-output) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslimefun interactive-eval-region (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (format-values-for-echo-area (eval-region string))))) + +(defslimefun re-evaluate-defvar (form) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form))))))) + +(defvar *swank-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*print-circle* . t) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun swank-pprint (values) + "Bind some printer variables and pretty print each object in VALUES." + (with-buffer-syntax () + (with-bindings *swank-pprint-bindings* + (cond ((null values) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o values) + (pprint o) + (terpri)))))))) + +(defslimefun pprint-eval (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (values + (let ((*standard-output* s) + (*trace-output* s)) + (multiple-value-list (eval (read-from-string string)))))) + (cat (get-output-stream-string s) + (swank-pprint values))))) + +(defslimefun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p) nil "Package ~a doesn't exist." name) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun truncate-string (string width &optional ellipsis) + (let ((len (length string))) + (cond ((< len width) string) + (ellipsis (cat (subseq string 0 width) ellipsis)) + (t (subseq string 0 width))))) + +(defun call/truncated-output-to-string (length function + &optional (ellipsis "..")) + "Call FUNCTION with a new stream, return the output written to the stream. +If FUNCTION tries to write more than LENGTH characters, it will be +aborted and return immediately with the output written so far." + (let ((buffer (make-string (+ length (length ellipsis)))) + (fill-pointer 0)) + (block buffer-full + (flet ((write-output (string) + (let* ((free (- length fill-pointer)) + (count (min free (length string)))) + (replace buffer string :start1 fill-pointer :end2 count) + (incf fill-pointer count) + (when (> (length string) free) + (replace buffer ellipsis :start1 fill-pointer) + (return-from buffer-full buffer))))) + (let ((stream (make-output-stream #'write-output))) + (funcall function stream) + (finish-output stream) + (subseq buffer 0 fill-pointer)))))) + +(defmacro with-string-stream ((var &key length bindings) + &body body) + (cond ((and (not bindings) (not length)) + `(with-output-to-string (,var) . ,body)) + ((not bindings) + `(call/truncated-output-to-string + ,length (lambda (,var) . ,body))) + (t + `(with-bindings ,bindings + (with-string-stream (,var :length ,length) + . ,body))))) + +(defun to-line (object &optional width) + "Print OBJECT to a single line. Return the string." + (let ((width (or width 512))) + (without-printing-errors (:object object :stream nil) + (with-string-stream (stream :length width) + (write object :stream stream :right-margin width :lines 1))))) + +(defun escape-string (string stream &key length (map '((#\" . "\\\"") + (#\\ . "\\\\")))) + "Write STRING to STREAM surronded by double-quotes. +LENGTH -- if non-nil truncate output after LENGTH chars. +MAP -- rewrite the chars in STRING according to this alist." + (let ((limit (or length array-dimension-limit))) + (write-char #\" stream) + (loop for c across string + for i from 0 do + (when (= i limit) + (write-string "..." stream) + (return)) + (let ((probe (assoc c map))) + (cond (probe (write-string (cdr probe) stream)) + (t (write-char c stream))))) + (write-char #\" stream))) + + +;;;; Prompt + +;; FIXME: do we really need 45 lines of code just to figure out the +;; prompt? + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (loop with package-name = (package-name package) + with offset = nil + do (let ((last-dot-pos (position #\. package-name :end offset + :from-end t))) + (unless last-dot-pos + (return nil)) + ;; If a dot chunk contains only numbers, that chunk most + ;; likely represents a version number; so we collect the + ;; next chunks, too, until we find one with meat. + (let ((name (subseq package-name (1+ last-dot-pos) offset))) + (if (notevery #'digit-char-p name) + (return (subseq package-name (1+ last-dot-pos))) + (setq offset last-dot-pos))))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + + + +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + A pathname or a string, + A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), + A function name (symbol or cons), + NIL. " + (flet ((canonicalize-filename (filename) + (pathname-to-filename (or (probe-file filename) filename)))) + (let ((target + (etypecase what + (null nil) + ((or string pathname) + `(:filename ,(canonicalize-filename what))) + ((cons (or string pathname) *) + `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) + ((or symbol cons) + `(:function-name ,(prin1-to-string what)))))) + (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) + ((default-connection) + (with-connection ((default-connection)) + (send-oob-to-emacs `(:ed ,target)))) + (t (error "No connection")))))) + +(defslimefun inspect-in-emacs (what &key wait) + "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the +inspector has been closed in Emacs." + (flet ((send-it () + (let ((tag (when wait (make-tag))) + (thread (when wait (current-thread-id)))) + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what) + ,thread + ,tag))) + (when wait + (wait-for-event `(:emacs-return ,tag result)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(defslimefun value-for-editing (form) + "Return a readable value of FORM for editing in Emacs. +FORM is expected, but not required, to be SETF'able." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (let* ((value (eval (read-from-string form))) + (*print-length* nil)) + (prin1-to-string value)))) + +(defslimefun commit-edited-value (form value) + "Set the value of a setf'able FORM to VALUE. +FORM and VALUE are both strings from Emacs." + (with-buffer-syntax () + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) + t)) + +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + +;; This is only used by the test suite. +(defun sleep-for (seconds) + "Sleep for at least SECONDS seconds. +This is just like cl:sleep but guarantees to sleep +at least SECONDS." + (let* ((start (get-internal-real-time)) + (end (+ start + (* seconds internal-time-units-per-second)))) + (loop + (let ((now (get-internal-real-time))) + (cond ((< end now) (return)) + (t (sleep (/ (- end now) + internal-time-units-per-second)))))))) + + +;;;; Debugger + +(defun invoke-slime-debugger (condition) + "Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (without-slime-interrupts + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) + +(define-condition invoke-default-debugger () ()) + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) + (handler-case + (call-with-debugger-hook #'swank-debugger-hook + (lambda () (invoke-slime-debugger condition))) + (invoke-default-debugger () + (invoke-default-debugger condition)))) + +(defun invoke-default-debugger (condition) + (call-with-debugger-hook nil (lambda () (invoke-debugger condition)))) + +(defvar *global-debugger* t + "Non-nil means the Swank debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'swank-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *swank-debugger-condition* nil + "The condition being debugged.") + +(defvar *sldb-level* 0 + "The current level of recursive debugging.") + +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sldb-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sldb-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-restarts condition)) + (*sldb-quit-restart* (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*))) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil)) + (force-user-output) + (call-with-debugging-environment + (lambda () + (sldb-loop *sldb-level*))))) + +(defun sldb-loop (level) + (unwind-protect + (loop + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs + (list* :debug (current-thread-id) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (send-to-emacs + (list :debug-activate (current-thread-id) level nil)) + (loop + (handler-case + (dcase (wait-for-event + `(or (:emacs-rex . _) + (:sldb-return ,(1+ level)))) + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:sldb-return _) (declare (ignore _)) (return nil))) + (sldb-condition (c) + (handle-sldb-condition c)))))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sldb-stepping-p*)) + (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue + (when (> level 1) + (send-event (current-thread) `(:sldb-return ,level))))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread-id) + ,(princ-to-string real-condition))))) + +(defun %%condition-message (condition) + (let ((limit (ash 1 16))) + (with-string-stream (stream :length limit) + (handler-case + (let ((*print-readably* nil) + (*print-pretty* t) + (*print-right-margin* 65) + (*print-circle* t) + (*print-length* (or *print-length* limit)) + (*print-level* (or *print-level* limit)) + (*print-lines* (or *print-lines* limit))) + (print-condition condition stream)) + (serious-condition (c) + (ignore-errors + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format stream "~&Error (~a) during printing: " (type-of c)) + (print-unreadable-object (condition stream :type t + :identity t)))))))))) + +(defun %condition-message (condition) + (string-trim #(#\newline #\space #\tab) + (%%condition-message condition))) + +(defvar *sldb-condition-printer* #'%condition-message + "Function called to print a condition to an SLDB buffer.") + +(defun safe-condition-message (condition) + "Print condition to a string, handling any errors during printing." + (funcall *sldb-condition-printer* condition)) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)) + (condition-extras *swank-debugger-condition*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sldb-restarts* collect + (list (format nil "~:[~;*~]~a" + (eq restart *sldb-quit-restart*) + (restart-name restart)) + (with-output-to-string (stream) + (without-printing-errors (:object restart + :stream stream + :msg "<>") + (princ restart stream))))))) + +;;;;; SLDB entry points + +(defslimefun sldb-break-with-default-debugger (dont-unwind) + "Invoke the default debugger." + (cond (dont-unwind + (invoke-default-debugger *swank-debugger-condition*)) + (t + (signal 'invoke-default-debugger)))) + +(defslimefun backtrace (start end) + "Return a list ((I FRAME PLIST) ...) of frames from START to END. + +I is an integer, and can be used to reference the corresponding frame +from Emacs; FRAME is a string representation of an implementation's +frame." + (loop for frame in (compute-backtrace start end) + for i from start collect + (list* i (frame-to-string frame) + (ecase (frame-restartable-p frame) + ((nil) nil) + ((t) `((:restartable t))))))) + +(defun frame-to-string (frame) + (with-string-stream (stream :length (* (or *print-lines* 1) + (or *print-right-margin* 100)) + :bindings *backtrace-printer-bindings*) + (handler-case (print-frame frame stream) + (serious-condition () + (format stream "[error printing frame]"))))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description [plist]) + extra ::= (:references and other random things) + cont ::= continutation + plist ::= (:restartable {nil | t | :unknown}) + +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continutation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil))) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (let ((restart (nth-restart index))) + (when restart + (invoke-restart-interactively restart)))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defslimefun sldb-continue () + (continue)) + +(defun coerce-to-condition (datum args) + (etypecase datum + (string (make-condition 'simple-error :format-control datum + :format-arguments args)) + (symbol (apply #'make-condition datum args)))) + +(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) + (with-simple-restart (continue "Continue from break.") + (invoke-slime-debugger (coerce-to-condition datum args)))) + +;; FIXME: (last (compute-restarts)) looks dubious. +(defslimefun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (let ((restart (or (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*)) + (car (last (compute-restarts)))))) + (cond (restart (invoke-restart restart)) + (t (format nil "Restart not active [~s]" *sldb-quit-restart*))))) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level n) + "Invoke the Nth available restart. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun wrap-sldb-vars (form) + `(let ((*sldb-level* ,*sldb-level*)) + ,form)) + +(defun eval-in-frame-aux (frame string package print) + (let* ((form (wrap-sldb-vars (parse-string string package))) + (values (multiple-value-list (eval-in-frame form frame)))) + (with-buffer-syntax (package) + (funcall print values)))) + +(defslimefun eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'format-values-for-echo-area)) + +(defslimefun pprint-eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'swank-pprint)) + +(defslimefun frame-package-name (frame) + (let ((pkg (frame-package frame))) + (cond (pkg (package-name pkg)) + (t (with-buffer-syntax () (package-name *package*)))))) + +(defslimefun frame-locals-and-catch-tags (index) + "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. +LOCALS is a list of the form ((&key NAME ID VALUE) ...). +TAGS has is a list of strings." + (list (frame-locals-for-emacs index) + (mapcar #'to-string (frame-catch-tags index)))) + +(defun frame-locals-for-emacs (index) + (with-bindings *backtrace-printer-bindings* + (loop for var in (frame-locals index) collect + (destructuring-bind (&key name id value) var + (list :name (let ((*package* (or (frame-package index) *package*))) + (prin1-to-string name)) + :id id + :value (to-line value *print-right-margin*)))))) + +(defslimefun sldb-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslimefun sldb-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslimefun sldb-break (name) + (with-buffer-syntax () + (sldb-break-at-start (read-from-string name)))) + +(defmacro define-stepper-function (name backend-function-name) + `(defslimefun ,name (frame) + (cond ((sldb-stepper-condition-p *swank-debugger-condition*) + (setq *sldb-stepping-p* t) + (,backend-function-name)) + ((find-restart 'continue) + (activate-stepping frame) + (setq *sldb-stepping-p* t) + (continue)) + (t + (error "Not currently single-stepping, ~ +and no continue restart available."))))) + +(define-stepper-function sldb-step sldb-step-into) +(define-stepper-function sldb-next sldb-step-next) +(define-stepper-function sldb-out sldb-step-out) + +(defslimefun toggle-break-on-signals () + (setq *break-on-signals* (not *break-on-signals*)) + (format nil "*break-on-signals* = ~a" *break-on-signals*)) + +(defslimefun sdlb-print-condition () + (princ-to-string *swank-debugger-condition*)) + + +;;;; Compilation Commands. + +(defstruct (compilation-result (:type list)) + (type :compilation-result) + notes + (successp nil :type boolean) + (duration 0.0 :type float) + (loadp nil :type boolean) + (faslfile nil :type (or null string))) + +(defun measure-time-interval (fun) + "Call FUN and return the first return value and the elapsed time. +The time is measured in seconds." + (declare (type function fun)) + (let ((before (get-internal-real-time))) + (values + (funcall fun) + (/ (- (get-internal-real-time) before) + (coerce internal-time-units-per-second 'float))))) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (source-context condition))) + (if s (list :source-context s))))) + +(defun collect-notes (function) + (let ((notes '())) + (multiple-value-bind (result seconds) + (handler-bind ((compiler-condition + (lambda (c) (push (make-compiler-note c) notes)))) + (measure-time-interval + (lambda () + ;; To report location of error-signaling toplevel forms + ;; for errors in EVAL-WHEN or during macroexpansion. + (restart-case (multiple-value-list (funcall function)) + (abort () :report "Abort compilation." (list nil)))))) + (destructuring-bind (successp &optional loadp faslfile) result + (let ((faslfile (etypecase faslfile + (null nil) + (pathname (pathname-to-filename faslfile))))) + (make-compilation-result :notes (reverse notes) + :duration seconds + :successp (if successp t) + :loadp (if loadp t) + :faslfile faslfile)))))) + +(defun swank-compile-file* (pathname load-p &rest options &key policy + &allow-other-keys) + (multiple-value-bind (output-pathname warnings? failure?) + (swank-compile-file pathname + (fasl-pathname pathname options) + nil + (or (guess-external-format pathname) + :default) + :policy policy) + (declare (ignore warnings?)) + (values t (not failure?) load-p output-pathname))) + +(defvar *compile-file-for-emacs-hook* '(swank-compile-file*)) + +(defslimefun compile-file-for-emacs (filename load-p &rest options) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((pathname (filename-to-pathname filename)) + (*compile-print* nil) + (*compile-verbose* t)) + (loop for hook in *compile-file-for-emacs-hook* + do + (multiple-value-bind (tried success load? output-pathname) + (apply hook pathname load-p options) + (when tried + (return (values success load? output-pathname)))))))))) + +;; FIXME: now that *compile-file-for-emacs-hook* is there this is +;; redundant and confusing. +(defvar *fasl-pathname-function* nil + "In non-nil, use this function to compute the name for fasl-files.") + +(defun pathname-as-directory (pathname) + (append (pathname-directory pathname) + (when (pathname-name pathname) + (list (file-namestring pathname))))) + +(defun compile-file-output (file directory) + (make-pathname :directory (pathname-as-directory directory) + :defaults (compile-file-pathname file))) + +(defun fasl-pathname (input-file options) + (cond (*fasl-pathname-function* + (funcall *fasl-pathname-function* input-file options)) + ((getf options :fasl-directory) + (let ((dir (getf options :fasl-directory))) + (assert (char= (aref dir (1- (length dir))) #\/)) + (compile-file-output input-file dir))) + (t + (compile-file-pathname input-file)))) + +(defslimefun compile-string-for-emacs (string buffer position filename policy) + "Compile STRING (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (let* ((offset (cadr (assoc :position position))) + (line-column (cdr (assoc :line position))) + (line (first line-column)) + (column (second line-column))) + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position offset + :filename filename + :line line + :column column + :policy policy))))))) + +(defslimefun compile-multiple-strings-for-emacs (strings policy) + "Compile STRINGS (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (loop for (string buffer package position filename) in strings collect + (collect-notes + (lambda () + (with-buffer-syntax (package) + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position position + :filename filename + :policy policy))))))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslimefun compile-file-if-needed (filename loadp) + (let ((pathname (filename-to-pathname filename))) + (cond ((requires-compile-p pathname) + (compile-file-for-emacs pathname loadp)) + (t + (collect-notes + (lambda () + (or (not loadp) + (load (compile-file-pathname pathname))))))))) + + +;;;; Loading + +(defslimefun load-file (filename) + (to-string (load (filename-to-pathname filename)))) + + +;;;;; swank-require + +(defslimefun swank-require (modules &optional filename) + "Load the module MODULE." + (dolist (module (ensure-list modules)) + (unless (member (string module) *modules* :test #'string=) + (require module (if filename + (filename-to-pathname filename) + (module-filename module))) + (assert (member (string module) *modules* :test #'string=) + () "Required module ~s was not provided" module))) + *modules*) + +(defvar *find-module* 'find-module + "Pluggable function to locate modules. +The function receives a module name as argument and should return +the filename of the module (or nil if the file doesn't exist).") + +(defun module-filename (module) + "Return the filename for the module MODULE." + (or (funcall *find-module* module) + (error "Can't locate module: ~s" module))) + +;;;;;; Simple *find-module* function. + +(defun merged-directory (dirname defaults) + (pathname-directory + (merge-pathnames + (make-pathname :directory `(:relative ,dirname) :defaults defaults) + defaults))) + +(defvar *load-path* '() + "A list of directories to search for modules.") + +(defun module-candidates (name dir) + (list (compile-file-pathname (make-pathname :name name :defaults dir)) + (make-pathname :name name :type "lisp" :defaults dir))) + +(defun find-module (module) + (let ((name (string-downcase module))) + (some (lambda (dir) (some #'probe-file (module-candidates name dir))) + *load-path*))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil))) + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string (funcall expander (from-string string)))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + +(defslimefun swank-compiler-macroexpand-1 (string) + (apply-macro-expander #'compiler-macroexpand-1 string)) + +(defslimefun swank-compiler-macroexpand (string) + (apply-macro-expander #'compiler-macroexpand string)) + +(defslimefun swank-expand-1 (string) + (apply-macro-expander #'expand-1 string)) + +(defslimefun swank-expand (string) + (apply-macro-expander #'expand string)) + +(defun expand-1 (form) + (multiple-value-bind (expansion expanded?) (macroexpand-1 form) + (if expanded? + (values expansion t) + (compiler-macroexpand-1 form)))) + +(defun expand (form) + (expand-repeatedly #'expand-1 form)) + +(defun expand-repeatedly (expander form) + (loop + (multiple-value-bind (expansion expanded?) (funcall expander form) + (unless expanded? (return expansion)) + (setq form expansion)))) + +(defslimefun swank-format-string-expand (string) + (apply-macro-expander #'format-string-expand string)) + +(defslimefun disassemble-form (form) + (with-buffer-syntax () + (with-output-to-string (*standard-output*) + (let ((*print-readably* nil)) + (disassemble (eval (read-from-string form))))))) + + +;;;; Simple completion + +(defslimefun simple-completions (prefix package) + "Return a list of completions for the string PREFIX." + (let ((strings (all-completions prefix package))) + (list strings (longest-common-prefix strings)))) + +(defun all-completions (prefix package) + (multiple-value-bind (name pname intern) (tokenize-symbol prefix) + (let* ((extern (and pname (not intern))) + (pkg (cond ((equal pname "") keyword-package) + ((not pname) (guess-buffer-package package)) + (t (guess-package pname)))) + (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) + (syms (and pkg (matching-symbols pkg extern test))) + (strings (loop for sym in syms + for str = (unparse-symbol sym) + when (prefix-match-p name str) ; remove |Foo| + collect str))) + (format-completion-set strings intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + +;;;; Simple arglist display + +(defslimefun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package))))) + (cond ((eq args :not-available) nil) + (t (princ-to-string (cons name args))))))) + + +;;;; Documentation + +(defslimefun apropos-list-for-emacs (name &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (remove-duplicates + (apropos-symbols name external-only case-sensitive package)) + #'present-symbol-before-p)))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (x y) + "Return true if X belongs before Y in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (declare (type symbol x y)) + (flet ((accessible (s) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) + (let ((ax (accessible x)) (ay (accessible y))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) + +(defun make-apropos-matcher (pattern case-sensitive) + (let ((chr= (if case-sensitive #'char= #'char-equal))) + (lambda (symbol) + (search pattern (string symbol) :test chr=)))) + +(defun apropos-symbols (string external-only case-sensitive package) + (let ((packages (or package (remove (find-package :keyword) + (list-all-packages)))) + (matcher (make-apropos-matcher string case-sensitive)) + (result)) + (with-package-iterator (next packages :external :internal) + (loop (multiple-value-bind (morep symbol) (next) + (cond ((not morep) (return)) + ((and (if external-only (symbol-external-p symbol) t) + (funcall matcher symbol)) + (push symbol result)))))) + result)) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslimefun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslimefun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslimefun documentation-symbol (symbol-name) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (with-output-to-string (string) + (format string "Documentation for the symbol ~a:~2%" sym) + (unless (or vdoc fdoc) + (format string "Not documented." )) + (when vdoc + (format string "Variable:~% ~a~2%" vdoc)) + (when fdoc + (format string "Function:~% Arglist: ~a~2% ~a" + (arglist sym) + fdoc)))) + (format nil "No such symbol, ~a." symbol-name))))) + + +;;;; Package Commands + +(defslimefun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defvar *after-toggle-trace-hook* nil + "Hook called whenever a SPEC is traced or untraced. + +If non-nil, called with two arguments SPEC and TRACED-P." ) +(defslimefun swank-toggle-trace (spec-string) + (let* ((spec (from-string spec-string)) + (retval (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec)))) + (traced-p (let* ((tosearch "is now traced.") + (start (- (length retval) + (length tosearch))) + (end (+ start (length tosearch)))) + (search tosearch (subseq retval start end)))) + (hook-msg (when *after-toggle-trace-hook* + (funcall *after-toggle-trace-hook* + spec + traced-p)))) + (if hook-msg + (format nil "~a~%(also ~a)" retval hook-msg) + retval))) + +(defslimefun untrace-all () + (untrace)) + + +;;;; Undefing + +(defslimefun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + +(defslimefun unintern-symbol (name package) + (let ((pkg (guess-package package))) + (cond ((not pkg) (format nil "No such package: ~s" package)) + (t + (multiple-value-bind (sym found) (parse-symbol name pkg) + (case found + ((nil) (format nil "~s not in package ~s" name package)) + (t + (unintern sym pkg) + (format nil "Uninterned symbol: ~s" sym)))))))) + +(defslimefun swank-delete-package (package-name) + (let ((pkg (or (guess-package package-name) + (error "No such package: ~s" package-name)))) + (delete-package pkg) + nil)) + + +;;;; Profiling + +(defun profiledp (fspec) + (member fspec (profiled-functions))) + +(defslimefun toggle-profile-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((profiledp fname) + (unprofile fname) + (format nil "~S is now unprofiled." fname)) + (t + (profile fname) + (format nil "~S is now profiled." fname))))) + +(defslimefun profile-by-substring (substring package) + (let ((count 0)) + (flet ((maybe-profile (symbol) + (when (and (fboundp symbol) + (not (profiledp symbol)) + (search substring (symbol-name symbol) :test #'equalp)) + (handler-case (progn + (profile symbol) + (incf count)) + (error (condition) + (warn "~a" condition)))))) + (if package + (do-symbols (symbol (parse-package package)) + (maybe-profile symbol)) + (do-all-symbols (symbol) + (maybe-profile symbol)))) + (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) + +(defslimefun swank-profile-package (package-name callersp methodsp) + (let ((pkg (or (guess-package package-name) + (error "Not a valid package name: ~s" package-name)))) + (check-type callersp boolean) + (check-type methodsp boolean) + (profile-package pkg callersp methodsp))) + + +;;;; Source Locations + +(defslimefun find-definition-for-thing (thing) + (find-source-location thing)) + +(defslimefun find-source-location-for-emacs (spec) + (find-source-location (value-spec-ref spec))) + +(defun value-spec-ref (spec) + (dcase spec + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (inspector-nth-part part)) + ((:sldb frame var) + (frame-var-value frame var)))) + +(defvar *find-definitions-right-trim* ",:.>") +(defvar *find-definitions-left-trim* "#:<") + +(defun find-definitions-find-symbol-or-package (name) + (flet ((do-find (name) + (multiple-value-bind (symbol found name) + (with-buffer-syntax () + (parse-symbol name)) + (cond (found + (return-from find-definitions-find-symbol-or-package + (values symbol found))) + ;; Packages are not named by symbols, so + ;; not-interned symbols can refer to packages + ((find-package name) + (return-from find-definitions-find-symbol-or-package + (values (make-symbol name) t))))))) + (do-find name) + (do-find (string-right-trim *find-definitions-right-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* + (string-right-trim + *find-definitions-right-trim* name))) + ;; Not exactly robust + (when (and (eql (search "(setf " name :test #'char-equal) 0) + (char= (char name (1- (length name))) #\))) + (multiple-value-bind (symbol found) + (with-buffer-syntax () + (parse-symbol (subseq name (length "(setf ") + (1- (length name))))) + (when found + (values `(setf ,symbol) t)))))) + +(defslimefun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (symbol found) + (find-definitions-find-symbol-or-package name) + (when found + (mapcar #'xref>elisp (find-definitions symbol))))) + +;;; Generic function so contribs can extend it. +(defgeneric xref-doit (type thing) + (:method (type thing) + (declare (ignore type thing)) + :not-implemented)) + +(macrolet ((define-xref-action (xref-type handler) + `(defmethod xref-doit ((type (eql ,xref-type)) thing) + (declare (ignorable type)) + (funcall ,handler thing)))) + (define-xref-action :calls #'who-calls) + (define-xref-action :calls-who #'calls-who) + (define-xref-action :references #'who-references) + (define-xref-action :binds #'who-binds) + (define-xref-action :sets #'who-sets) + (define-xref-action :macroexpands #'who-macroexpands) + (define-xref-action :specializes #'who-specializes) + (define-xref-action :callers #'list-callers) + (define-xref-action :callees #'list-callees)) + +(defslimefun xref (type name) + (multiple-value-bind (sexp error) (ignore-errors (from-string name)) + (unless error + (let ((xrefs (xref-doit type sexp))) + (if (eq xrefs :not-implemented) + :not-implemented + (mapcar #'xref>elisp xrefs)))))) + +(defslimefun xrefs (types name) + (loop for type in types + for xrefs = (xref type name) + when (and (not (eq :not-implemented xrefs)) + (not (null xrefs))) + collect (cons type xrefs))) + +(defun xref>elisp (xref) + (destructuring-bind (name loc) xref + (list (to-string name) loc))) + + +;;;;; Lazy lists + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr ,@more))))) + +(defun lcons-cdr (lcons) + (with-struct* (lcons- @ lcons) + (cond ((@ forced?) + (@ %cdr)) + (t + (let ((value (funcall (@ %cdr)))) + (setf (@ forced?) t + (@ %cdr) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + + +;;;; Inspecting + +(defvar *inspector-verbose* nil) + +(defvar *inspector-printer-bindings* + '((*print-lines* . 1) + (*print-right-margin* . 75) + (*print-pretty* . t) + (*print-readably* . nil))) + +(defvar *inspector-verbose-printer-bindings* + '((*print-escape* . t) + (*print-circle* . t) + (*print-array* . nil))) + +(defstruct inspector-state) +(defstruct (istate (:conc-name istate.) (:include inspector-state)) + object + (verbose *inspector-verbose*) + (parts (make-array 10 :adjustable t :fill-pointer 0)) + (actions (make-array 10 :adjustable t :fill-pointer 0)) + metadata-plist + content + next previous) + +(defvar *istate* nil) +(defvar *inspector-history*) + +(defun reset-inspector () + (setq *istate* nil + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval (read-from-string string)))))) + +(defun ensure-istate-metadata (o indicator default) + (with-struct (istate. object metadata-plist) *istate* + (assert (eq object o)) + (let ((data (getf metadata-plist indicator default))) + (setf (getf metadata-plist indicator) data) + data))) + +(defun inspect-object (o) + (let* ((prev *istate*) + (istate (make-istate :object o :previous prev + :verbose (cond (prev (istate.verbose prev)) + (t *inspector-verbose*))))) + (setq *istate* istate) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (unless (find o *inspector-history*) + (vector-push-extend o *inspector-history*)) + (let ((previous (istate.previous istate))) + (if previous (setf (istate.next previous) istate))) + (istate>elisp istate))) + +(defun emacs-inspect/istate (istate) + (with-bindings (if (istate.verbose istate) + *inspector-verbose-printer-bindings* + *inspector-printer-bindings*) + (emacs-inspect (istate.object istate)))) + +(defun istate>elisp (istate) + (list :title (prepare-title istate) + :id (assign-index (istate.object istate) (istate.parts istate)) + :content (prepare-range istate 0 500))) + +(defun prepare-title (istate) + (if (istate.verbose istate) + (with-bindings *inspector-verbose-printer-bindings* + (to-string (istate.object istate))) + (with-string-stream (stream :length 200 + :bindings *inspector-printer-bindings*) + (print-unreadable-object + ((istate.object istate) stream :type t :identity t))))) + +(defun prepare-range (istate start end) + (let* ((range (content-range (istate.content istate) start end)) + (ps (loop for part in range append (prepare-part part istate)))) + (list ps + (if (< (length ps) (- end start)) + (+ start (length ps)) + (+ end 1000)) + start end))) + +(defun prepare-part (part istate) + (let ((newline '#.(string #\newline))) + (etypecase part + (string (list part)) + (cons (dcase part + ((:newline) (list newline)) + ((:value obj &optional str) + (list (value-part obj str (istate.parts istate)))) + ((:label &rest strs) + (list (list :label (apply #'cat (mapcar #'string strs))))) + ((:action label lambda &key (refreshp t)) + (list (action-part label lambda refreshp + (istate.actions istate)))) + ((:line label value) + (list (princ-to-string label) ": " + (value-part value nil (istate.parts istate)) + newline))))))) + +(defun value-part (object string parts) + (list :value + (or string (print-part-to-string object)) + (assign-index object parts))) + +(defun action-part (label lambda refreshp actions) + (list :action label (assign-index (list lambda refreshp) actions))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun print-part-to-string (value) + (let* ((*print-readably* nil) + (string (to-line value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "@~D=~A" pos string) + string))) + +(defun content-range (list start end) + (typecase list + (list (let ((len (length list))) + (subseq list start (min len end)))) + (lcons (llist-range list start end)))) + +(defslimefun inspector-nth-part (index) + "Return the current inspector's INDEXth part. +The second value indicates if that part exists at all." + (let* ((parts (istate.parts *istate*)) + (foundp (< index (length parts)))) + (values (and foundp (aref parts index)) + foundp))) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-range (from to) + (prepare-range *istate* from to)) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) + (apply fun args) + (if refreshp + (inspector-reinspect) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Inspect the previous object. +Return nil if there's no previous object." + (with-buffer-syntax () + (cond ((istate.previous *istate*) + (setq *istate* (istate.previous *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the history of inspected objects.." + (with-buffer-syntax () + (cond ((istate.next *istate*) + (setq *istate* (istate.next *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-reinspect () + (let ((istate *istate*)) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (istate>elisp istate))) + +(defslimefun inspector-toggle-verbose () + "Toggle verbosity of inspected object." + (setf (istate.verbose *istate*) (not (istate.verbose *istate*))) + (istate>elisp *istate*)) + +(defslimefun inspector-eval (string) + (let* ((obj (istate.object *istate*)) + (context (eval-context obj)) + (form (with-buffer-syntax ((cdr (assoc '*package* context))) + (read-from-string string))) + (ignorable (remove-if #'boundp (mapcar #'car context)))) + (to-string (eval `(let ((* ',obj) (- ',form) + . ,(loop for (var . val) in context + unless (constantp var) collect + `(,var ',val))) + (declare (ignorable . ,ignorable)) + ,form))))) + +(defslimefun inspector-history () + (with-output-to-string (out) + (let ((newest (loop for s = *istate* then next + for next = (istate.next s) + if (not next) return s))) + (format out "--- next/prev chain ---") + (loop for s = newest then (istate.previous s) while s do + (let ((val (istate.object s))) + (format out "~%~:[ ~; *~]@~d " + (eq s *istate*) + (position val *inspector-history*)) + (print-unreadable-object (val out :type t :identity t))))) + (format out "~%~%--- all visited objects ---") + (loop for val across *inspector-history* for i from 0 do + (format out "~%~2,' d " i) + (print-unreadable-object (val out :type t :identity t))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string (istate.object *istate*)))) + +(defslimefun pprint-inspector-part (index) + "Pretty-print the currently inspected object." + (with-buffer-syntax () + (swank-pprint (list (inspector-nth-part index))))) + +(defslimefun inspect-in-frame (string index) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + +;;;;; Lists + +(defmethod emacs-inspect ((o cons)) + (if (listp (cdr o)) + (inspect-list o) + (inspect-cons o))) + +(defun inspect-cons (cons) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons)))) + +(defun inspect-list (list) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (list* title '(:newline) (inspect-list-aux list)))) + (cond ((not length) + (frob "A circular list:" + (cons (car list) + (ldiff (cdr list) list)))) + ((not tail) + (frob "A proper list:" list)) + (t + (frob "An improper list:" list)))))) + +(defun inspect-list-aux (list) + (loop for i from 0 for rest on list while (consp rest) append + (if (listp (cdr rest)) + (label-value-line i (car rest)) + (label-value-line* (i (car rest)) (:tail (cdr rest)))))) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Return NIL if LIST is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +;;;;; Hashtables + +(defun hash-table-to-alist (ht) + (let ((result '())) + (maphash (lambda (key value) + (setq result (acons key value result))) + ht) + result)) + +(defmethod emacs-inspect ((ht hash-table)) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + (label-value-line "Weakness:" weakness))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" + ,(lambda () (clrhash ht))) (:newline) + "Contents: " (:newline))) + (let ((content (hash-table-to-alist ht))) + (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) + (setf content (sort content 'string< :key #'first))) + ((every (lambda (x) (typep (first x) 'real)) content) + (setf content (sort content '< :key #'first)))) + (loop for (key . value) in content appending + `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +;;;;; Arrays + +(defmethod emacs-inspect ((array array)) + (lcons* + (iline "Dimensions" (array-dimensions array)) + (iline "Element type" (array-element-type array)) + (iline "Total size" (array-total-size array)) + (iline "Adjustable" (adjustable-array-p array)) + (iline "Fill pointer" (if (array-has-fill-pointer-p array) + (fill-pointer array))) + "Contents:" '(:newline) + (labels ((k (i max) + (cond ((= i max) '()) + (t (lcons (iline i (row-major-aref array i)) + (k (1+ i) max)))))) + (k 0 (array-total-size array))))) + +;;;;; Chars + +(defmethod emacs-inspect ((char character)) + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char)))))) + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslimefun list-threads () + "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread. +Example: + ((:id :name :status :priority) + (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) + (5 \"reader-thread\" \"Active\" 0) + (4 \"control-thread\" \"Semaphore timed wait\" 0) + (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) + (1 \"listener\" \"Active\" 0) + (0 \"Initial\" \"Sleep\" 0))" + (setq *thread-list* (all-threads)) + (when (and *emacs-connection* + (use-threads-p) + (equalp (thread-name (current-thread)) "worker")) + (setf *thread-list* (delete (current-thread) *thread-list*))) + (let* ((plist (thread-attributes (car *thread-list*))) + (labels (loop for (key) on plist by #'cddr + collect key))) + `((:id :name :status ,@labels) + ,@(loop for thread in *thread-list* + for name = (thread-name thread) + for attributes = (thread-attributes thread) + collect (list* (thread-id thread) + (string name) + (thread-status thread) + (loop for label in labels + collect (getf attributes label))))))) + +(defslimefun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslimefun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (queue-thread-interrupt + (nth-thread index) + (lambda () + (with-connection (connection) + (simple-break)))))) + +(defslimefun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslimefun start-swank-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a swank server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslimefun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'swank-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'swank-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *slime-features* should be connection-local + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*slime-features*' in a format suitable to send it to Emacs." + *slime-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslimefun update-indentation-information () + (send-to-indentation-cache `(:update-indentation-information)) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) + +;; Send REQUEST to the cache. If we are single threaded perform the +;; request right away, otherwise delegate the request to the +;; indentation-cache-thread. +(defun send-to-indentation-cache (request) + (let ((c *emacs-connection*)) + (etypecase c + (singlethreaded-connection + (handle-indentation-cache-request c request)) + (multithreaded-connection + (without-slime-interrupts + (send (mconn.indentation-cache-thread c) request)))))) + +(defun indentation-cache-loop (connection) + (with-connection (connection) + (loop + (restart-case + (handle-indentation-cache-request connection (receive)) + (abort () + :report "Return to the indentation cache request handling loop."))))) + +(defun handle-indentation-cache-request (connection request) + (dcase request + ((:sync-indentation package) + (let ((fullp (need-full-indentation-update-p connection))) + (perform-indentation-update connection fullp package))) + ((:update-indentation-information) + (perform-indentation-update connection t nil)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection.indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force package) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection.indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force package))) + (setf (connection.indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (setf (connection.indentation-cache connection) cache) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache force package) + "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to PACKAGE." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (let ((pkgs (mapcar #'package-name + (symbol-packages symbol))) + (name (string-downcase symbol))) + (push (list name indent pkgs) alist))))))) + (cond (force + (do-all-symbols (symbol) + (consider symbol))) + ((package-name package) ; don't try to iterate over a + ; deleted package. + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (consider symbol))))) + alist))) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun symbol-packages (symbol) + "Return the packages where SYMBOL can be found." + (let ((string (string symbol))) + (loop for p in (list-all-packages) + when (eq symbol (find-symbol string p)) + collect p))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. +#-clasp +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (swank::with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (swank::send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (make-output-stream (make-output-function-for-target connection target))) + + +;;;; Testing + +(defslimefun io-speed-test (&optional (n 1000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (finish-output s))) + (finish-output s) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) + nil)) + +(defslimefun flow-control-test (n delay) + (let ((stream (make-output-stream + (let ((conn *emacs-connection*)) + (lambda (string) + (declare (ignore string)) + (with-connection (conn) + (send-to-emacs `(:test-delay ,delay)))))))) + (dotimes (i n) + (print i stream) + (force-output stream) + (background-message "flow-control-test: ~d" i)))) + + +(defun before-init (version load-path) + (pushnew :swank *features*) + (setq *swank-wire-protocol-version* version) + (setq *load-path* load-path)) + +(defun init () + (run-hook *after-init-hook*)) + +;; Local Variables: +;; coding: latin-1-unix +;; indent-tabs-mode: nil +;; outline-regexp: ";;;;;*" +;; End: + +;;; swank.lisp ends here diff --git a/elpa/slime-20200319.1939/swank/abcl.lisp b/elpa/slime-20200319.1939/swank/abcl.lisp new file mode 100644 index 00000000..fec2032f --- /dev/null +++ b/elpa/slime-20200319.1939/swank/abcl.lisp @@ -0,0 +1,1532 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. +;;; +;;; Adapted from swank-acl.lisp, Andras Simon, 2004 +;;; New work by Alan Ruttenberg, 2016-7 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/abcl + (:use cl swank/backend) + (:import-from :java + #:jcall #:jstatic + #:jmethod + #:jfield + #:jconstructor + #:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array + #:jclass #:jnew #:java-object + ;; be conservative and add any import java functions only for later lisps + #+#.(swank/backend:with-symbol 'jfield-name 'java) #:jfield-name + #+#.(swank/backend:with-symbol 'jinstance-of-p 'java) #:jinstance-of-p + #+#.(swank/backend:with-symbol 'jclass-superclass 'java) #:jclass-superclass + #+#.(swank/backend:with-symbol 'jclass-interfaces 'java) #:jclass-interfaces + #+#.(swank/backend:with-symbol 'java-exception 'java) #:java-exception + #+#.(swank/backend:with-symbol 'jobject-class 'java) #:jobject-class + #+#.(swank/backend:with-symbol 'jclass-name 'java) #:jclass-name + #+#.(swank/backend:with-symbol 'java-object-p 'java) #:java-object-p)) + +(in-package swank/abcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint) + (require :gray-streams) + (require :abcl-contrib) + + ;;; Probe and load ABCL-INTROSPECT pushing to *FEATURES* on success + ;;; allowing us to conditionalize usage via `#+abcl-introspect` forms. + (when (ignore-errors (and + (fboundp '(setf sys::function-plist)) + (progn + (require :abcl-introspect) + (find "ABCL-INTROSPECT" *modules* :test + 'equal)))) + (pushnew :abcl-introspect *features*))) + +(defimplementation gray-package-name () + "GRAY-STREAMS") + +;; FIXME: switch to shared Gray stream implementation when the +;; architecture for booting streams allows us to replace the Java-side +;; implementation of a Slime{Input,Output}Stream.java classes are +;; subsumed . +(progn + (defimplementation make-output-stream (write-string) + (ext:make-slime-output-stream write-string)) + + (defimplementation make-input-stream (read-string) + (ext:make-slime-input-stream read-string + (make-synonym-stream '*standard-output*)))) + +;;; Have CL:INSPECT use SLIME +;;; +;;; Since Swank may also be run in a server not running under Emacs +;;; and potentially with other REPLs, we export a functional toggle +;;; for the user to call after loading these definitions. +(defun enable-cl-inspect-in-emacs () + (swank::wrap 'cl:inspect :use-slime :replace 'swank::inspect-in-emacs)) + +;; ??? repair bare print object so inspector titles show java class +(defun %print-unreadable-object-java-too (object stream type identity body) + (setf stream (sys::out-synonym-of stream)) + (when *print-readably* + (error 'print-not-readable :object object)) + (format stream "#<") + (when type + (if (java-object-p object) + ;; Special handling for java objects + (if (jinstance-of-p object "java.lang.Class") + (progn + (write-string "jclass " stream) + (format stream "~a" (jclass-name object))) + (format stream "~a" (jclass-name (jobject-class object)))) + ;; usual handling + (format stream "~S" (type-of object))) + (format stream " ")) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (format stream " ")) + (format stream "{~X}" (sys::identity-hash-code object))) + (format stream ">") + nil) + +(wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) + + +;;;; MOP + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +(defun slot-definition-documentation (slot) + (declare (ignore slot)) + #+abcl-introspect + (documentation slot 't)) + +(defun slot-definition-type (slot) + (declare (ignore slot)) + t) + +(defun class-prototype (class) + (declare (ignore class)) + nil) + +(defun generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun specializer-direct-methods (spec) + (mop:class-direct-methods spec)) + +(defun slot-definition-name (slot) + (mop:slot-definition-name slot)) + +(defun class-slots (class) + (mop:class-slots class)) + +(defun method-generic-function (method) + (mop:method-generic-function method)) + +(defun method-function (method) + (mop:method-function method)) + +(defun slot-boundp-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-value object (slot-definition-name slotdef))) + +(defun (setf slot-value-using-class) (new class object slotdef ) + (declare (ignore class)) + (mop::%set-slot-value object (slot-definition-name slotdef) new)) + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + #+#.(swank/backend:with-symbol + 'compute-applicable-methods-using-classes 'mop) + mop:compute-applicable-methods-using-classes + ;; standard-class readers + mop:class-default-initargs + mop:class-direct-default-initargs + mop:class-direct-slots + mop:class-direct-subclasses + mop:class-direct-superclasses + mop:eql-specializer + mop:class-finalized-p + mop:finalize-inheritance + cl:class-name + mop:class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop:generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop:generic-function-lambda-list + mop:generic-function-methods + mop:generic-function-method-class + mop:generic-function-method-combination + mop:generic-function-name + ;; method readers + method-generic-function + method-function + mop:method-lambda-list + mop:method-specializers + mop:method-qualifiers + ;; slot readers + mop:slot-definition-allocation + slot-definition-documentation ;;dummy + mop:slot-definition-initargs + mop:slot-definition-initform + mop:slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop:slot-definition-readers + mop:slot-definition-writers + slot-boundp-using-class + slot-value-using-class + set-slot-value-using-class + #+#.(swank/backend:with-symbol + 'slot-makunbound-using-class 'mop) + mop:slot-makunbound-using-class)) + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ext:make-server-socket port)) + +(defimplementation local-port (socket) + (jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket)) + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.reflect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + +;;;; External formats + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") + ((:iso-8859-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + (:euc-jp "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + (:us-ascii "us-ascii") + ((:us-ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;;; Unix signals + +(defimplementation getpid () + (if (fboundp 'ext::get-pid) + (ext::get-pid) ;;; Introduced with abcl-1.5.0 + (handler-case + (let* ((runtime + (java:jstatic "getRuntime" "java.lang.Runtime")) + (command + (java:jnew-array-from-array + "java.lang.String" #("sh" "-c" "echo $PPID"))) + (runtime-exec-jmethod + ;; Complicated because java.lang.Runtime.exec() is + ;; overloaded on a non-primitive type (array of + ;; java.lang.String), so we have to use the actual + ;; parameter instance to get java.lang.Class + (java:jmethod "java.lang.Runtime" "exec" + (java:jcall + (java:jmethod "java.lang.Object" "getClass") + command))) + (process + (java:jcall runtime-exec-jmethod runtime command)) + (output + (java:jcall (java:jmethod "java.lang.Process" "getInputStream") + process))) + (java:jcall (java:jmethod "java.lang.Process" "waitFor") + process) + (loop :with b :do + (setq b + (java:jcall (java:jmethod "java.io.InputStream" "read") + output)) + :until (member b '(-1 #x0a)) ; Either EOF or LF + :collecting (code-char b) :into result + :finally (return + (parse-integer (coerce result 'string))))) + (t () 0)))) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) + (sys::arglist fun) + (when (and (not present) + (fboundp fun) + (typep (symbol-function fun) + 'standard-generic-function)) + (setq arglist + (mop::generic-function-lambda-list (symbol-function fun)) + present + t)) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (if (fboundp 'sys::any-function-name) + ;; abcl-1.5.0 + (sys::any-function-name function) + ;; pre abcl-1.5.0 + (nth-value 2 (function-lambda-expression function)))) + +(defimplementation macroexpand-all (form &optional env) + (ext:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,(macroexpand-all form env))))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + ((:variable :macro) + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;;; Debugger + +;; Copied from swank-sbcl.lisp. +#+abcl-introspect +(defvar sys::*caught-frames*) +;; +;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, +;; so we have to make sure that the latter gets run when it was +;; established locally by a user (i.e. changed meanwhile.) +(defun make-invoke-debugger-hook (hook) + (lambda (condition old-hook) + (prog1 (let (#+abcl-introspect + (sys::*caught-frames* nil)) + ;; the next might be the right thing for earlier lisps but I don't know + ;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on abcl-1.4 and earlier + (let (#+abcl-introspect + (sys::*saved-backtrace* + (if (fboundp 'sys::new-backtrace) + (sys::new-backtrace condition) + (sys::backtrace)))) + (if *debugger-hook* + (funcall *debugger-hook* condition old-hook) + (funcall hook condition old-hook))))))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank)) + (*sldb-topframe* + (or + (second (member magic-token + #+abcl-introspect sys::*saved-backtrace* + #-abcl-introspect (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))) + (car sys::*saved-backtrace*))) + #+#.(swank/backend:with-symbol *debug-condition* 'ext) + (ext::*debug-condition* swank::*swank-debugger-condition*)) + (funcall debugger-loop-fn))) + +(defun backtrace (start end) + "A backtrace without initial SWANK frames." + (let ((backtrace + #+abcl-introspect sys::*saved-backtrace* + #-abcl-introspect (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) + +(defun nth-frame (index) + (nth index (backtrace 0 nil))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (backtrace start end))) + +;; Don't count on JSS being loaded, but if it is then there's some more stuff we can do ++#+#.(swank/backend:with-symbol 'invoke-restargs 'jss) +(defun jss-p () + (and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS"))) + ++#+#.(swank/backend:with-symbol 'invoke-restargs 'jss) +(defun matches-jss-call (form) + (flet ((gensymp (s) (and (symbolp s) (null (symbol-package s)))) + (invokep (s) (and (symbolp s) (eq s (jss-p))))) + (let ((method + (swank/match::select-match + form + (((LAMBDA ((#'gensymp a) &REST (#'gensymp b)) + ((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) . args)) . args) '=> c) + (other nil)))) + method))) + +#-abcl-introspect +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + +;; Use princ cs write-string for lisp frames as it respects (print-object (function t)) +;; Rewrite jss expansions to their unexpanded state +;; Show java exception frames up to where a java exception happened with a "!" +;; Check if a java class corresponds to a lisp function and tell us if to +(defvar *debugger-package* (find-package 'cl-user)) + +#+abcl-introspect +(defimplementation print-frame (frame stream) + ;; make clear which functions aren't Common Lisp. Otherwise uses + ;; default package, which is invisible + (let ((*package* (or *debugger-package* *package*))) + (if (typep frame 'sys::lisp-stack-frame) + (if (not (jss-p)) + (princ (system:frame-to-list frame) stream) + ;; rewrite jss forms as they would be written + (let ((form (system:frame-to-list frame))) + (if (eq (car form) (jss-p)) + (format stream "(#~s ~{~s~^~})" (second form) (list* (third form) (fourth form))) + (loop initially (write-char #\( stream) + for (el . rest) on form + for method = (swank/abcl::matches-jss-call el) + do + (cond (method + (format stream "(#~s ~{~s~^~})" method (cdr el))) + (t + (prin1 el stream))) + (unless (null rest) (write-char #\space stream)) + finally (write-char #\) stream))))) + (let ((classname (getf (sys:frame-to-list frame) :class))) + (if (and (fboundp 'sys::javaframe) + (member (sys::javaframe frame) sys::*caught-frames* :test 'equal)) + (write-string "! " stream)) + (write-string (sys:frame-to-string frame) stream) + (if (and classname (sys::java-class-lisp-function classname)) + (format stream " = ~a" (sys::java-class-lisp-function classname))))))) + +;;; Machinery for DEFIMPLEMENTATION +;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --ME 20150403 +(defun nth-frame-list (index) + (jcall "toLispList" (nth-frame index))) + +(defun match-lambda (operator values) + (jvm::match-lambda-list + (multiple-value-list + (jvm::parse-lambda-list (ext:arglist operator))) + values)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME + (when (typep frame 'sys::lisp-stack-frame) + (loop + :for id :upfrom 0 + :with frame = (nth-frame-list index) + :with operator = (first frame) + :with values = (rest frame) + :with arglist = (if (and operator (consp values) (not (null values))) + (handler-case (match-lambda operator values) + (jvm::lambda-list-mismatch (e) (declare(ignore e)) + :lambda-list-mismatch)) + :not-available) + :for value :in values + :collecting (list + :name (if (not (keywordp arglist)) + (first (nth id arglist)) + (format nil "arg~A" id)) + :id id + :value value))))) + +(defimplementation frame-var-value (index id) + (elt (rest (jcall "toLispList" (nth-frame index))) id)) + +#+abcl-introspect +(defimplementation disassemble-frame (index) + (sys::disassemble (frame-function (nth-frame index)))) + +(defun frame-function (frame) + (let ((list (sys::frame-to-list frame))) + (cond + ((keywordp (car list)) + (find (getf list :method) + (jcall "getDeclaredMethods" (jclass (getf list :class))) + :key (lambda(e)(jcall "getName" e)) :test 'equal)) + (t (car list) )))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (or (source-location (nth-frame index)) + `(:error ,(format nil "No source for frame: ~a" frame))))) + + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defvar *abcl-signaled-conditions*) + +(defun handle-compiler-warning (condition) + (let ((loc (when (and jvm::*compile-file-pathname* + system::*source-position*) + (cons jvm::*compile-file-pathname* system::*source-position*)))) + ;; filter condition signaled more than once. + (unless (member condition *abcl-signaled-conditions*) + (push condition *abcl-signaled-conditions*) + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (format nil "~A" condition) + :location (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (make-location + (list :file (namestring *compile-filename*)) + (list :position 1)))))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (fn warn fail) + (compile-file input-file :output-file output-file) + (values fn warn + (and fn load-p + (not (load fn))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) + (sys::*source-position* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; source location and users of it + +(defgeneric source-location (object)) + +;; try to find some kind of source for internals +#+abcl-introspect +(defun implementation-source-location (arg) + (let ((function (cond ((functionp arg) + arg) + ((and (symbolp arg) (fboundp arg)) + (or (symbol-function arg) (macro-function arg)))))) + (when (typep function 'generic-function) + (setf function (mop::funcallable-instance-function function))) + ;; functions are execute methods of class + (when (or (functionp function) (special-operator-p arg)) + (let ((fclass (jcall "getClass" function))) + (let ((classname (jcall "getName" fclass))) + (destructuring-bind (class local) + (if (find #\$ classname) + (split-string classname "\\$") + (list classname (jcall "replaceFirst" classname "([^.]*\\.)*" ""))) + (unless (member local '("MacroObject" "CompiledClosure" "Closure") :test 'equal) + ;; look for java source + (let* ((partial-path (substitute #\/ #\. class)) + (java-path (concatenate 'string partial-path ".java")) + (found-in-source-path (find-file-in-path java-path *source-path*))) + ;; snippet for finding the internal class within the file + (if found-in-source-path + `((:primitive ,local) + (:location ,found-in-source-path + (:line 0) + (:snippet ,(format nil "class ~a" local)))) + ;; if not, look for the class file, and hope that + ;; emacs is configured to disassemble class entries + ;; in jars. + + ;; Alan uses jdc.el + ;; + ;; with jad + ;; Also (setq sys::*disassembler* "jad -a -p") + (let ((class-in-source-path + (find-file-in-path (concatenate 'string partial-path ".class") *source-path*))) + ;; no snippet, since internal class is in its own file + (when class-in-source-path + `(:primitive (:location ,class-in-source-path (:line 0) nil))))))))))))) + +#+abcl-introspect +(defun get-declared-field (class fieldname) + (find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal)) + +#+abcl-introspect +(defun symbol-defined-in-java (symbol) + (loop with internal-name1 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "") "-" "_") + with internal-name2 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "_") "-" "_") + for class in + (load-time-value (mapcar + 'jclass + '("org.armedbear.lisp.Package" + "org.armedbear.lisp.Symbol" + "org.armedbear.lisp.Debug" + "org.armedbear.lisp.Extensions" + "org.armedbear.lisp.JavaObject" + "org.armedbear.lisp.Lisp" + "org.armedbear.lisp.Pathname" + "org.armedbear.lisp.Site"))) + thereis + (or (get-declared-field class internal-name1) + (get-declared-field class internal-name2)))) + +#+abcl-introspect +(defun maybe-implementation-variable (s) + (let ((field (symbol-defined-in-java s))) + (and field + (let ((class (jcall "getName" (jcall "getDeclaringClass" field)))) + (let* ((partial-path (substitute #\/ #\. class)) + (java-path (concatenate 'string partial-path ".java")) + (found-in-source-path (find-file-in-path java-path *source-path*))) + (when found-in-source-path + `(symbol (:location ,found-in-source-path (:line 0) + (:snippet ,(format nil "~s" (string s))))))))))) + +#+abcl-introspect +(defun if-we-have-to-choose-one-choose-the-function (sources) + (or (loop for spec in sources + for (dspec) = spec + when (and (consp dspec) (eq (car dspec) :function)) + when (and (consp dspec) (member (car dspec) '(:swank-implementation :function))) + do (return-from if-we-have-to-choose-one-choose-the-function spec)) + (car sources))) + +(defmethod source-location ((symbol symbol)) + (or #+abcl-introspect + (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source)))) + (and maybe (second (slime-location-from-source-annotation symbol maybe)))) + ;; This below should be obsolete - it uses the old sys:%source + ;; leave it here for now just in case + (and (pathnamep (ext:source-pathname symbol)) + (let ((pos (ext:source-file-position symbol)) + (path (namestring (ext:source-pathname symbol)))) + ; boot.lisp gets recorded wrong + (when (equal path "boot.lisp") + (setq path (second (find-file-in-path "org/armedbear/lisp/boot.lisp" *source-path*)))) + (cond ((ext:pathname-jar-p path) + `(:location + ;; strip off "jar:file:" = 9 characters + (:zip ,@(split-string (subseq path (length "jar:file:")) "!/")) + ;; pos never seems right. Use function name. + (:function-name ,(string symbol)) + (:align t))) + ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") + ;; conspire with swank-compile-string to keep the buffer + ;; name in a pathname whose device is "emacs-buffer". + `(:location + (:buffer ,(pathname-name (ext:source-pathname symbol))) + (:function-name ,(string symbol)) + (:align t))) + (t + `(:location + (:file ,path) + ,(if pos + (list :position (1+ pos)) + (list :function-name (string symbol))) + (:align t)))))) + #+abcl-introspect + (second (implementation-source-location symbol)))) + +(defmethod source-location ((frame sys::java-stack-frame)) + (destructuring-bind (&key class method file line) (sys:frame-to-list frame) + (declare (ignore method)) + (let ((file (or (find-file-in-path file *source-path*) + (let ((f (format nil "~{~a/~}~a" + (butlast (split-string class "\\.")) + file))) + (find-file-in-path f *source-path*))))) + (and file + `(:location ,file (:line ,line) ()))))) + +(defmethod source-location ((frame sys::lisp-stack-frame)) + (destructuring-bind (operator &rest args) (sys:frame-to-list frame) + (declare (ignore args)) + (etypecase operator + (function (source-location operator)) + (list nil) + (symbol (source-location operator))))) + +(defmethod source-location ((fun function)) + (if #+abcl-introspect + (sys::local-function-p fun) + #-abcl-introspect + nil + (source-location (sys::local-function-owner fun)) + (let ((name (function-name fun))) + (and name (source-location name))))) + +(defmethod source-location ((method method)) + #+abcl-introspect + (let ((found + (find `(:method ,@(sys::method-spec-list method)) + (get (function-name method) 'sys::source) + :key 'car :test 'equalp))) + (and found (second (slime-location-from-source-annotation (function-name method) found)))) + #-abcl-introspect + (let ((name (function-name fun))) + (and name (source-location name)))) + +(defun system-property (name) + (jstatic "getProperty" "java.lang.System" name)) + +(defun pathname-parent (pathname) + (make-pathname :directory (butlast (pathname-directory pathname)))) + +(defun pathname-absolute-p (pathname) + (eq (car (pathname-directory pathname)) ':absolute)) + +(defun split-string (string regexp) + (coerce + (jcall (jmethod "java.lang.String" "split" "java.lang.String") + string regexp) + 'list)) + +(defun path-separator () + (jfield "java.io.File" "pathSeparator")) + +(defun search-path-property (prop-name) + (let ((string (system-property prop-name))) + (and string + (remove nil + (mapcar #'truename + (split-string string (path-separator))))))) + +(defun jdk-source-path () + (let* ((jre-home (truename (system-property "java.home"))) + (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) + (truename (probe-file src-zip))) + (and truename (list truename)))) + +(defun class-path () + (append (search-path-property "java.class.path") + (search-path-property "sun.boot.class.path"))) + +(defvar *source-path* + (remove nil + (append (search-path-property "user.dir") + (jdk-source-path) + ;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well + #+abcl-introspect + (list (sys::find-system-jar) + (sys::find-contrib-jar)))) + ;; you should tell slime where the abcl sources are. In .swank.lisp I have: + ;; (push (probe-file "/Users/alanr/repos/abcl/src/") *SOURCE-PATH*) +"List of directories to search for source files.") + +(defun zipfile-contains-p (zipfile-name entry-name) + (let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile" + "java.lang.String") + zipfile-name))) + (jcall + (jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") + zipfile entry-name))) + +;; Try to find FILENAME in PATH. If found, return a file spec as +;; needed by Emacs. We also look in zip files. +(defun find-file-in-path (filename path) + (labels ((try (dir) + (cond ((not (pathname-type dir)) + (let ((f (probe-file (merge-pathnames filename dir)))) + (and f `(:file ,(namestring f))))) + ((member (pathname-type dir) '("zip" "jar") :test 'equal) + (try-zip dir)) + (t (error "strange path element: ~s" path)))) + (try-zip (zip) + (let* ((zipfile-name (namestring (truename zip)))) + (and (zipfile-contains-p zipfile-name filename) + `(#+abcl-introspect + :zip + #-abcl-introspect + :dir + ,zipfile-name ,filename))))) + (cond ((pathname-absolute-p filename) (probe-file filename)) + (t + (loop for dir in path + if (try dir) return it))))) + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (or (if (and (consp type) (getf *definition-types* (car type))) + `(,(getf *definition-types* (car type)) ,(second type) ,@(third type) ,@(cdddr type)) + (getf *definition-types* type)) + type)) + +(defun stringify-method-specs (type) + "return a (:method ..) location for slime" + (let ((*print-case* :downcase)) + (flet ((p (a) (princ-to-string a))) + (destructuring-bind (name qualifiers specializers) (cdr type) + `(,(car type) ,(p name) ,(mapcar #'p specializers) ,@(mapcar #'p qualifiers)))))) + +;; for abcl source, check if it is still there, and if not, look in abcl jar instead +(defun maybe-redirect-to-jar (path) + (setq path (namestring path)) + (if (probe-file path) + path + (if (search "/org/armedbear/lisp" path :test 'string=) + (let ((jarpath (format nil "jar:file:~a!~a" (namestring (sys::find-system-jar)) + (subseq path (search "/org/armedbear/lisp" path))))) + (if (probe-file jarpath) + jarpath + path)) + path))) + +#-abcl-introspect +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#+abcl-introspect +(defimplementation find-definitions (symbol) + (when (stringp symbol) + ;; allow a string to be passed. If it is package prefixed, remove the prefix + (setq symbol (intern (string-upcase + (subseq symbol (1+ (or (position #\: symbol :from-end t) -1)))) + 'keyword))) + (let ((sources nil) + (implementation-variables nil) + (implementation-functions nil)) + (loop for package in (list-all-packages) + for sym = (find-symbol (string symbol) package) + when (and sym (equal (symbol-package sym) package)) + do + (when (sys::autoloadp symbol) + (sys::resolve symbol)) + (let ((source (or (get sym 'ext::source) (get sym 'sys::source))) + (i-var (maybe-implementation-variable sym)) + (i-fun (implementation-source-location sym))) + (when source + (setq sources (append sources (or (get sym 'ext::source) (get sym 'sys::source))))) + (when i-var + (push i-var implementation-variables)) + (when i-fun + (push i-fun implementation-functions)))) + (setq sources (remove-duplicates sources :test 'equalp)) + (append (remove-duplicates implementation-functions :test 'equalp) + (mapcar (lambda(s) (slime-location-from-source-annotation symbol s)) sources) + (remove-duplicates implementation-variables :test 'equalp)))) + +(defun slime-location-from-source-annotation (sym it) + (destructuring-bind (what path pos) it + + (let* ((isfunction + ;; all of these are (defxxx forms, which is what :function locations look for in slime + (and (consp what) (member (car what) + '(:function :generic-function :macro :class :compiler-macro + :type :constant :variable :package :structure :condition)))) + (ismethod (and (consp what) (eq (car what) :method))) + ( (cond (isfunction (list :function-name (princ-to-string (second what)))) + (ismethod (stringify-method-specs what)) + (t (list :position (1+ (or pos 0)))))) + + (path2 (if (eq path :top-level) + ;; this is bogus - figure out some way to guess which is the repl associated with :toplevel + ;; or get rid of this + "emacs-buffer:*slime-repl*" + (maybe-redirect-to-jar path)))) + (when (atom what) + (setq what (list what sym))) + (list (definition-specifier what) + (if (ext:pathname-jar-p path2) + `(:location + (:zip ,@(split-string (subseq path2 (length "jar:file:")) "!/")) + ;; pos never seems right. Use function name. + , + (:align t)) + ;; conspire with swank-compile-string to keep the + ;; buffer name in a pathname whose device is + ;; "emacs-buffer". + (if (eql 0 (search "emacs-buffer:" path2)) + `(:location + (:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:")))) + , + (:align t)) + `(:location + (:file ,path2) + , + (:align t)))))))) + +#+abcl-introspect +(defimplementation list-callers (thing) + (loop for caller in (sys::callers thing) + when (typep caller 'method) + append (let ((name (mop:generic-function-name + (mop:method-generic-function caller)))) + (mapcar (lambda(s) (slime-location-from-source-annotation thing s)) + (remove `(:method ,@(sys::method-spec-list caller)) + (get + (if (consp name) (second name) name) + 'sys::source) + :key 'car :test-not 'equalp))) + when (symbolp caller) + append (mapcar (lambda(s) (slime-location-from-source-annotation caller s)) + (get caller 'sys::source)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Inspecting + +;;; BEGIN FIXME move into generalized Swank infrastructure, or add to contrib mechanism +;; this is only for hyperspec request in an inspector window +;; TODO have slime-hyperspec-lookup respect this variable too +(defvar *slime-inspector-hyperspec-in-browser* t + "If t then invoking hyperspec within the inspector browses the hyperspec in an emacs buffer, otherwise respecting the value of browse-url-browser-function") + +(defun hyperspec-do (name) + (let ((form `(let ((browse-url-browser-function + ,(if *slime-inspector-hyperspec-in-browser* + '(lambda(a v) (eww a)) + 'browse-url-browser-function))) + (slime-hyperdoc-lookup ,name)))) + (swank::eval-in-emacs form t))) +;;; END FIXME move into generalized Swank infrastructure, or add to contrib mechanism + +;;; Although by convention toString() is supposed to be a +;;; non-computationally expensive operation this isn't always the +;;; case, so make its computation a user interaction. +(defparameter *to-string-hashtable* (make-hash-table :weakness :key)) + +(defmethod emacs-inspect ((o t)) + (let* ((type (type-of o)) + (class (ignore-errors (find-class type))) + (jclass (and (typep class 'sys::built-in-class) + (jcall "getClass" o)))) + (let ((parts (sys:inspected-parts o))) + `((:label "Type: ") (:value ,(or class type)) (:Newline) + ,@(if jclass + `((:label "Java type: ") (:value ,jclass) (:newline))) + ,@(if parts + (loop :for (label . value) :in parts + :appending (list + (list :label (string-capitalize label)) + ": " + (list :value value (princ-to-string value)) '(:newline))) + (list '(:label "No inspectable parts, dumping output of CL:DESCRIBE:") + '(:newline) + (with-output-to-string (desc) (describe o desc)))))))) + +(defmethod emacs-inspect ((string string)) + (swank::lcons* + '(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline) + #+abcl-introspect ;; ??? This doesn't appear depend on ABCL-INTROSPECT. Why disable? + `(:action "[Edit in emacs buffer]" ,(lambda() (swank::ed-in-emacs `(:string ,string)))) + '(:newline) + (if (ignore-errors (jclass string)) + `(:line "Names java class" ,(jclass string)) + "") + #+abcl-introspect + (if (and (jss-p) + (stringp (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t))) + `(:multiple + (:label "Abbreviates java class: ") + ,(let ((it (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t))) + `(:value ,(jclass it))) + (:newline)) + "") + (if (ignore-errors (find-package (string-upcase string))) + `(:line "Names package" ,(find-package (string-upcase string))) + "") + (let ((symbols (loop for p in (list-all-packages) + for found = (find-symbol (string-upcase string)) + when (and found (eq (symbol-package found) p) + (or (fboundp found) + (boundp found) + (symbol-plist found) + (ignore-errors (find-class found)))) + collect found))) + (if symbols + `(:multiple (:label "Names symbols: ") + ,@(loop for s in symbols + collect + (Let ((*package* (find-package :keyword))) + `(:value ,s ,(prin1-to-string s))) collect " ") (:newline)) + "")) + (call-next-method))) + +#+#.(swank/backend:with-symbol 'java-exception 'java) +(defmethod emacs-inspect ((o java:java-exception)) + (append (call-next-method) + (list '(:newline) '(:label "Stack trace") + '(:newline) + (let ((w (jnew "java.io.StringWriter"))) + (jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w)) + (jcall "toString" w))))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + "Initialization:" (:newline) + (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) + (:label " Form: ") ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#") (:newline) + (:label " Function: ") + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defmethod emacs-inspect ((f function)) + `(,@(when (function-name f) + `((:label "Name: ") + ,(princ-to-string (sys::any-function-name f)) (:newline))) + ,@(multiple-value-bind (args present) (sys::arglist f) + (when present + `((:label "Argument list: ") + ,(princ-to-string args) + (:newline)))) + #+abcl-introspect + ,@(when (documentation f t) + `("Documentation:" (:newline) + ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `((:label "Lambda expression:") + (:newline) ,(princ-to-string + (function-lambda-expression f)) (:newline))) + (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline) + #+abcl-introspect + ,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f) + `((:label "Closed over: ") + ,@(loop + for el in (sys::compiled-closure-context f) + collect `(:value ,el) + collect " ") + (:newline))) + #+abcl-introspect + ,@(when (sys::get-loaded-from f) + (list `(:label "Defined in: ") + `(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f))) + '(:newline))) + ;; I think this should work in older lisps too -- alanr + ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f)))) + (when (plusp (length fields)) + (list* '(:label "Internal fields: ") '(:newline) + (loop for field across fields + do (jcall "setAccessible" field t) ;;; not a great idea esp. wrt. Java9 + append + (let ((value (jcall "get" field f))) + (list " " + `(:label ,(jcall "getName" field)) + ": " + `(:value ,value ,(princ-to-string value)) + '(:newline))))))) + #+abcl-introspect + ,@(when (and (function-name f) (symbolp (function-name f)) + (eq (symbol-package (function-name f)) (find-package :cl))) + (list '(:newline) (list :action "Lookup in hyperspec" + (lambda () (hyperspec-do (symbol-name (function-name f)))) + :refreshp nil) + '(:newline))))) + +(defmethod emacs-inspect ((o java:java-object)) + (if (jinstance-of-p o (jclass "java.lang.Class")) + (emacs-inspect-java-class o) + (emacs-inspect-java-object o))) + +(defvar *slime-tostring-on-demand* nil + "Set to t if you don't want to automatically show toString() for java objects and instead have inspector action to compute") + +(defun static-field? (field) + ;; (plusp (logand #"reflect.Modifier.STATIC" (jcall "getModifiers" field))) + ;; ugly replace with answer to avoid using jss + (plusp (logand 8 (jcall "getModifiers" field)))) + +(defun inspector-java-object-fields (object) + (loop + for super = (java::jobject-class object) then (jclass-superclass super) + while super + ;;; NOTE: In the next line, if I write #'(lambda.... then I + ;;; get an error compiling "Attempt to throw to the + ;;; nonexistent tag DUPLICATABLE-CODE-P.". WTF + for fields + = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x) (jcall "getName" x))) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length fields)) fromline) + append fromline + append + (loop for this across fields + for value = (jcall "get" (progn (jcall "setAccessible" this t) this) object) + for line = `(" " (:label ,(jcall "getName" this)) ": " (:value ,value) (:newline)) + if (static-field? this) + append line into statics + else append line into members + finally (return (append + (if members `((:label "Member fields: ") (:newline) ,@members)) + (if statics `((:label "Static fields: ") (:newline) ,@statics))))))) + +(defun emacs-inspect-java-object (object) + (let ((to-string (lambda () + (handler-case + (setf (gethash object *to-string-hashtable*) + (jcall "toString" object)) + (t (e) + (setf (gethash object *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e)))))) + (intended-class (cdr (assoc "intendedClass" (sys::inspected-parts object) + :test 'equal)))) + `((:label "Class: ") + (:value ,(jcall "getClass" object) ,(jcall "getName" (jcall "getClass" object) )) (:newline) + ,@(if (and intended-class (not (equal intended-class (jcall "getName" (jcall "getClass" object))))) + `((:label "Intended Class: ") + (:value ,(jclass intended-class) ,intended-class) (:newline))) + ,@(if (or (gethash object *to-string-hashtable*) (not *slime-tostring-on-demand*)) + (label-value-line "toString()" (funcall to-string)) + `((:action "[compute toString()]" ,to-string) (:newline))) + ,@(inspector-java-object-fields object)))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + (:label "Initialization:") (:newline) + (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) + (:label " Form: ") + ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#") (:newline) + " Function: " + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defun inspector-java-fields (class) + (loop + for super + = class then (jclass-superclass super) + while super + for fields + = (jcall "getDeclaredFields" super) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length fields)) fromline) + append fromline + append + (loop for this across fields + for pre = (subseq (jcall "toString" this) + 0 + (1+ (position #\. (jcall "toString" this) :from-end t))) + collect " " + collect (list :value this pre) + collect (list :value this (jcall "getName" this) ) + collect '(:newline)))) + +(defun inspector-java-methods (class) + (loop + for super + = class then (jclass-superclass super) + while super + for methods + = (jcall "getDeclaredMethods" super) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length methods)) fromline) + append fromline + append + (loop for this across methods + for desc = (jcall "toString" this) + for paren = (position #\( desc) + for dot = (position #\. (subseq desc 0 paren) :from-end t) + for pre = (subseq desc 0 dot) + for name = (subseq desc dot paren) + for after = (subseq desc paren) + collect " " + collect (list :value this pre) + collect (list :value this name) + collect (list :value this after) + collect '(:newline)))) + +(defun emacs-inspect-java-class (class) + (let ((has-superclasses (jclass-superclass class)) + (has-interfaces (plusp (length (jclass-interfaces class)))) + (fields (inspector-java-fields class)) + (path (jcall "replaceFirst" + (jcall "replaceFirst" + (jcall "toString" (jcall "getResource" + class + (concatenate 'string + "/" (substitute #\/ #\. (jcall "getName" class)) + ".class"))) + "jar:file:" "") "!.*" ""))) + `((:label ,(format nil "Java Class: ~a" (jcall "getName" class) )) + (:newline) + ,@(when path (list `(:label ,"Loaded from: ") + `(:value ,path) + " " + `(:action "[open in emacs buffer]" ,(lambda() (swank::ed-in-emacs `( ,path)))) '(:newline))) + ,@(if has-superclasses + (list* '(:label "Superclasses: ") (butlast (loop for super = (jclass-superclass class) then (jclass-superclass super) + while super collect (list :value super (jcall "getName" super)) collect ", ")))) + ,@(if has-interfaces + (list* '(:newline) '(:label "Implements Interfaces: ") + (butlast (loop for i across (jclass-interfaces class) collect (list :value i (jcall "getName" i)) collect ", ")))) + (:newline) (:label "Methods:") (:newline) + ,@(inspector-java-methods class) + ,@(if fields + (list* + '(:newline) '(:label "Fields:") '(:newline) + fields))))) + +(defmethod emacs-inspect ((object sys::structure-object)) + (let ((structure-def (get (type-of object) 'system::structure-definition ))) + `((:label "Type: ") (:value ,(type-of object)) (:newline) + (:label "Class: ") (:value ,(class-of object)) (:newline) + ,@(inspector-structure-slot-names-and-values object)))) + +(defun inspector-structure-slot-names-and-values (structure) + (let ((structure-def (get (type-of structure) 'system::structure-definition))) + `((:label "Slots: ") (:newline) + ,@(loop for slotdef in (sys::dd-slots structure-def) + for name = (sys::dsd-name slotdef) + for reader = (sys::dsd-reader slotdef) + for value = (eval `(,reader ,structure)) + append + `(" " (:label ,(string-downcase (string name))) ": " (:value ,value) (:newline)))))) + +(defmethod emacs-inspect ((object sys::structure-class)) + (let* ((name (jss::get-java-field object "name" t)) + (def (get name 'system::structure-definition))) + `((:label "Class: ") (:value ,object) (:newline) + (:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array* nil)) (prin1-to-string def))) (:newline) + ,@(parts-for-structure-def name) + ;; copy-paste from swank fancy inspector + ,@(when (swank-mop:specializer-direct-methods object) + `((:label "It is used as a direct specializer in the following methods:") + (:newline) + ,@(loop + for method in (specializer-direct-methods object) + for method-spec = (swank::method-for-inspect-value method) + collect " " + collect `(:value ,method ,(string-downcase (string (car method-spec)))) + collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec))) + append (let ((method method)) + `(" " (:action "[remove]" + ,(lambda () (remove-method (swank-mop::method-generic-function method) method))))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (swank::abbrev-doc (documentation method t)) and + collect '(:newline))))))) + +(defun parts-for-structure-def-slot (def) + `((:label ,(string-downcase (sys::dsd-name def))) " reader: " (:value ,(sys::dsd-reader def) ,(string-downcase (string (sys::dsdreader def)))) + ", index: " (:value ,(sys::dsd-index def)) + ,@(if (sys::dsd-initform def) + `(", initform: " (:value ,(sys::dsd-initform def)))) + ,@(if (sys::dsd-read-only def) + '(", Read only")))) + +(defun parts-for-structure-def (name) + (let ((structure-def (get name 'system::structure-definition ))) + (append + (loop for accessor in '(dd-name dd-conc-name dd-default-constructor dd-constructors dd-copier dd-include dd-type + dd-named dd-initial-offset dd-predicate dd-print-function dd-print-object + dd-inherited-accessors) + for key = (intern (subseq (string accessor) 3) 'keyword) + for fsym = (find-symbol (string accessor) 'system) + for value = (eval `(,fsym ,structure-def)) + append `((:label ,(string-capitalize (string key))) ": " (:value ,value) (:newline))) + (let* ((direct (sys::dd-direct-slots structure-def) ) + (all (sys::dd-slots structure-def)) + (inherited (set-difference all direct))) + `((:label "Direct slots: ") (:newline) + ,@(loop for slotdef in direct + append `(" " ,@(parts-for-structure-def-slot slotdef) + (:newline))) + ,@(if inherited + (append '((:label "Inherited slots: ") (:newline)) + (loop for slotdef in inherited + append `(" " (:label ,(string-downcase (string (sys::dsd-name slotdef)))) + (:value ,slotdef "slot definition") + (:newline)))))))))) + +;;;; Multithreading + +(defimplementation spawn (fn &key name) + (threads:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-plists* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'id) + (setf (getf (gethash thread *thread-plists*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plists*) 'id)))) + +(defimplementation thread-name (thread) + (threads:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (declare (ignore name)) + (threads:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (threads:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (threads:current-thread)) + +(defimplementation all-threads () + (copy-list (threads:mapcar-threads #'identity))) + +(defimplementation thread-alive-p (thread) + (member thread (all-threads))) + +(defimplementation interrupt-thread (thread fn) + (threads:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (threads:destroy-thread thread)) + +(defstruct mailbox + (queue '())) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'mailbox) + (setf (getf (gethash thread *thread-plists*) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (threads:synchronized-on mbox + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message))) + (threads:object-notify-all mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (threads:synchronized-on mbox + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (when (eq timeout t) (return (values nil t))) + (threads:object-wait mbox 0.3)))))) + +(defimplementation quit-lisp () + (ext:exit)) + +;; FIXME probably should be promoted to other lisps but I don't want to mess with them +(defvar *inspector-print-case* *print-case*) + +(defimplementation call-with-syntax-hooks (fn) + (let ((*print-case* *inspector-print-case*)) + (funcall fn))) + +;;; +#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) + +;; all the defimplentations aren't compiled. Compile them. Set their +;; function name to be the same as the implementation name so +;; meta-. works. + +#+abcl-introspect +(eval-when (:load-toplevel :execute) + (loop for s in swank-backend::*interface-functions* + for impl = (get s 'swank-backend::implementation) + do (when (and impl (not (compiled-function-p impl))) + (let ((name (gensym))) + (compile name impl) + (let ((compiled (symbol-function name))) + (system::%set-lambda-name compiled (second (sys::lambda-name impl))) + (setf (get s 'swank-backend::implementation) compiled)))))) + diff --git a/elpa/slime-20200319.1939/swank/allegro.lisp b/elpa/slime-20200319.1939/swank/allegro.lisp new file mode 100644 index 00000000..942764cd --- /dev/null +++ b/elpa/slime-20200319.1939/swank/allegro.lisp @@ -0,0 +1,1086 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/allegro + (:use cl swank/backend)) + +(in-package swank/allegro) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process) + #+(version>= 8 2) + (require 'lldb)) + +(defimplementation gray-package-name () + '#:excl) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; UTF8 + +(define-symbol-macro utf8-ef + (load-time-value + (excl:crlf-base-ef (excl:find-external-format :utf-8)) + t)) + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format utf8-ef)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defimplementation socket-fd (stream) + (excl::stream-input-handle stream)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +;;;; Unix signals + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + #+(version>= 8 0) + (excl::walk-form form) + #-(version>= 8 0) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (check-type f function) + (cross-reference::object-to-function-name f)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our + ;; break form somewhere. This does not work for setf, :before and + ;; :after methods, which need special syntax in the trace call, see + ;; ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((magic-symbol (intern (symbol-name :swank-debugger-hook) + (find-package :swank))) + (top-frame (excl::int-newest-frame (excl::current-thread)))) + (loop for frame = top-frame then (next-frame frame) + for i from 0 + while (and frame (< i 30)) + when (eq (debugger:frame-name frame) magic-symbol) + return (next-frame frame) + finally (return top-frame)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation disassemble-frame (index) + (let ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) + (disassemble (debugger:frame-function frame))))) + +(defimplementation frame-source-location (index) + (let* ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (declare (ignore x xx xxx)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) + (t ; frames for unbound functions etc end up here + (cadr (car (fspec-definition-locations + (car (debugger:frame-expression frame)))))))))) + +(defun function-source-location (fun) + (cadr (car (fspec-definition-locations + (xref::object-to-function-name fun))))) + +#+(version>= 8 2) +(defun pc-source-location (fun pc) + (let* ((debug-info (excl::function-source-debug-info fun))) + (cond ((not debug-info) + (function-source-location fun)) + (t + (let* ((code-loc (find-if (lambda (c) + (<= (- pc (sys::natural-width)) + (let ((x (excl::ldb-code-pc c))) + (or x -1)) + pc)) + debug-info))) + (cond ((not code-loc) + (ldb-code-to-src-loc (aref debug-info 0))) + (t + (ldb-code-to-src-loc code-loc)))))))) + +#+(version>= 8 2) +(defun ldb-code-to-src-loc (code) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (loop for i from (excl::ldb-code-index code) downto 0 + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start + return (if (listp start) + (first start) + start))) + (src-file (excl:source-file func))) + (cond (start + (buffer-or-file-location src-file start)) + (func + (let* ((debug-info (excl::function-source-debug-info func)) + (whole (aref debug-info 0)) + (paths (source-paths-of (excl::ldb-code-source whole) + (excl::ldb-code-source code))) + (path (if paths (longest-common-prefix paths) '())) + (start 0)) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) + `(:source-path (0 . ,path) ,start))) + (lambda (buffer bstart) + (make-location `(:buffer ,buffer) + `(:source-path (0 . ,path) + ,(+ bstart start))))))) + (t + nil)))) + +(defun longest-common-prefix (sequences) + (assert sequences) + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix sequences))) + +(defun source-paths-of (whole part) + (let ((result '())) + (labels ((walk (form path) + (cond ((eq form part) + (push (reverse path) result)) + ((consp form) + (loop for i from 0 while (consp form) do + (walk (pop form) (cons i path))))))) + (walk whole '()) + (reverse result)))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (typep name '(and symbol (not null) (not keyword))) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation frame-restartable-p (frame) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (funcall (read-from-string "swank::background-message") + "~a ~a" frame (princ-to-string c)) + nil))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun redefinition-p (condition) + (and (typep condition 'style-warning) + (every #'char-equal "redefin" (princ-to-string condition)))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(deftype redefinition () + `(satisfies redefinition-p)) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and #-(version>= 10 0) (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + ((and (typep condition 'excl::compiler-note) + (let ((format (slot-value condition 'excl::format-control))) + (and (search "Closure" format) + (search "will be stack allocated" format)))) + ;; Ignore "Closure will be stack allocated" notes. + ;; That occurs often but is usually uninteresting. + ) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (redefinition :redefinition) + (style-warning :style-warning) + (warning :warning) + (compiler-note :note) + (reader-error :read-error) + (error :error)) + :message (format nil "~A" condition) + :location (compiler-warning-location condition))))) + +(defun condition-pathname-and-position (condition) + (let* ((context #+(version>= 10 0) + (getf (slot-value condition 'excl::plist) + :source-context)) + (location-available (and context + (excl::source-context-start-char context)))) + (cond (location-available + (values (excl::source-context-pathname context) + (when-let (start-char (excl::source-context-start-char context)) + (let ((position (if (listp start-char) ; HACK + (first start-char) + start-char))) + (if (typep condition 'excl::compiler-free-reference-warning) + position + (1+ position)))))) + ((typep condition 'reader-error) + (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) + (file (pathname (stream-error-stream condition)))) + (when (integerp pos) + (values file pos)))) + (t + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (when loc + (destructuring-bind (file . pos) loc + (let ((start (if (consp pos) ; 8.2 and newer + #+(version>= 10 1) + (if (typep condition 'excl::compiler-inconsistent-name-usage-warning) + (second pos) + (first pos)) + #-(version>= 10 1) + (first pos) + pos))) + (values file start))))))))) + +(defun compiler-warning-location (condition) + (multiple-value-bind (pathname position) + (condition-pathname-and-position condition) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (if position + (list :offset 1 (1- position)) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + #+(version>= 10 1) + (list :offset 1 position) + #-(version>= 10 1) + (list :position (1+ position)))) + (t + (make-error-location "No error location available."))))) + +;; TODO: report it as a bug to Franz that the condition's plist +;; slot contains (:loc nil). +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . locs) in (car fargs) do + (dolist (loc locs) + (multiple-value-bind (pos file) (ecase (length loc) + (2 (values-list loc)) + (3 (destructuring-bind + (start end file) loc + (declare (ignore end)) + (values start file)))) + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + #+(version>= 9 0) + (list :offset 1 pos) + #-(version>= 9 0) + (list :position (1+ pos))))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + (compiler-note #'handle-compiler-warning) + (reader-error #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file) + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + (compile-file *compile-filename* + :output-file output-file + :load-after-compile load-p + :external-format external-format))) + (reader-error () (values nil nil t)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun write-tracking-preamble (stream file file-offset) + "Instrument the top of the temporary file to be compiled. + +The header tells allegro that any definitions compiled in the temp +file should be found in FILE exactly at FILE-OFFSET. To get Allegro +to do this, this factors in the length of the inserted header itself." + (with-standard-io-syntax + (let* ((*package* (find-package :keyword)) + (source-pathname-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*source-pathname* + (pathname ,(sys::frob-source-file file))))) + (source-pathname-string (write-to-string source-pathname-form)) + (position-form-length-bound 160) ; should be enough for everyone + (header-length (+ (length source-pathname-string) + position-form-length-bound)) + (position-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*partial-source-file-p* ,(- file-offset + header-length + 1 ; for the newline + )))) + (position-form-string (write-to-string position-form)) + (padding-string (make-string (- position-form-length-bound + (length position-form-string)) + :initial-element #\;))) + (write-string source-pathname-string stream) + (write-string position-form-string stream) + (write-string padding-string stream) + (write-char #\newline stream)))) + +(defun compile-from-temp-file (string buffer offset file) + (call-with-temp-file + (lambda (stream filename) + (when (and file offset (probe-file file)) + (write-tracking-preamble stream file offset)) + (write-string string stream) + (finish-output stream) + (multiple-value-bind (binary-filename warnings? failure?) + (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*redefinition-warnings* nil)) + (compile-file filename)) + (declare (ignore warnings?)) + (when binary-filename + (let ((excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + excl::*source-pathname* + (load binary-filename)) + (when (and buffer offset (or (not file) + (not (probe-file file)))) + (setf (gethash (pathname stream) *temp-file-map*) + (list buffer offset))) + (delete-file binary-filename)) + (not failure?))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (compile-from-temp-file string buffer position filename))) + (reader-error () nil))) + +;;;; Definition Finding + +(defun buffer-or-file (file file-fun buffer-fun) + (let* ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer start) probe + (funcall buffer-fun buffer start))) + (t (funcall file-fun (namestring (truename file))))))) + +(defun buffer-or-file-location (file offset) + (buffer-or-file file + (lambda (filename) + (make-location `(:file ,filename) + `(:position ,(1+ offset)))) + (lambda (buffer start) + (make-location `(:buffer ,buffer) + `(:offset ,start ,offset))))) + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :offset 1 start) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-fspec-location (fspec type file top-level) + (handler-case + (etypecase file + (pathname + (let ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer offset) probe + (make-location `(:buffer ,buffer) + `(:offset ,offset 0)))) + (t + (find-definition-in-file fspec type file top-level))))) + ((member :top-level) + (make-error-location "Defined at toplevel: ~A" + (fspec->string fspec)))) + (error (e) + (make-error-location "Error: ~A" e)))) + +(defun fspec->string (fspec) + (typecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))) + (t (princ-to-string fspec)))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (declare (ignore _internal _n)) + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (when (and (null defs) + (listp fspec) + (string= (car fspec) '#:method)) + ;; If methods are defined in a defgeneric form, the source location is + ;; recorded for the gf but not for the methods. Therefore fall back to + ;; the gf as the likely place of definition. + (setq defs (excl::find-source-file (second fspec)))) + (if (null defs) + (list + (list fspec + (make-error-location "Unknown source location for ~A" + (fspec->string fspec)))) + (loop for (fspec type file top-level) in defs collect + (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +(defimplementation find-source-location (obj) + (first (rest (first (fspec-definition-locations obj))))) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/\ +;; doc/runtime-analyzer.htm#data-collection-control-2 + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package :common-lisp)) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) + (symbol-function (read-from-string "swank:y-or-n-p-in-emacs"))) + (unwind-protect + (progn ,@body) + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(excl:without-redefinition-warnings +(defmethod emacs-inspect ((o t)) + (allegro-inspect o))) + +(defmethod emacs-inspect ((o function)) + (allegro-inspect o)) + +(defmethod emacs-inspect ((o standard-object)) + (allegro-inspect o)) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte :unsigned-long32) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value :func) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (princ-to-string (mp:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :times-resumed (mp:process-times-resumed thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate nil))) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) + +(defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread))) + (mp:open-gate (mailbox.gate mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (flet ((open-mailbox () + ;; this opens the mailbox and returns if has the message + ;; we are expecting. But first, check for interrupts. + (check-slime-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return-from receive-if (car tail))) + ;; ...if it doesn't, we close the gate (even if it + ;; was already closed) + (mp:close-gate (mailbox.gate mbox)))))) + (cond (timeout + ;; open the mailbox and return asap + (open-mailbox) + (return-from receive-if (values nil t))) + (t + ;; wait until gate open, then open mailbox. If there's + ;; no message there, repeat forever. + (loop + (mp:process-wait + "receive-if (waiting on gate)" + #'mp:gate-open-p (mailbox.gate mbox)) + (open-mailbox))))))) + +(let ((alist '()) + (lock (mp:make-process-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-process-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-process-lock (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (push (cons var form) + #+(version>= 9 0) + excl:*required-thread-bindings* + #-(version>= 9 0) + excl::required-thread-bindings)) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace ) +;; (trace ((method ? (+)))) +;; (trace ((labels ))) +;; (trace ((labels (method (+)) ))) +;; can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))) + allegro-spec)) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) diff --git a/elpa/slime-20200319.1939/swank/backend.lisp b/elpa/slime-20200319.1939/swank/backend.lisp new file mode 100644 index 00000000..e2bd26d3 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/backend.lisp @@ -0,0 +1,1581 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-.lisp provides methods. + +(in-package swank/backend) + + +;;;; Metacode + +(defparameter *debug-swank-backend* nil + "If this is true, backends should not catch errors but enter the +debugger where appropriate. Also, they should not perform backtrace +magic but really show every frame including SWANK related ones.") + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defvar *log-output* nil) ; should be nil for image dumpers + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implemented" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank/backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) + ;; For implicit BLOCK. FLET because of interplay w/ decls. + (flet ((,name ,args ,@body)) #',name)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (let ((*print-pretty* t)) + (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" + (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(definterface gray-package-name () + "Return a package-name that contains the Gray stream symbols. +This will be used like so: + (defpackage foo + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (check-type conc-name symbol) + (flet ((reader (slot) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defmacro when-let ((var value) &body body) + `(let ((,var ,value)) + (when ,var ,@body))) + +(defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + +(defun with-symbol (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (and (find-package package) + (find-symbol (string name) package)))) + +(defun choose-symbol (package name alt-package alt-name) + "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. + Suitable for use with #." + (or (and (find-package package) + (find-symbol (string name) package)) + (find-symbol (string alt-name) alt-package))) + + +;;;; UFT8 + +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + #xFFFD))))) ;; Replacement_Character + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (code-char #xFFFD)) ;; Replacement_Character + ((and (< code char-code-limit) + (code-char code))) + (t + (code-char #xFFFD))) ;; Replacement_Character + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun %utf8-encode (code buffer start end) + (declare (type (unsigned-byte 31) code) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (%utf8-encode (code-char #xFFFD) ;; Replacement_Character + buffer start end)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + (t (utf8-encode-aux code buffer start end 6)))) + +(defun utf8-encode (char buffer start end) + (declare (type character char) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (%utf8-encode (char-code char) buffer start end)) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) + + +;;;; TCP server + +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + (declare (ignore function)) + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + +(definterface quit-lisp () + "Exit the current lisp image.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface lisp-implementation-program () + "Return the argv[0] of the running Lisp process, or NIL." + (let ((file (car (command-line-args)))) + (when (and file (probe-file file)) + (namestring (truename file))))) + +(definterface socket-fd (socket-stream) + "Return the file descriptor for SOCKET-STREAM.") + +(definterface make-fd-stream (fd external-format) + "Create a character stream for the file descriptor FD.") + +(definterface dup (fd) + "Duplicate a file descriptor. +If the syscall fails, signal a condition. +See dup(2).") + +(definterface exec-image (image-file args) + "Replace the current process with a new process image. +The new image is created by loading the previously dumped +core file IMAGE-FILE. +ARGS is a list of strings passed as arguments to +the new image. +This is thin wrapper around exec(3).") + +(definterface command-line-args () + "Return a list of strings as passed by the OS." + nil) + + +;; pathnames are sooo useless + +(definterface filename-to-pathname (filename) + "Return a pathname for FILENAME. +A filename in Emacs may for example contain asterisks which should not +be translated to wildcards." + (parse-namestring filename)) + +(definterface pathname-to-filename (pathname) + "Return the filename for PATHNAME." + (namestring pathname)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + + +;;;; Packages + +(definterface package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the +nicknames local to the designated package." + (declare (ignore package)) + nil) + +(definterface find-locally-nicknamed-package (name base-package) + "Return the package whose local nickname in BASE-PACKAGE matches NAME. +Return NIL if local nicknames are not implemented or if there is no +such package." + (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position filename + line column policy) + "Compile source from STRING. +During compilation, compiler conditions must be trapped and +resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If FILENAME is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +If LINE and COLUMN are supplied, and non-NIL, they may be used +by certain implementations as the line and column of the start of +the string in FILENAME. Both LINE and COLUMN are 1-based. + +Should return T on successful compilation, NIL otherwise. +") + +(definterface swank-compile-file (input-file output-file load-p + external-format + &key policy) + "Compile INPUT-FILE signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note :redefinition)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + ;; Macro expansion history etc. which may be helpful in some cases + ;; but is often very verbose. + (source-context :initarg :source-context + :type (or null string) + :initform nil + :accessor source-context) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s pathname :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline #\;))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + +(defvar *auto-flush-interval* 0.2) + +(defun auto-flush-loop (stream interval &optional receive) + (loop + (when (not (and (open-stream-p stream) + (output-stream-p stream))) + (return nil)) + (force-output stream) + (when receive + (receive-if #'identity)) + (sleep interval))) + +(definterface make-auto-flush-thread (stream) + "Make an auto-flush thread" + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil)) + :name "auto-flush-thread")) + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest variables)) + (ignore '(&rest variables)) + (ignorable '(&rest variables)) + (special '(&rest variables)) + (inline '(&rest function-names)) + (notinline '(&rest function-names)) + (declaration '(&rest names)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) + (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest variables)) + ((and (listp decl-identifier) + (typespec-p (first decl-identifier))) + '(&rest variables)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface type-specifier-p (symbol) + "Determine if SYMBOL is a type-specifier." + (or (documentation symbol 'type) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is +available." + (declare (ignore function)) + nil) + +(definterface valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (eq (first form) 'setf) (symbolp (second form)))))) + +(definterface macroexpand-all (form &optional env) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) + (valid-function-name-p (car form)) + (compiler-macro-function (car form) env)))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(defmacro with-collected-macro-forms + ((forms &optional result) instrumented-form &body body) + "Collect macro forms by locally binding *MACROEXPAND-HOOK*. + +Evaluates INSTRUMENTED-FORM and collects any forms which undergo +macro-expansion into a list. Then evaluates BODY with FORMS bound to +the list of forms, and RESULT (optionally) bound to the value of +INSTRUMENTED-FORM." + (assert (and (symbolp forms) (not (null forms)))) + (assert (symbolp result)) + (let ((result-symbol (or result (gensym)))) + `(call-with-collected-macro-forms + (lambda (,forms ,result-symbol) + (declare (ignore ,@(and (not result) + `(,result-symbol)))) + ,@body) + (lambda () ,instrumented-form)))) + +(defun call-with-collected-macro-forms (body-fn instrumented-fn) + (let ((return-value nil) + (collected-forms '())) + (let* ((real-macroexpand-hook *macroexpand-hook*) + (*macroexpand-hook* + (lambda (macro-function form environment) + (let ((result (funcall real-macroexpand-hook + macro-function form environment))) + (unless (eq result form) + (push form collected-forms)) + result)))) + (setf return-value (funcall instrumented-fn))) + (funcall body-fn collected-forms return-value))) + +(definterface collect-macro-forms (form &optional env) + "Collect subforms of FORM which undergo (compiler-)macro expansion. +Returns two values: a list of macro forms and a list of compiler macro +forms." + (with-collected-macro-forms (macro-forms expansion) + (ignore-errors (macroexpand-all form env)) + (with-collected-macro-forms (compiler-macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,expansion)))) + (values macro-forms compiler-macro-forms)))) + +(definterface format-string-expand (control-string) + "Expand the format string CONTROL-STRING." + (macroexpand `(formatter ,control-string))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys +not listed here (but slime-print-apropos in Emacs must know about +them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. HOOK can be NIL. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. ``Ordered list'' +means that an integer I can be mapped back to the i-th frame of this +backtrace. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) + nil) + +(definterface frame-source-location (frame-number) + "Return the source location for the frame associated to FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of catch tags for being printed in a debugger stack +frame." + (declare (ignore frame-number)) + '()) + +(definterface frame-locals (frame-number) + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + +(definterface frame-call (frame-number) + "Return a string representing a call to the entry point of a frame.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface print-condition (condition stream) + "Print a condition for display in SLDB." + (princ condition stream)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface gdb-initial-commands () + "List of gdb commands supposed to be executed first for the + ATTACH-GDB restart." + nil) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (location (:type list) + (:constructor make-location + (buffer position &optional hints))) + (type :location) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defmacro converting-errors-to-error-location (&body body) + "Catches errors during BODY and converts them to an error location." + (let ((gblock (gensym "CONVERTING-ERRORS+"))) + `(block ,gblock + (handler-bind ((error + #'(lambda (e) + (if *debug-swank-backend* + nil ;decline + (return-from ,gblock + (make-error-location e)))))) + ,@body)))) + +(defun make-error-location (datum &rest args) + (cond ((typep datum 'condition) + `(:error ,(format nil "Error: ~A" datum))) + ((symbolp datum) + `(:error ,(format nil "Error: ~A" + (apply #'make-condition datum args)))) + (t + (assert (stringp datum)) + `(:error ,(apply #'format nil datum args))))) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface find-source-location (object) + "Returns the source location of OBJECT, or NIL. + +That is the source location of the underlying datastructure of +OBJECT. E.g. on a STANDARD-OBJECT, the source location of the +respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the +respective DEFSTRUCT definition, and so on." + ;; This returns one source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + (declare (ignore object)) + (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ + this implementation.")) + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified. +CMUCL/SBCL use this to cache the unmodified file and use the +unmodified text to improve the precision of source locations." + (declare (ignore filename)) + nil) + + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value." + (declare (ignore macro-name)) + :not-implemented) + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value." + (declare (ignore class-name)) + :not-implemented) + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Trace + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Inspector + +(defgeneric emacs-inspect (object) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +Returns a list specifying how to render the object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. +")) + +(defmethod emacs-inspect ((object t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc)))) + +(definterface eval-context (object) + "Return a list of bindings corresponding to OBJECT's slots." + (declare (ignore object)) + '()) + +;;; Utilities for inspector methods. +;;; + +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id ) (thread-id )) <==> (eq )" + thread) + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists." + (declare (ignore id)) + (current-thread)) + +(definterface thread-name (thread) + "Return the name of THREAD. +Thread names are short strings meaningful to the user. They do not +have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a fresh list of all threads." + '()) + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Terminate THREAD immediately. +Don't execute unwind-protected sections, don't raise conditions. +(Do not pass go, do not collect $200.)" + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD." + (declare (ignore thread)) + object) + +(definterface receive (&optional timeout) + "Return the next message from current thread's mailbox." + (receive-if (constantly t) timeout)) + +(definterface receive-if (predicate &optional timeout) + "Return the first message satisfiying PREDICATE.") + +(definterface wake-thread (thread) + "Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using +asynchronous interrupts." + (declare (ignore thread)) + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient + nil) + +(definterface register-thread (name thread) + "Associate the thread THREAD with the symbol NAME. +The thread can then be retrieved with `find-registered'. +If THREAD is nil delete the association." + (declare (ignore name thread)) + nil) + +(definterface find-registered (name) + "Find the thread that was registered for the symbol NAME. +Return nil if the no thread was registred or if the tread is dead." + (declare (ignore name)) + nil) + +(definterface set-default-initial-binding (var form) + "Initialize special variable VAR by default with FORM. + +Some implementations initialize certain variables in each newly +created thread. This function sets the form which is used to produce +the initial value." + (set var (eval form))) + +;; List of delayed interrupts. +;; This should only have thread-local bindings, so no init form. +(defvar *pending-slime-interrupts*) + +(defun check-slime-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete. +Return a boolean indicating whether any interrupts was processed." + (when (and (boundp '*pending-slime-interrupts*) + *pending-slime-interrupts*) + (funcall (pop *pending-slime-interrupts*)) + t)) + +(defvar *interrupt-queued-handler* nil + "Function to call on queued interrupts. +Interrupts get queued when an interrupt occurs while interrupt +handling is disabled. + +Backends can use this function to abort slow operations.") + +(definterface wait-for-input (streams &optional timeout) + "Wait for input on a list of streams. Return those that are ready. +STREAMS is a list of streams +TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams +which are ready (or have reached end-of-file) without waiting. +If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, +return nil. + +Return :interrupt if an interrupt occurs while waiting." + (declare (ignore streams timeout)) + ;; Invoking the slime debugger will just endlessly loop. + (call-with-debugger-hook + nil + (lambda () + (error "~s not implemented. Check if ~s = ~s is supported by the implementation." + 'wait-for-input 'swank:*communication-style* swank:*communication-style*)))) + + +;;;; Locks + +;; Please use locks only in swank-gray.lisp. Locks are too low-level +;; for our taste. + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Floating point + +(definterface float-nan-p (float) + "Return true if FLOAT is a NaN value (Not a Number)." + ;; When the float type implements IEEE-754 floats, two NaN values + ;; are never equal; when the implementation does not support NaN, + ;; the predicate should return false. An implementation can + ;; implement comparison with "unordered-signaling predicates", which + ;; emit floating point exceptions. + (handler-case (not (= float float)) + ;; Comparisons never signal an exception other than the invalid + ;; operation exception (5.11 Details of comparison predicates). + (floating-point-invalid-operation () t))) + +(definterface float-infinity-p (float) + "Return true if FLOAT is positive or negative infinity." + (not (< most-negative-long-float + float + most-positive-long-float))) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") + +(defun deinit-log-output () + ;; Can't hang on to an fd-stream from a previous session. + (setf *log-output* nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'slime-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'slime-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement)) + spec) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'slime-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'slime-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'slime-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) diff --git a/elpa/slime-20200319.1939/swank/ccl.lisp b/elpa/slime-20200319.1939/swank/ccl.lisp new file mode 100644 index 00000000..5518f568 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/ccl.lisp @@ -0,0 +1,868 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ccl.lisp --- SLIME backend for Clozure CL. +;;; +;;; Copyright (C) 2003, James Bielman +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with Clozure CL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage swank/ccl + (:use cl swank/backend)) + +(in-package swank/ccl) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 4)) + () "This file needs CCL version 1.4 or newer")) + +(defimplementation gray-package-name () + "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (ok err) (ignore-errors (require 'xref)) + (unless ok + (warn "~a~%" err)))) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl:standard-slot-definition + cl:method + cl:standard-class + ccl:eql-specializer + openmcl-mop:finalize-inheritance + openmcl-mop:compute-applicable-methods-using-classes + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + openmcl-mop:slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout)) + (let ((stream-args (and external-format + `(:external-format ,external-format)))) + (ccl:accept-connection socket :wait t :stream-args stream-args))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation socket-fd (stream) + (ccl::ioblock-device (ccl::stream-ioblock stream t))) + +;;; Unix signals + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "ccl") + +;;; Arglist + +(defimplementation arglist (fname) + (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) + (ccl:arglist fname)) + (if binding + arglist + :not-available))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (let ((flags (ccl:declaration-information decl-identifier))) + (if flags + `(&any ,flags) + (call-next-method)))) + +;;; Compilation + +(defun handle-compiler-warning (condition) + "Resignal a ccl:compiler-warning as swank/backend:compiler-warning." + (signal 'compiler-condition + :original-condition condition + :message (compiler-warning-short-message condition) + :source-context nil + :severity (compiler-warning-severity condition) + :location (source-note-to-source-location + (ccl:compiler-warning-source-note condition) + (lambda () "Unknown source") + (ccl:compiler-warning-function-name condition)))) + +(defgeneric compiler-warning-severity (condition)) +(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) +(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) + +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl:report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl:compiler-warning)) + (with-output-to-string (stream) + (ccl:report-compiler-warning c stream :short t))) + +;; Needed because `ccl:report-compiler-warning' would return +;; "Nonspecific warning". +(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) + (princ-to-string c)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) + (let ((ccl:*merge-compiler-warnings* nil)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +;; Use a temp file rather than in-core compilation in order to handle +;; eval-when's as compile-time. +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column policy)) + (with-compilation-hooks () + (let ((temp-file-name (ccl:temp-pathname)) + (ccl:*save-source-locations* t)) + (unwind-protect + (progn + (with-open-file (s temp-file-name :direction :output + :if-exists :error :external-format :utf-8) + (write-string string s)) + (let ((binary-filename (compile-temp-file + temp-file-name filename buffer position))) + (delete-file binary-filename))) + (delete-file temp-file-name))))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) + (compile-file temp-file-name + :load t + :compile-file-original-truename + (or buffer-file-name + (progn + (setf (gethash temp-file-name *temp-file-map*) + buffer-name) + temp-file-name)) + :compile-file-original-buffer-offset (1- offset) + :external-format :utf-8)) + +(defimplementation save-image (filename &optional restart-function) + (ccl:save-application filename :toplevel-function restart-function)) + +;;; Cross-referencing + +(defun xref-locations (relation name &optional inverse) + (delete-duplicates + (mapcan #'find-definitions + (if inverse + (ccl::get-relation relation name :wild :exhaustive t) + (ccl::get-relation relation :wild name :exhaustive t))) + :test 'equal)) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation who-specializes (class) + (when (symbolp class) + (setq class (find-class class nil))) + (when class + (delete-duplicates + (mapcar (lambda (m) + (car (find-definitions m))) + (ccl:specializer-direct-methods class)) + :test 'equal))) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation list-callers (symbol) + (delete-duplicates + (mapcan #'find-definitions (ccl:caller-functions symbol)) + :test #'equal)) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;; Debugging + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(*debugger-hook* nil) + ;; don't let error while printing error take us down + (ccl:*signal-printing-errors* nil)) + (funcall debugger-loop-fn))) + +;; This is called for an async interrupt and is running in a random +;; thread not selected by the user, so don't use thread-local vars +;; such as *emacs-connection*. +(defun find-repl-thread () + (let* ((*break-on-signals* nil) + (conn (swank::default-connection))) + (and (swank::multithreaded-connection-p conn) + (swank::mconn.repl-thread conn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ccl:*break-hook* hook) + (ccl:*select-interactive-process-hook* 'find-repl-thread)) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ccl:*break-hook* function) + (setq ccl:*select-interactive-process-hook* 'find-repl-thread) + ) + +(defun map-backtrace (function &optional + (start-frame-number 0) + end-frame-number) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((end-frame-number (or end-frame-number most-positive-fixnum))) + (ccl:map-call-frames function + :origin ccl:*top-error-frame* + :start-frame-number start-frame-number + :count (- end-frame-number start-frame-number)))) + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (p context) + (push (list :frame p context) result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context) (rest frame) + (let ((lfun (ccl:frame-function p context))) + (format stream "(~S" (or (ccl:function-name lfun) lfun)) + (let* ((unavailable (cons nil nil)) + (args (ccl:frame-supplied-arguments p context + :unknown-marker unavailable))) + (declare (dynamic-extent unavailable)) + (if (eq args unavailable) + (format stream " #") + (dolist (arg args) + (if (eq arg unavailable) + (format stream " #") + (format stream " ~s" arg))))) + (format stream ")")))) + +(defmacro with-frame ((p context) frame-number &body body) + `(call/frame ,frame-number (lambda (,p ,context) . ,body))) + +(defun call/frame (frame-number if-found) + (map-backtrace + (lambda (p context) + (return-from call/frame + (funcall if-found p context))) + frame-number)) + +(defimplementation frame-call (frame-number) + (with-frame (p context) frame-number + (with-output-to-string (stream) + (print-frame (list :frame p context) stream)))) + +(defimplementation frame-var-value (frame var) + (with-frame (p context) frame + (cdr (nth var (ccl:frame-named-variables p context))))) + +(defimplementation frame-locals (index) + (with-frame (p context) index + (loop for (name . value) in (ccl:frame-named-variables p context) + collect (list :name name :value value :id 0)))) + +(defimplementation frame-source-location (index) + (with-frame (p context) index + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (if pc + (pc-source-location lfun pc) + (function-source-location lfun))))) + +(defun function-name-package (name) + (etypecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql ccl::traced)) (function-name-package (second name))) + ((cons (eql setf)) (symbol-package (second name))) + ((cons (eql :internal)) (function-name-package (car (last name)))) + ((cons (and symbol (not keyword)) (or (cons list null) + (cons keyword (cons list null)))) + (symbol-package (car name))) + (standard-method (function-name-package (ccl:method-name name))))) + +(defimplementation frame-package (frame-number) + (with-frame (p context) frame-number + (let* ((lfun (ccl:frame-function p context)) + (name (ccl:function-name lfun))) + (function-name-package name)))) + +(defimplementation eval-in-frame (form index) + (with-frame (p context) index + (let ((vars (ccl:frame-named-variables p context))) + (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) + (declare (ignorable ,@(mapcar #'car vars))) + ,form))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (with-frame (p context) index + (declare (ignore context)) + (ccl:apply-in-frame p #'values values)))) + +(defimplementation restart-frame (index) + (with-frame (p context) index + (ccl:apply-in-frame p + (ccl:frame-function p context) + (ccl:frame-supplied-arguments p context)))) + +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context) the-frame-number + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) + (disassemble lfun)))) + +;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) +;; contains some interesting details: +;; +;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects +;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, +;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end +;; positions are file positions (not character positions). The text will +;; be NIL unless text recording was on at read-time. If the original +;; file is still available, you can force missing source text to be read +;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. +;; +;; Source-note's are associated with definitions (via record-source-file) +;; and also stored in function objects (including anonymous and nested +;; functions). The former can be retrieved via +;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. +;; +;; The recording behavior is controlled by the new variable +;; CCL:*SAVE-SOURCE-LOCATIONS*: +;; +;; If NIL, don't store source-notes in function objects, and store only +;; the filename for definitions (the latter only if +;; *record-source-file* is true). +;; +;; If T, store source-notes, including a copy of the original source +;; text, for function objects and definitions (the latter only if +;; *record-source-file* is true). +;; +;; If :NO-TEXT, store source-notes, but without saved text, for +;; function objects and defintions (the latter only if +;; *record-source-file* is true). This is the default. +;; +;; PC to source mapping is controlled by the new variable +;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a +;; compressed table mapping pc offsets to corresponding source locations. +;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) +;; which returns a source-note for the source at offset pc in the +;; function. + +(defun function-source-location (function) + (source-note-to-source-location + (or (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "Function has no source note: ~A" function)) + (ccl:function-name function))) + +(defun pc-source-location (function pc) + (source-note-to-source-location + (or (ccl:find-source-note-at-pc function pc) + (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "No source note at PC: ~a[~d]" function pc)) + (ccl:function-name function))) + +(defun function-name-source-note (fun) + (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) + (and defs + (destructuring-bind ((type . name) srcloc . srclocs) (car defs) + (declare (ignore type name srclocs)) + srcloc)))) + +(defun source-note-to-source-location (source if-nil-thunk &optional name) + (labels ((filename-to-buffer (filename) + (cond ((gethash filename *temp-file-map*) + (list :buffer (gethash filename *temp-file-map*))) + ((probe-file filename) + (list :file (ccl:native-translated-namestring + (truename filename)))) + (t (error "File ~s doesn't exist" filename))))) + (handler-case + (cond ((ccl:source-note-p source) + (let* ((full-text (ccl:source-note-text source)) + (file-name (ccl:source-note-filename source)) + (start-pos (ccl:source-note-start-pos source))) + (make-location + (when file-name (filename-to-buffer (pathname file-name))) + (when start-pos (list :position (1+ start-pos))) + (when full-text + (list :snippet (subseq full-text 0 + (min 40 (length full-text)))))))) + ((and source name) + ;; This branch is probably never used + (make-location + (filename-to-buffer source) + (list :function-name (princ-to-string + (if (functionp name) + (ccl:function-name name) + name))))) + (t `(:error ,(funcall if-nil-thunk)))) + (error (c) `(:error ,(princ-to-string c)))))) + +(defun alphatizer-definitions (name) + (let ((alpha (gethash name ccl::*nx1-alphatizers*))) + (and alpha (ccl:find-definition-sources alpha)))) + +(defun p2-definitions (name) + (let ((nx1-op (gethash name ccl::*nx1-operators*))) + (and nx1-op + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) + +(defimplementation find-definitions (name) + (let ((defs (append (or (ccl:find-definition-sources name) + (and (symbolp name) + (fboundp name) + (ccl:find-definition-sources + (symbol-function name)))) + (alphatizer-definitions name) + (p2-definitions name)))) + (loop for ((type . name) . sources) in defs + collect (list (definition-name type name) + (source-note-to-source-location + (find-if-not #'null sources) + (lambda () "No source-note available") + name))))) + +(defimplementation find-source-location (obj) + (let* ((defs (ccl:find-definition-sources obj)) + (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) + (car defs))) + (note (find-if-not #'null (cdr best-def)))) + (when note + (source-note-to-source-location + note + (lambda () "No source note available"))))) + +(defun definition-name (type object) + (case (ccl:definition-type-name type) + (method (ccl:name-of object)) + (t (list (ccl:definition-type-name type) (ccl:name-of object))))) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl:setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + (maybe-push + :type (when (ccl:type-specifier-p symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl:setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (or (find-class symbol nil) symbol))))) + +;; spec ::= (:defmethod {}* ({}*)) +(defun parse-defmethod-spec (spec) + (values (second spec) + (subseq spec 2 (position-if #'consp spec)) + (find-if #'consp (cddr spec)))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (let ((what (ecase (first spec) + ((setf) + spec) + ((:defgeneric) + (second spec)) + ((:defmethod) + (multiple-value-bind (name qualifiers specializers) + (parse-defmethod-spec spec) + (find-method (fdefinition name) + qualifiers + specializers)))))) + (cond ((member what (trace) :test #'equal) + (ccl::%untrace what) + (format nil "~S is now untraced." what)) + (t + (ccl:trace-function what) + (format nil "~S is now traced." what))))) + +;;; Macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (ccl:macroexpand-all form env)) + +;;;; Inspection + +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + +(defmethod emacs-inspect ((o t)) + (let* ((inspector:*inspector-disassembly* t) + (i (inspector:make-inspector o)) + (count (inspector:compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector:line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) + +(defmethod emacs-inspect :around ((o t)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (let ((value (call-next-method))) + (cond ((listp value) + (append value + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR")))) + (t value))))) + +(defmethod emacs-inspect ((f function)) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(princ-to-string (arglist f)) (:newline)) + (label-value-line "Documentation" (documentation f t)) + (when (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))) + (when (ccl:function-source-note f) + (label-value-line "Source note" + (ccl:function-source-note f))) + (when (typep f 'ccl:compiled-lexical-closure) + (append + (label-value-line "Inner function" (ccl::closure-function f)) + '("Closed over values:" (:newline)) + (loop for (name value) in (ccl::closure-closed-over-values f) + append (label-value-line (format nil " ~a" name) + value)))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod emacs-inspect ((uv uvector-inspector)) + (with-slots (object) uv + (loop for i below (ccl:uvsize object) append + (label-value-line (princ-to-string i) (ccl:uvref object i))))) + +(defimplementation type-specifier-p (symbol) + (or (ccl:type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Multiprocessing + +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fun &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") + fun)) + +(defimplementation thread-id (thread) + (ccl:process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl:process-serial-number)) + +(defimplementation thread-name (thread) + (ccl:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (ccl:process-priority thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + ;;(ccl:process-kill thread) ; doesn't cut it + (ccl::process-initial-form-exited thread :kill)) + +(defimplementation thread-alive-p (thread) + (not (ccl:process-exhausted-p thread))) + +(defimplementation interrupt-thread (thread function) + (ccl:process-interrupt + thread + (lambda () + (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) + (funcall function))))) + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) + +(let ((alist '()) + (lock (ccl:make-lock "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (ccl:with-lock-grabbed (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (ccl:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (ccl:with-lock-grabbed (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (eval `(ccl::def-standard-initial-binding ,var ,form))) + +(defimplementation quit-lisp () + (ccl:quit)) + +(defimplementation set-default-directory (directory) + (let ((dir (truename (merge-pathnames directory)))) + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (ccl:cwd dir) + (default-directory))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl:hash-table-weak-p hashtable)) + +(pushnew 'deinit-log-output ccl:*save-exit-functions*) diff --git a/elpa/slime-20200319.1939/swank/clasp.lisp b/elpa/slime-20200319.1939/swank/clasp.lisp new file mode 100644 index 00000000..4fdab2c1 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/clasp.lisp @@ -0,0 +1,803 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-clasp.lisp --- SLIME backend for CLASP. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/clasp + (:use cl swank/backend)) + +(in-package swank/clasp) + +#+(or) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq swank::*log-output* (open "/tmp/slime.log" :direction :output)) + (setq swank:*log-events* t)) + +(defmacro slime-dbg (fmt &rest args) + `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols :clos nil)) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn +#| #+threads :spawn + #-threads nil +|# + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, CLASP uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If CLASP is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as CLASP's +;;; main-thread is also the Slime's REPL thread. + +#+clasp-working +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (core:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun condition-severity (condition) + (etypecase condition + (cmp:redefined-function-warning :redefinition) + (style-warning :style-warning) + (warning :warning) + (reader-error :read-error) + (error :error))) + +(defun condition-location (origin) + (if (null origin) + (make-error-location "No error location available") + ;; NOTE: If we're compiling in a buffer, the origin + ;; will already be set up with the offset correctly + ;; due to the :source-debug parameters from + ;; swank-compile-string (below). + (make-file-location + (core:file-scope-pathname + (core:file-scope origin)) + (core:source-pos-info-filepos origin)))) + +(defun signal-compiler-condition (condition origin) + (signal 'compiler-condition + :original-condition condition + :severity (condition-severity condition) + :message (princ-to-string condition) + :location (condition-location origin))) + +(defun handle-compiler-condition (condition) + ;; First resignal warnings, so that outer handlers - which may choose to + ;; muffle this - get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition) + (cmp:compiler-condition-origin condition))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind + (((or error warning) #'handle-compiler-condition)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) + ;; Ignore the output-file and generate our own + (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-")))) + (format t "Using tmp-output-file: ~a~%" tmp-output-file) + (multiple-value-bind (fasl warnings-p failure-p) + (with-compilation-hooks () + (compile-file input-file :output-file tmp-output-file + :external-format external-format)) + (values fasl warnings-p + (or failure-p + (when load-p + (not (load fasl)))))))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename line column policy) + (declare (ignore column policy)) ;; We may use column in the future + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) + (compile-file tmp-file + :source-debug-pathname (pathname truename) + ;; emacs numbers are 1-based instead of 0-based, + ;; so we have to subtract + :source-debug-lineno (1- line) + :source-debug-offset (1- position))))) + (when fasl-file (load fasl-file)) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (core:function-lambda-list name) ;; Uses bc-split + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos::generic-function-name f)) + (function (ext:compiled-function-name f)))) + +;; FIXME +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +;;; modified from sbcl.lisp +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (format t "In collect-macro-forms~%") + (cmp:code-walk + (lambda (form environment) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (core:compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form) + form environment) + (values macro-forms compiler-macro-forms))) + + + + + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* +#+frs si::*frs-base* +#+frs si::*frs-top* + si::*tpl-commands* + si::*tpl-level* +#+frs si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env +#+frs si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)) + ) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun)) + ) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of CLASP's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* 0) + (*ihs-current* *ihs-top*) + #+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + #+frs (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*))) + (core:call-with-backtrace + (lambda (raw-backtrace) + (let ((*backtrace* + (let ((backtrace (core::common-lisp-backtrace-frames + raw-backtrace + :gather-start-trigger + (lambda (frame) + (let ((function-name (core::backtrace-frame-function-name frame))) + (and (symbolp function-name) + (eq function-name 'core::universal-error-handler)))) + :gather-all-frames nil))) + (unless backtrace + (setq backtrace (core::common-lisp-backtrace-frames + :gather-all-frames nil))) + backtrace))) + (declare (special *ihs-current*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn))))))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (core::backtrace-frame-function-name frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun frame-function (frame-number) + (let ((x (core::backtrace-frame-function-name (elt *backtrace* frame-number)))) + (etypecase x + (symbol + (and (fboundp x) + (fdefinition x))) + (cons + (if (eq (car x) 'cl:setf) + (fdefinition x) + nil)) + (function + x)))) + +(defimplementation print-frame (frame stream) + (if (core::backtrace-frame-arguments frame) + (format stream "(~a~{ ~s~})" (core::backtrace-frame-print-name frame) + (coerce (core::backtrace-frame-arguments frame) 'list)) + (format stream "~a" (core::backtrace-frame-print-name frame)))) + +(defimplementation frame-source-location (frame-number) + (let* ((address (core::backtrace-frame-return-address (elt *backtrace* frame-number))) + (code-source-location (ext::code-source-position address))) + (format t "address: ~a code-source-location ~s~%" address code-source-location) + ;; (core::source-info-backtrace *backtrace*) + (if (ext::code-source-line-source-pathname code-source-location) + (make-location (list :file (namestring (ext::code-source-line-source-pathname code-source-location))) + (list :line (ext::code-source-line-line-number code-source-location)) + '(:align t)) + `(:error ,(format nil "No source for frame: ~a" frame-number))))) + +#+clasp-working +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defun ihs-frame-id (frame-number) + (- (core:ihs-top) frame-number)) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (env nil) ; no env yet + (locals (loop for x = env then (core:get-parent-environment x) + while x + nconc (loop for name across (core:environment-debug-names x) + for value across (core:environment-debug-values x) + collect (list :name name :id 0 :value value))))) + (nconc + (loop for arg across (core::backtrace-frame-arguments frame) + for i from 0 + collect (list :name (intern (format nil "ARG~d" i) :cl-user) + :id 0 + :value arg)) + locals))) + +(defimplementation frame-var-value (frame-number var-number) + (let* ((frame (elt *backtrace* frame-number)) + (env nil) + (args (core::backtrace-frame-arguments frame))) + (if (< var-number (length args)) + (svref args var-number) + (elt (frame-locals frame-number) var-number)))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function frame-number))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (raw-arg-values (coerce (core::backtrace-frame-arguments frame) 'list))) + (if (and (= (length raw-arg-values) 2) (core:vaslistp (car raw-arg-values))) + (let* ((arg-values (core:list-from-va-list (car raw-arg-values))) + (bindings (append (loop for i from 0 for value in arg-values collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value)) + (list (list (intern "NEXT-METHODS" :cl-user) (cadr raw-arg-values)))))) + (eval + `(let (,@bindings) ,form))) + (let* ((arg-values raw-arg-values) + (bindings (loop for i from 0 for value in arg-values collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value)))) + (eval + `(let (,@bindings) ,form)))))) + + +#+clasp-working +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +#+clasp-working +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from CLASP point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun translate-location (location) + (make-location (list :file (namestring (ext:source-location-pathname location))) + (list :position (ext:source-location-offset location)) + '(:align t))) + +(defimplementation find-definitions (name) + (loop for kind in ext:*source-location-kinds* + for locations = (ext:source-location name kind) + when locations + nconc (loop for location in locations + collect (list kind (translate-location location))))) + +(defun source-location (object) + (let ((location (ext:source-location object t))) + (when location + (translate-location (car location))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-lock :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock :name "SLIMELCK")) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (format t "About to with-lock in wake-thread~%") + (mp:with-lock (mutex) + (format t "In wake-thread~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex) + (swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (mp:with-lock (mutex) + (swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (swank::log-event "clasp.lisp: send about to broadcast~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + + (defimplementation receive-if (test &optional timeout) + (slime-dbg "Entered receive-if") + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (slime-dbg "receive-if assert") + (assert (or (not timeout) (eq timeout t))) + (loop + (slime-dbg "receive-if check-slime-interrupts") + (check-slime-interrupts) + (slime-dbg "receive-if with-lock") + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (slime-dbg "receive-if when (eq") + (when (eq timeout t) (return (values nil t))) + (slime-dbg "receive-if condition-variable-timedwait") + (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 + (slime-dbg "came out of condition-variable-timedwait") + (core:check-pending-interrupts))))) + + ) ; #+threads (progn ... + + +(defmethod emacs-inspect ((object core:cxx-object)) + (let ((encoded (core:encode object))) + (loop for (key . value) in encoded + append (list (string key) ": " (list :value value) (list :newline))))) + +(defmethod emacs-inspect ((object core:va-list)) + (emacs-inspect (core:list-from-va-list object))) diff --git a/elpa/slime-20200319.1939/swank/clisp.lisp b/elpa/slime-20200319.1939/swank/clisp.lisp new file mode 100644 index 00000000..6e23b801 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/clisp.lisp @@ -0,0 +1,930 @@ +;;;; -*- indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program 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 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(defpackage swank/clisp + (:use cl swank/backend)) + +(in-package swank/clisp) + +(eval-when (:compile-toplevel) + (unless (string< "2.44" (lisp-implementation-version)) + (error "Need at least CLISP version 2.44"))) + +(defimplementation gray-package-name () + "GRAY") + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank/clisp::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (when (find-restart 'socket-status) + (invoke-restart (find-restart 'socket-status))) + (continue)))) + (funcall function))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + +;;;; TCP Server + +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +#-win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout + (socket:socket-status streams 0 0) + (return (loop for (s nil . x) in streams + if x collect s))) + (t + (with-simple-restart (socket-status "Return from socket-status.") + (socket:socket-status streams 0 500000)) + (let ((ready (loop for (s nil . x) in streams + if x collect s))) + (when ready (return ready)))))))) + +#+win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (t + (let ((ready (remove-if-not #'input-available-p streams))) + (when ready (return ready))) + (when timeout (return nil)) + (sleep 0.1))))) + +#+win32 +;; Some facts to remember (for the next time we need to debug this): +;; - interactive-sream-p returns t for socket-streams +;; - listen returns nil for socket-streams +;; - (type-of ) is 'stream +;; - (type-of *terminal-io*) is 'two-way-stream +;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) +;; - calling socket:socket-status on non sockets signals an error, +;; but seems to mess up something internally. +;; - calling read-char-no-hang on sockets does not signal an error, +;; but seems to mess up something internally. +(defun input-available-p (stream) + (case (stream-element-type stream) + (character + (let ((c (read-char-no-hang stream nil nil))) + (cond ((not c) + nil) + (t + (unread-char c stream) + t)))) + (t + (eq (socket:socket-status (cons stream :input) 0 0) + :input)))) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1") + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Swank functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defun fspec-pathname (spec) + (let ((path spec) + type + lines) + (when (consp path) + (psetq type (car path) + path (cadr path) + lines (cddr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path type lines))) + +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) + (fspec-pathname fspec) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) + (ignore-errors (truename file)) + (cond (truename + (make-location + (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string name))) + (when (consp type) + (list :snippet (format nil "~A" type))))) + (t (list :error (princ-to-string c)))))) + (t (list :error + (format nil "No source information available for: ~S" + fspec))))))) + +(defimplementation find-definitions (name) + (mapcar #'(lambda (e) (fspec-location name e)) + (documentation name 'sys::file))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (let* ((modes '((:all-stack-elements 1) + (:all-frames 2) + (:only-lexical-frames 3) + (:only-eval-and-apply-frames 4) + (:only-apply-frames 5))) + (mode (cadr (assoc :all-stack-elements modes)))) + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + (sys::frame-up 1 frame mode))) + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (let* ((f (sys::the-frame)) + (bt (sldb-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env + compiled-tagbody compiled-block))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +;; FIXME: they changed the layout in 2.44 and not all patterns have +;; been updated. +(defvar *frame-prefixes* + '(("\\[[0-9]\\+\\] frame binding variables" bind-var) + ("<1> # # # " fun) + ("<2> " 2nd-frame) + )) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (loop for f in (subseq bt start (min (or end len) len)) + collect f))) + +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \\(.*\\)" s 1)) + (apply + (string-match "APPLY frame for call \\(.*\\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down 1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (regexp string) + (if (regexp:match (concatenate 'string "^" regexp) string) t)) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':offset *buffer-offset* 0))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location)) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (&rest args) + (signal 'compiler-condition + :severity :error + :message (apply #'format nil + (if (= (length args) 3) + (cdr args) + args)) + :location (compiler-note-location)) + (apply *orig-c-error* args)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (with-compilation-unit () + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (fspec-location symbol symbol) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defmethod emacs-inspect ((o t)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o + (sys::insp-title inspection) + (sys::insp-blurb inspection))) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + + +(defimplementation preferred-communication-style () + nil) + +;;; FIXME +;;; +;;; Clisp 2.48 added experimental support for threads. Basically, you +;;; can use :SPAWN now, BUT: +;;; +;;; - there are problems with GC, and threads stuffed into weak +;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. +;;; +;;; See test case at +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 +;;; +;;; Even though said to be fixed, it's not: +;;; +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 +;;; +;;; - The DYNAMIC-FLET above is an implementation technique that's +;;; probably not sustainable in light of threads. This got to be +;;; rewritten. +;;; +;;; TCR (2009-07-30) + +#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) +(progn + (defimplementation spawn (fn &key name) + (mp:make-thread fn :name name)) + + (defvar *thread-plist-table-lock* + (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) + + (defvar *thread-plist-table* (make-hash-table :weak :key) + "A hashtable mapping threads to a plist.") + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (mp:with-mutex-lock (*thread-plist-table-lock*) + (or (getf (gethash thread *thread-plist-table*) 'thread-id) + (setf (getf (gethash thread *thread-plist-table*) 'thread-id) + (incf *thread-id-counter*))))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plist-table*) 'thread-id)))) + + (defimplementation thread-name (thread) + ;; To guard against returning #. + (princ-to-string (mp:thread-name thread))) + + (defimplementation thread-status (thread) + (if (thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-mutex :name name :recursive-p t)) + + (defimplementation call-with-lock-held (lock function) + (mp:with-mutex-lock (lock) + (funcall function))) + + (defimplementation current-thread () + (mp:current-thread)) + + (defimplementation all-threads () + (mp:list-threads)) + + (defimplementation interrupt-thread (thread fn) + (mp:thread-interrupt thread :function fn)) + + (defimplementation kill-thread (thread) + (mp:thread-interrupt thread :function t)) + + (defimplementation thread-alive-p (thread) + (mp:thread-active-p thread)) + + (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) + (defvar *mailboxes* (list)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-lock :name "MAILBOX.LOCK")) + (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-mutex-lock (*mailboxes-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox.lock mbox))) + (mp:with-mutex-lock (lock) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:exemption-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (lock (mailbox.lock mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-mutex-lock (lock) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) diff --git a/elpa/slime-20200319.1939/swank/cmucl.lisp b/elpa/slime-20200319.1939/swank/cmucl.lisp new file mode 100644 index 00000000..8b3d947d --- /dev/null +++ b/elpa/slime-20200319.1939/swank/cmucl.lisp @@ -0,0 +1,2470 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank/backend' package. + +(defpackage swank/cmucl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache + fwrappers)) + +(in-package swank/cmucl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (let ((min-version #x20c)) + (assert (>= c:byte-fasl-file-version min-version) + () "This file requires CMUCL version ~x or newer" min-version)) + + (require 'gray-streams)) + + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;; UTF8 + +(locally (declare (optimize (ext:inhibit-warnings 3))) + ;; Compile and load the utf8 format, if not already loaded. + (stream::find-external-format :utf-8)) + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (ext:accept-tcp-connection socket) + (ecase buffering + ((t) :full) + (:line :line) + ((nil) :none)) + external-format)) + +;;;;; Sockets + +(defimplementation socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "iso-latin-1-unix") + #+unicode + (:utf-8 "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd buffering external-format) + "Create a new input/output fd-stream for FD." + (cond (external-format + (sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) + +(defimplementation make-fd-stream (fd external-format) + (make-socket-io-stream fd :full external-format)) + +(defimplementation dup (fd) + (multiple-value-bind (clone error) (unix:unix-dup fd) + (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) + clone)) + +(defimplementation command-line-args () + ext:*command-line-strings*) + +(defimplementation exec-image (image-file args) + (multiple-value-bind (ok error) + (unix:unix-execve (car (command-line-args)) + (list* (car (command-line-args)) + "-core" image-file + "-noinit" + args)) + (error "~a" (unix:get-unix-error-msg error)) + ok)) + +;;;;; Signal-driven I/O + +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun reset-sigio-handlers () (setq *sigio-handlers* '())) +;; All file handlers are invalid afer reload. +(pushnew 'reset-sigio-handlers ext:*after-save-initializations*) + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (when (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + (assert (not (assoc fd *sigio-handlers*))) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (let ((ready (remove-if-not #'listen streams))) + (when ready (return ready))) + (when timeout (return nil)) + (multiple-value-bind (in out) (make-pipe) + (let* ((f (constantly t)) + (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) + collect (add-one-shot-handler s f)))) + (unwind-protect + (let ((*interrupt-queued-handler* (lambda () + (write-char #\! out)))) + (when (check-slime-interrupts) (return :interrupt)) + (sys:serve-event)) + (mapc #'sys:remove-fd-handler handlers) + (close in) + (close out)))))) + +(defun to-fd-stream (stream) + (etypecase stream + (sys:fd-stream stream) + (synonym-stream + (to-fd-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (to-fd-stream (two-way-stream-input-stream stream))))) + +(defun add-one-shot-handler (stream function) + (let (handler) + (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input + (lambda (fd) + (declare (ignore fd)) + (sys:remove-fd-handler handler) + (funcall function stream)))))) + +(defun make-pipe () + (multiple-value-bind (in out) (unix:unix-pipe) + (values (sys:make-fd-stream in :input t :buffering :none) + (sys:make-fd-stream out :output t :buffering :none)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (clear-xref-info input-file) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string) + (source-info (list :emacs-buffer buffer + :emacs-buffer-offset position + :emacs-buffer-string string))) + (with-input-from-string (stream string) + (let ((failurep (ext:compile-from-stream stream :source-info + source-info))) + (not failurep)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (compiler-condition-message condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun compiler-condition-message (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe context information for Emacs." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ + ~@[==>~{~&~A~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (with-struct (c::compiler-error-context- file-name + original-source + original-source-path) context + (or (locate-compiler-note file-name original-source + (reverse original-source-path)) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (cond (*compile-file-truename* + (make-location (list :file (unix-truename *compile-file-truename*)) + (list :eof))) + (*buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (t (list :error "No error location available.")))) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; + +(defxref who-macroexpands xref:who-macroexpands) +;; XXX +(defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + xref::*who-is-called* + xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (root-number (di:debug-source-root-number debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s root-number))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream root) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (- (di:code-location-top-level-form-offset location) + root)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s 0))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name) + (template-definitions name) + (primitive-definitions name) + (vm-support-routine-definitions name) + )) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (gf-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + +(defun byte-function-location (fun) + "Return the location of the byte-compiled function FUN." + (etypecase fun + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) + (if di + (debug-info-function-name-location di) + `(:error + ,(format nil "Byte-function without debug-info: ~a" fun))))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fun))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + (let ((ctor (struct-constructor dd))) + (cond (ctor + (function-location (coerce ctor 'function))) + (t + (let ((name (kernel:dd-name dd))) + (multiple-value-bind (location foundp) + (ext:info :source-location :defvar name) + (cond (foundp + (resolve-source-location location)) + (t + (error "No location for defstruct: ~S" name))))))))) + +(defun struct-constructor (dd) + "Return the name of the constructor from a defstruct definition." + (let* ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (if (consp constructor) (car constructor) constructor))) + +;;;;;; Generic functions and methods + +(defun gf-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +(defun method-location (method) + (typecase method + (pcl::standard-accessor-method + (definition-source-location + (cond ((pcl::definition-source method) + method) + (t + (pcl::slot-definition-class + (pcl::accessor-method-slot-definition method)))) + (pcl::accessor-method-slot-name method))) + (t + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (pcl-class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(class ,name) (class-location class)))))))) + +(defun pcl-class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +;; FIXME: eval used for backward compatibility. +(defun class-location (class) + (declare (type kernel::class class)) + (let ((name (kernel:%class-name class))) + (multiple-value-bind (loc found?) + (let ((x (ignore-errors + (multiple-value-list + (eval `(ext:info :source-location :class ',name)))))) + (values-list x)) + (cond (found? (resolve-source-location loc)) + (`(:error + ,(format nil "No location recorded for class: ~S" name))))))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-buffer-offset ,pos))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((f (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if f + `(((setf ,name) ,(function-location (cond ((functionp f) f) + ((macro-function f)) + ((fdefinition f))))))))) + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(,(type-of template) + ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + +(defun template-definitions (name) + (let* ((templates (c::backend-template-names c::*backend*)) + (template (gethash name templates))) + (etypecase template + (null) + (c::vop-info + (maybe-make-definition (c::vop-info-generator-function template) + (type-of template) name))))) + +;; for cases like: (%primitive NAME ...) +(defun primitive-definitions (name) + (let ((csym (find-symbol (string name) 'c))) + (and csym + (not (eq csym name)) + (template-definitions csym)))) + +(defun vm-support-routine-definitions (name) + (let ((sr (c::backend-support-routines c::*backend*)) + (name (find-symbol (string name) 'c))) + (and name + (slot-exists-p sr name) + (maybe-make-definition (slot-value sr name) + (find-symbol (string 'vm-support-routine) 'c) + name)))) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) + ((code-location-source-location (di:frame-code-location frame)))))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((loc (di:frame-code-location frame))) + (remove-if + (lambda (v) + (not (eq (di:debug-variable-validity v loc) :valid))) + (di::debug-function-debug-variables (di:frame-debug-function frame))))) + +(defun debug-var-value (var frame) + (let* ((loc (di:frame-code-location frame)) + (validity (di:debug-variable-validity var loc))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for v across (frame-debug-vars frame) + collect (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (call-next-function))) +(set-fwrappers 'di::handle-breakpoint '()) +(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (speed 0))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + (di::interpreted-debug-function -1) + (di::bogus-debug-function + #-x86 + (let* ((real (di::frame-real-frame (di::frame-up frame))) + (fp (di::frame-pointer real))) + ;;#+(or) + (progn + (format *debug-io* "Frame-real-frame = ~S~%" real) + (format *debug-io* "fp = ~S~%" fp) + (format *debug-io* "lra = ~S~%" + (kernel:stack-ref fp vm::lra-save-offset))) + (values + (sys:int-sap + (- (kernel:get-lisp-obj-address + (kernel:stack-ref fp vm::lra-save-offset)) + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type))) + 0)) + #+x86 + (let ((fp (di::frame-pointer (di:frame-up frame)))) + (multiple-value-bind (ra ofp) (di::x86-call-context fp) + (declare (ignore ofp)) + (values ra 0)))))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +~8X Stack Pointer +~8X Frame Pointer +~8X Instruction Pointer +~8X Saved Frame Pointer +~8X Saved Instruction Pointer~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + +(defvar *gdb-program-name* + (ext:enumerate-search-list (p "path:gdb") + (when (probe-file p) + (return p)))) + +(defimplementation disassemble-frame (frame-number) + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (cond ((probe-file *gdb-program-name*) + (let ((ip (sys:sap-int (frame-ip frame)))) + (princ (gdb-command "disas 0x~x" ip)))) + (t + (format t "~%[Disassembling bogus frames not implemented]"))))))) + +(defmacro with-temporary-file ((stream filename) &body body) + `(call/temporary-file (lambda (,stream ,filename) . ,body))) + +(defun call/temporary-file (fun) + (let ((name (system::pick-temporary-file-name))) + (unwind-protect + (with-open-file (stream name :direction :output :if-exists :supersede) + (funcall fun stream name)) + (delete-file name)))) + +(defun gdb-command (format-string &rest args) + (let ((str (gdb-exec (format nil + "interpreter-exec mi2 \"attach ~d\"~%~ + interpreter-exec console ~s~%detach" + (getpid) + (apply #'format nil format-string args)))) + (prompt (format nil + #-(and darwin x86) "~%^done~%(gdb) ~%" + #+(and darwin x86) +"~%^done,thread-id=\"1\"~%(gdb) ~%"))) + (subseq str (+ (or (search prompt str) 0) (length prompt))))) + +(defun gdb-exec (cmd) + (with-temporary-file (file filename) + (write-string cmd file) + (force-output file) + (let* ((output (make-string-output-stream)) + ;; gdb on sparc needs to know the executable to find the + ;; symbols. Without this, gdb can't disassemble anything. + ;; NOTE: We assume that the first entry in + ;; lisp::*cmucl-lib* is the bin directory where lisp is + ;; located. If this is not true, we'll have to do + ;; something better to find the lisp executable. + (lisp-path + #+sparc + (list + (namestring + (probe-file + (merge-pathnames "lisp" (car (lisp::parse-unix-search-path + lisp::*cmucl-lib*)))))) + #-sparc + nil) + (proc (ext:run-program *gdb-program-name* + `(,@lisp-path "-batch" "-x" ,filename) + :wait t + :output output))) + (assert (eq (ext:process-status proc) :exited)) + (assert (eq (ext:process-exit-code proc) 0)) + (get-output-stream-string output)))) + +(defun foreign-frame-p (frame) + #-x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) + #+x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (multiple-value-bind (pc code) + (di::compute-lra-data-from-pc ip) + (declare (ignore pc)) + (not code))))) + +(defun foreign-frame-source-location (frame) + (let ((ip (sys:sap-int (frame-ip frame)))) + (cond ((probe-file *gdb-program-name*) + (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) + (t `(:error "no srcloc available for ~a" frame))))) + +;; The output of gdb looks like: +;; Line 215 of "../../src/lisp/x86-assem.S" +;; starts at address 0x805318c +;; and ends at 0x805318e . +;; The ../../ are fixed up with the "target:" search list which might +;; be wrong sometimes. +(defun parse-gdb-line-info (string) + (with-input-from-string (*standard-input* string) + (let ((w1 (read-word))) + (cond ((equal w1 "Line") + (let ((line (read-word))) + (assert (equal (read-word) "of")) + (let* ((file (read-from-string (read-word))) + (pathname + (or (probe-file file) + (probe-file (format nil "target:lisp/~a" file)) + file))) + (make-location (list :file (unix-truename pathname)) + (list :line (parse-integer line)))))) + (t + `(:error ,string)))))) + +(defun read-word (&optional (stream *standard-input*)) + (peek-char t stream) + (concatenate 'string (loop until (whitespacep (peek-char nil stream)) + collect (read-char stream)))) + +(defun whitespacep (char) + (member char '(#\space #\newline))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod emacs-inspect ((o kernel:funcallable-instance)) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (cmucl-inspect o))) + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +#+(or) +(defmethod emacs-inspect ((o array)) + (if (typep o 'simple-array) + (call-next-method) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + +(defmethod emacs-inspect ((o simple-vector)) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +(defimplementation eval-context (obj) + (cond ((typep (class-of obj) 'structure-class) + (let* ((dd (kernel:layout-info (kernel:layout-of obj))) + (slots (kernel:dd-slots dd))) + (list* (cons '*package* + (symbol-package (if slots + (kernel:dsd-name (car slots)) + (kernel:dd-name dd)))) + (loop for slot in slots collect + (cons (kernel:dsd-name slot) + (funcall (kernel:dsd-accessor slot) obj)))))))) + + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + :methods methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (check-slime-interrupts) + (let* ((mbox (mailbox thread))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.5 + (lambda () (some test (mailbox.queue mbox))))))) + + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (swank::background-message message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (apply #'ext:save-lisp + filename + (if restart-function + `(:init-function ,restart-function)))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function c-call:int c-call:int + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include +#include +#include +#include +#include + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; FIXME: lisp:unicode-complete introduced in version 20d. +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defun match-semi-standard (prefix matchp) + ;; Handle the CMUCL's short character names. + (loop for name in lisp::char-name-alist + when (funcall matchp prefix (car name)) + collect (car name))) + +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defimplementation character-completion-set (prefix matchp) + (let ((names (lisp::unicode-complete prefix))) + ;; Match prefix against semistandard names. If there's a match, + ;; add it to our list of matches. + (let ((semi-standard (match-semi-standard prefix matchp))) + (when semi-standard + (setf names (append semi-standard names)))) + (setf names (mapcar #'string-capitalize names)) + (loop for n in names + when (funcall matchp prefix n) + collect n))) diff --git a/elpa/slime-20200319.1939/swank/corman.lisp b/elpa/slime-20200319.1939/swank/corman.lisp new file mode 100644 index 00000000..3e34f19a --- /dev/null +++ b/elpa/slime-20200319.1939/swank/corman.lisp @@ -0,0 +1,583 @@ +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank/backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) + cl::*top-level*) + collect + (make-frame + :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port &key backlog) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name + (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-position* 0))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location"))))))) + (funcall fn))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (output-file warnings? failure?) + (compile-file input-file :output-file output-file) + (values output-file warnings? + (or failure? (and load-p (load output-file)))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Inspecting + +;; Hack to make swank.lisp load, at least +(defclass file-stream ()) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot + ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class + ,(princ-to-string (class-name class))))) + '("#")) + (:newline))) + +(defmethod emacs-inspect ((slot cons)) + ;; Inspects slot definitions + (if (eq (car slot) :name) + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" + (:newline) + (:value + ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value + ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#") (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline)) + (call-next-method))) + +(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) + (list* (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + '(:newline) + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i)))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) diff --git a/elpa/slime-20200319.1939/swank/ecl.lisp b/elpa/slime-20200319.1939/swank/ecl.lisp new file mode 100644 index 00000000..0c5bb1ce --- /dev/null +++ b/elpa/slime-20200319.1939/swank/ecl.lisp @@ -0,0 +1,1098 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ecl.lisp --- SLIME backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/ecl + (:use cl swank/backend)) + +(in-package swank/ecl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ecl-version () + (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) + (if version + (symbol-value version) + 0))) + (when (< (ecl-version) 100301) + (error "~&IMPORTANT:~% ~ + The version of ECL you're using (~A) is too old.~% ~ + Please upgrade to at least 10.3.1.~% ~ + Sorry for the inconvenience.~%~%" + (lisp-implementation-version)))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event.fas") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + (and (< (ecl-version) 121201) + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes)))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; UTF8 + +;;; Convert the string STRING to a (simple-array (unsigned-byte 8)). +;;; +;;; string-to-utf8 (string) + +;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string. +;;; +;;; utf8-to-string (octets) + + +;;;; TCP Server + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) + +;;; Call FN whenever SOCKET is readable. +;;; +;;; add-sigio-handler (socket fn) + +;;; Remove all sigio handlers for SOCKET. +;;; +;;; remove-sigio-handlers (socket) + +;;; Call FN when Lisp is waiting for input and SOCKET is readable. +;;; +;;; add-fd-handler (socket fn) + +;;; Remove all fd-handlers for SOCKET. +;;; +;;; remove-fd-handlers (socket) + +(defimplementation preferred-communication-style () + (cond + ((member :threads *features*) :spawn) + ((member :windows *features*) nil) + (t #|:fd-handler|# nil))) + +;;; Set the 'stream 'timeout. The timeout is either the real number +;;; specifying the timeout in seconds or 'nil for no timeout. +;;; +;;; set-stream-timeout (stream timeout) + + +;;; Hook called when the first connection from Emacs is established. +;;; Called from the INIT-FN of the socket server that accepts the +;;; connection. +;;; +;;; This is intended for setting up extra context, e.g. to discover +;;; that the calling thread is the one that interacts with Emacs. +;;; +;;; emacs-connected () + + +;;;; Unix Integration + +(defimplementation getpid () + (si:getpid)) + +;;; Call FUNCTION on SIGINT (instead of invoking the debugger). +;;; Return old signal handler. +;;; +;;; install-sigint-handler (function) + +;;; XXX! +;;; If ECL is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as ECL's +;;; main-thread is also the Slime's REPL thread. + +(defun make-interrupt-handler (real-handler) + #+threads + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler))) + #-threads + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; Default implementation is fine. +;;; +;;; lisp-implementation-type-name +;;; lisp-implementation-program + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +;;; Create a character stream for the file descriptor FD. This +;;; interface implementation requires either `ffi:c-inline' or has to +;;; wait for the exported interface. +;;; +;;; make-fd-stream (socket-stream) + +;;; Duplicate a file descriptor. If the syscall fails, signal a +;;; condition. See dup(2). This interface requiers `ffi:c-inline' or +;;; has to wait for the exported interface. +;;; +;;; dup (fd) + +;;; Does not apply to ECL which doesn't dump images. +;;; +;;; exec-image (image-file args) + +(defimplementation command-line-args () + (ext:command-args)) + + +;;;; pathnames + +;;; Return a pathname for FILENAME. +;;; A filename in Emacs may for example contain asterisks which should not +;;; be translated to wildcards. +;;; +;;; filename-to-pathname (filename) + +;;; Return the filename for PATHNAME. +;;; +;;; pathname-to-filename (pathname) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + + +;;; Call FN with hooks to handle special syntax. Can we use it for +;;; `ffi:c-inline' to be handled as C/C++ code? +;;; +;;; call-with-syntax-hooks + +;;; Return a suitable initial value for SWANK:*READTABLE-ALIST*. +;;; +;;; default-readtable-alist + + +;;;; Packages + +#+package-local-nicknames +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-ecl-bytecmp +(defun handle-compiler-message (condition) + ;; ECL emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (c:compiler-fatal-error :error) + (c:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-ecl-bytecmp +(defun condition-location (condition) + (let ((file (c:compiler-message-file condition)) + (position (c:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + #+ecl-bytecmp + (funcall function) + #-ecl-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string + (string &key buffer position filename line column policy) + (declare (ignore line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (compile-file tmp-file + :load t + :source-truename (or filename + (note-buffer-tmpfile tmp-file buffer)) + :source-offset (1- position)))) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, ECL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;; Default implementation is fine +;;; +;;; guess-external-format + + +;;;; Streams + +;;; Implemented in `gray' +;;; +;;; make-output-stream +;;; make-input-stream + + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (ext:function-lambda-list name) + (if foundp arglist :not-available))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos:generic-function-name f)) + (function (si:compiled-function-name f)))) + +;;; Default implementation is fine (CL). +;;; +;;; valid-function-name-p (form) + +#+walker +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +;;; Default implementation is fine. +;;; +;;; compiler-macroexpand-1 +;;; compiler-macroexpand + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +;;; Expand the format string CONTROL-STRING. +;;; Default implementation is fine. +;;; +;;; format-string-expand + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + + +;;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name)))) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::bc-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (ihs-top)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (when file + (make-file-location file position)))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record (remove-if-not #'consp frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (si::fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) + +;;; Is the frame FRAME restartable?. +;;; Return T if `restart-frame' can safely be called on the frame. +;;; +;;; frame-restartable-p (frame) + +(defimplementation frame-source-location (frame-number) + (let ((frame (elt *backtrace* frame-number))) + (or (nth-value 1 (frame-function frame)) + (make-error-location "Unknown source location for ~A." (car frame))))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env + (elt *backtrace* frame-number))) + collect (list :name name :id 0 :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (destructuring-bind (name . value) + (elt + (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-number) + (declare (ignore name)) + value)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) + +;;; frame-package +;;; frame-call +;;; return-from-frame +;;; restart-frame +;;; print-condition +;;; condition-extras + +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +;;; active-stepping +;;; sldb-break-on-return +;;; sldb-break-at-start +;;; sldb-stepper-condition-p +;;; sldb-setp-into +;;; sldb-step-next +;;; sldb-step-out + + +;;;; Definition finding + +(defvar +TAGS+ (namestring + (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from ECL point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun make-TAGS-location (&rest tags) + (make-location `(:etags-file ,+TAGS+) + `(:tag ,@tags))) + +(defimplementation find-definitions (name) + (let ((annotations (ext:get-annotation name 'si::location :all))) + (cond (annotations + (loop for annotation in annotations + collect (destructuring-bind (dspec file . pos) annotation + `(,dspec ,(make-file-location file pos))))) + (t + (mapcan #'(lambda (type) (find-definitions-by-type name type)) + (classify-definition-name name)))))) + +(defun classify-definition-name (name) + (let ((types '())) + (when (fboundp name) + (cond ((special-operator-p name) + (push :special-operator types)) + ((macro-function name) + (push :macro types)) + ((typep (fdefinition name) 'generic-function) + (push :generic-function types)) + ((si:mangle-name name t) + (push :c-function types)) + (t + (push :lisp-function types)))) + (when (boundp name) + (cond ((constantp name) + (push :constant types)) + (t + (push :global-variable types)))) + types)) + +(defun find-definitions-by-type (name type) + (ecase type + (:lisp-function + (when-let (loc (source-location (fdefinition name))) + (list `((defun ,name) ,loc)))) + (:c-function + (when-let (loc (source-location (fdefinition name))) + (list `((c-source ,name) ,loc)))) + (:generic-function + (loop for method in (clos:generic-function-methods (fdefinition name)) + for specs = (clos:method-specializers method) + for loc = (source-location method) + when loc + collect `((defmethod ,name ,specs) ,loc))) + (:macro + (when-let (loc (source-location (macro-function name))) + (list `((defmacro ,name) ,loc)))) + (:constant + (when-let (loc (source-location name)) + (list `((defconstant ,name) ,loc)))) + (:global-variable + (when-let (loc (source-location name)) + (list `((defvar ,name) ,loc)))) + (:special-operator))) + +;;; FIXME: There ought to be a better way. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun c-function-name-p (name) + (and (symbolp name) (si:mangle-name name t) t)) + (defun c-function-p (object) + (and (functionp object) + (let ((fn-name (function-name object))) + (and fn-name (c-function-name-p fn-name)))))) + +(deftype c-function () + `(satisfies c-function-p)) + +(defun assert-source-directory () + (unless (probe-file #P"SRC:") + (error "ECL's source directory ~A does not exist. ~ + You can specify a different location via the environment ~ + variable `ECLSRCDIR'." + (namestring (translate-logical-pathname #P"SYS:"))))) + +(defun assert-TAGS-file () + (unless (probe-file +TAGS+) + (error "No TAGS file ~A found. It should have been installed with ECL." + +TAGS+))) + +(defun package-names (package) + (cons (package-name package) (package-nicknames package))) + +(defun source-location (object) + (converting-errors-to-error-location + (typecase object + (c-function + (assert-source-directory) + (assert-TAGS-file) + (let ((lisp-name (function-name object))) + (assert lisp-name) + (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) + (assert flag) + ;; In ECL's code base sometimes the mangled name is used + ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or + ;; @EXT::SYMBOL is used. We cannot predict here, so we just + ;; provide several candidates. + (apply #'make-TAGS-location + c-name + (loop with s = (symbol-name lisp-name) + for p in (package-names (symbol-package lisp-name)) + collect (format nil "~A::~A" p s) + collect (format nil "~(~A::~A~)" p s)))))) + (function + (multiple-value-bind (file pos) (ext:compiled-function-file object) + (cond ((not file) + (return-from source-location nil)) + ((tmpfile-to-buffer file) + (make-buffer-location (tmpfile-to-buffer file) pos)) + (t + (assert (probe-file file)) + (assert (not (minusp pos))) + (make-file-location file pos))))) + (method + ;; FIXME: This will always return NIL at the moment; ECL does not + ;; store debug information for methods yet. + (source-location (clos:method-function object))) + ((member nil t) + (multiple-value-bind (flag c-name) (si:mangle-name object) + (assert flag) + (make-TAGS-location c-name)))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + +;;; buffer-first-change + + +;;;; XREF + +;;; who-calls +;;; calls-who +;;; who-references +;;; who-binds +;;; who-sets +;;; who-macroexpands +;;; who-specializes +;;; list-callers +;;; list-callees + + +;;;; Profiling + +;;; XXX: use monitor.lisp (ccl,clisp) + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Trace + +;;; Toggle tracing of the function(s) given with SPEC. +;;; SPEC can be: +;;; (setf NAME) ; a setf function +;;; (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method +;;; (:defgeneric NAME) ; a generic function with all methods +;;; (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. +;;; (:labels TOPLEVEL LOCAL) +;;; (:flet TOPLEVEL LOCAL) +;;; +;;; toggle-trace (spec) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + +;;; Return a list of bindings corresponding to OBJECT's slots. +;;; eval-context (object) + +;;; Return a string describing the primitive type of object. +;;; describe-primitive-type (object) + + +;;;; Multithreading + +;;; Not needed in ECL +;;; +;;; initialize-multiprocessing + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + ;; thread-attributes + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + ;; receive + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-wait (mailbox.cvar mbox) mutex))))) + + ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using + ;; asynchronous interrupts. + ;; + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient. + ;; + ;; wake-thread (thread) + + ;; Copied from sbcl.lisp and adjusted to ECL. + (let ((alist '()) + (mutex (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (mutex) + (cdr (assoc name alist))))) + + ;; Not needed in ECL (?). + ;; + ;; set-default-initial-binding (var form) + + ) ; #+threads + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (flet ((poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready))))))) + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Locks + +#+threads +(defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + +;;;; Weak datastructures + +;;; XXX: this should work but causes SLIME REPL hang at some point of time. May +;;; be ECL or SLIME bug - disabling for now. +#+(and ecl-weak-hash (or)) +(progn + (defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weakness :key args)) + + (defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weakness :value args)) + + (defimplementation hash-table-weakness (hashtable) + (ext:hash-table-weakness hashtable))) + + +;;;; Character names + +;;; Default implementation is fine. +;;; +;;; character-completion-set (prefix matchp) + + +;;;; Heap dumps + +;;; Doesn't apply to ECL. +;;; +;;; save-image (filename &optional restart-function) +;;; background-save-image (filename &key restart-function completion-function) + + +;;;; Wrapping + +;;; Intercept future calls to SPEC and surround them in callbacks. +;;; Very much similar to so-called advices for normal functions. +;;; +;;; wrap (spec indicator &key before after replace) +;;; unwrap (spec indicator) +;;; wrapped-p (spec indicator) diff --git a/elpa/slime-20200319.1939/swank/gray.lisp b/elpa/slime-20200319.1939/swank/gray.lisp new file mode 100644 index 00000000..3c6c6976 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/gray.lisp @@ -0,0 +1,207 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/backend) + +#.(progn + (defvar *gray-stream-symbols* + '(fundamental-character-output-stream + stream-write-char + stream-write-string + stream-fresh-line + stream-force-output + stream-finish-output + + fundamental-character-input-stream + stream-read-char + stream-peek-char + stream-read-line + stream-listen + stream-unread-char + stream-clear-input + stream-line-column + stream-read-char-no-hang)) + nil) + +(defpackage swank/gray + (:use cl swank/backend) + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) + (:export . #.*gray-stream-symbols*)) + +(in-package swank/gray) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (lock :initform (make-lock :name "buffer write lock")) + (flush-thread :initarg :flush-thread + :initform nil + :accessor flush-thread) + (flush-scheduled :initarg :flush-scheduled + :initform nil + :accessor flush-scheduled))) + +(defun maybe-schedule-flush (stream) + (when (and (flush-thread stream) + (not (flush-scheduled stream))) + (setf (flush-scheduled stream) t) + (send (flush-thread stream) t))) + +(defmacro with-slime-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-lock-held lock (lambda () ,@body)))) + +(defmethod stream-write-char ((stream slime-output-stream) char) + (with-slime-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (if (= fill-pointer (length buffer)) + (finish-output stream) + (maybe-schedule-flush stream))) + char) + +(defmethod stream-write-string ((stream slime-output-stream) string + &optional start end) + (with-slime-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count) + (maybe-schedule-flush stream)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + +(defmethod stream-line-column ((stream slime-output-stream)) + (with-slime-output-stream stream column)) + +(defmethod stream-finish-output ((stream slime-output-stream)) + (with-slime-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0)) + (setf (flush-scheduled stream) nil)) + nil) + +#+(and sbcl sb-thread) +(defmethod stream-force-output :around ((stream slime-output-stream)) + ;; Workaround for deadlocks between the world-lock and auto-flush-thread + ;; buffer write lock. + ;; + ;; Another alternative would be to grab the world-lock here, but that's less + ;; future-proof, and could introduce other lock-ordering issues in the + ;; future. + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) + +(defmethod stream-force-output ((stream slime-output-stream)) + (stream-finish-output stream)) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (with-slime-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) + +(defclass slime-input-stream (fundamental-character-input-stream) + ((input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index input-fn) s + (when (= index (length buffer)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + + +;;; + +(defimplementation make-auto-flush-thread (stream) + (if (typep stream 'slime-output-stream) + (setf (flush-thread stream) + (spawn (lambda () (auto-flush-loop stream 0.08 t)) + :name "auto-flush-thread")) + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) + :name "auto-flush-thread"))) + +(defimplementation make-output-stream (write-string) + (make-instance 'slime-output-stream :output-fn write-string)) + +(defimplementation make-input-stream (read-string) + (make-instance 'slime-input-stream :input-fn read-string)) diff --git a/elpa/slime-20200319.1939/swank/lispworks.lisp b/elpa/slime-20200319.1939/swank/lispworks.lisp new file mode 100644 index 00000000..b9d82188 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/lispworks.lisp @@ -0,0 +1,1020 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/lispworks + (:use cl swank/backend)) + +(in-package swank/lispworks) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defimplementation gray-package-name () + "STREAM") + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :slot-boundp-using-class + :slot-value-using-class + :slot-makunbound-using-class + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:slot-boundp-using-class (class object slotd) + (clos:slot-boundp-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:slot-value-using-class (class object slotd) + (clos:slot-value-using-class class object + (clos:slot-definition-name slotd))) + +(defun (setf swank-mop:slot-value-using-class) (value class object slotd) + (setf (clos:slot-value-using-class class object + (clos:slot-definition-name slotd)) + value)) + +(defun swank-mop:slot-makunbound-using-class (class object slotd) + (clos:slot-makunbound-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *original-defimplementation* (macro-function 'defimplementation)) + (defmacro defimplementation (&whole whole name args &body body + &environment env) + (declare (ignore args body)) + `(progn + (dspec:record-definition '(defun ,name) (dspec:location) + :check-redefinition-p nil) + ,(funcall *original-defimplementation* whole env)))) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port &key backlog) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (cond ((not external-format) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))) + (t + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-flexi-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8)) + external-format))))))) + +(defun make-flexi-stream (stream external-format) + (unless (member :flexi-streams *features*) + (error "Cannot use external format ~A~ + without having installed flexi-streams in the inferior-lisp." + external-format)) + (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") + stream + :external-format + (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") + external-format))) + +;;; Coding Systems + +(defun valid-external-format-p (external-format) + (member external-format *external-format-to-coding-system* + :test #'equal :key #'car)) + +(defvar *external-format-to-coding-system* + '(((:latin-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") + ;;((:utf-8) "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + ;;((:euc-jp) "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + ;;((:ascii) "us-ascii") + ((:ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;; Unix signals + +(defun sigint-handler () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Swank request handler thread. + #-win32 + (sys::set-signal-handler +sigint+ + (make-sigint-handler mp:*current-process*))) + +#-win32 +(defimplementation install-sigint-handler (handler) + (sys::set-signal-handler +sigint+ + (let ((self mp:*current-process*)) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt self handler))))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defun map-list (function list) + "Map over proper and not proper lists." + (loop for (car . cdr) on list + collect (funcall function car) into result + when (null cdr) return result + when (atom cdr) return (nconc result (funcall function cdr)))) + +(defun replace-strings-with-symbols (tree) + (map-list + (lambda (x) + (typecase x + (list + (replace-strings-with-symbols x)) + (symbol + x) + (string + (intern x)) + (t + (intern (write-to-string x))))) + tree)) + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + (replace-strings-with-symbols arglist))))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (or (documentation sym kind)))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" + symbol + (lispworks:function-lambda-list symbol) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Debugging + +(defclass slime-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun slime-env (hook io-bindings) + (make-instance 'slime-env :name "SLIME Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts condition)) + (swank:swank-debugger-hook condition *debugger-hook*)) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply #'swank:y-or-n-p-in-emacs msg args)) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setf (env:environment) (slime-env function '()))) + +(defvar *sldb-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sldb-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (flet ((find-named-frame (name) + (do ((frame (dbg::debugger-stack-current-frame + dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + name))) + (nth-next-frame frame 1))))) + (or (find-named-frame 'invoke-debugger) + (find-named-frame 'swank::safe-backtrace) + ;; if we can't find a likely top frame, take any old frame + ;; at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sldb-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil) + (kind nil)) + (loop for arg in (dbg::call-frame-arglist frame) + if (eq kind '&rest) + nconc (handler-case + (dbg::dbg-eval arg frame) + (error (e) (list (format nil "<~A>" arg)))) + and do (loop-finish) + else + if (member arg '(&rest &optional &key)) + do (setq kind arg) + else + nconc + (handler-case + (nconc (and (eq kind '&key) + (list (cond ((symbolp arg) + (intern (symbol-name arg) :keyword)) + ((and (consp arg) (symbolp (car arg))) + (intern (symbol-name (car arg)) + :keyword)) + (t (caar arg))))) + (list (dbg::dbg-eval + (cond ((symbolp arg) arg) + ((and (consp arg) (symbolp (car arg))) + (car arg)) + (t (cadar arg))) + frame))) + (error (e) (list (format nil "<~A>" arg))))))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (prin1 (cons (dbg::call-frame-function-name frame) + (frame-actual-args frame)) + stream)) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-source-location (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee))) + (path (and (dbg::call-frame-p frame) + (dbg::call-frame-edit-path frame)))) + (if dspec + (frame-location dspec cname path)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defun function-name-package (name) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql hcl:subfunction)) + (destructuring-bind (name parent) (cdr name) + (declare (ignore name)) + (function-name-package parent))) + ((cons (eql lw:top-level-form)) nil) + (t nil))) + +(defimplementation frame-package (frame-number) + (let ((frame (nth-frame frame-number))) + (if (dbg::call-frame-p frame) + (function-name-package (dbg::call-frame-function-name frame))))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +(defimplementation disassemble-frame (frame-number) + (let* ((frame (nth-frame frame-number))) + (when (dbg::call-frame-p frame) + (let ((function (dbg::get-call-frame-function frame))) + (disassemble function))))) + +;;; Definition finding + +(defun frame-location (dspec callee-name edit-path) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name))) + (path (edit-path-to-cmucl-source-path edit-path))) + (make-dspec-location rdspec location + `(:call-site ,name :edit-path ,path))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +;; dbg::call-frame-edit-path is not documented but lets assume the +;; binary representation of the integer EDIT-PATH should be +;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the +;; same as cadadddr. Something is odd with the highest bit. +(defun edit-path-to-cmucl-source-path (edit-path) + (and edit-path + (cons 0 + (let ((n -1)) + (loop for i from (1- (integer-length edit-path)) downto 0 + if (logbitp i edit-path) do (incf n) + else collect (prog1 n (setq n 0))))))) + +;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-swank-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + (multiple-value-prog1 (progn ,@body) + (signal-error-data-base compiler::*error-database* + ,location) + (signal-undefined-functions compiler::*unknown-functions* + ,location)))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-swank-compilation-unit (input-file) + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (multiple-value-bind (condition path) + (if (consp c) (values (car c) (cdr c)) (values c nil)) + (funcall fn filename dspec condition path)))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + #-(or lispworks4 lispworks5) + (conditions:compiler-note :note) + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defvar *temp-file-format* '(:utf-8 :eol-style :lf)) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output + :if-exists :supersede + :external-format *temp-file-format*) + + (write-string string s) + (finish-output s)) + (multiple-value-bind (binary-filename warnings? failure?) + (compile-file filename :load t + :external-format *temp-file-format*) + (declare (ignore warnings?)) + (when binary-filename + (delete-file binary-filename)) + (not failure?))) + (delete-file filename))) + +(defun dspec-function-name-position (dspec fallback) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t fallback)))) + (null fallback) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +(defun skip-comments (stream) + (let ((pos0 (file-position stream))) + (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) + '(())) + (file-position stream (1- (file-position stream)))) + (t (file-position stream pos0))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (ignore-errors (dspec-stream-position stream dspec)))) + (if pos + (list :position (1+ pos)) + (dspec-function-name-position dspec `(:position 1))))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset) location + (declare (ignore _)) + (make-location `(:buffer ,buffer) + (dspec-function-name-position dspec `(:offset ,offset 0)) + hints))))) + +(defun make-dspec-progenitor-location (dspec location edit-path) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location + (if edit-path + (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition edit-path) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename) edit-path) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (cond ((sys::setf-symbol-p symbol) + (sys::setf-pair-from-underlying-name symbol)) + (t symbol))) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location + dspec + (or filename + (gethash (list unfun dspec) *undefined-functions-hash*)) + nil) + nil))) + htab)) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-swank-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +(defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #+Harlequin-Unix-Lisp (sys:callablep object) + #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) + (sys:compiled-code-p object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +(defun list-callees-internal (name) + (let ((callees '())) + (system::find-constant$funcallable + 'junk name + :test #'(lambda (junk constant) + (declare (ignore junk)) + (when (and (symbolp constant) + (fboundp constant)) + (pushnew (list 'function constant) callees :test 'equal)) + ;; Return nil so we iterate over all constants. + nil)) + callees)) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((class (find-class classname nil))) + (when class + (let ((methods (clos:class-direct-methods class))) + (xref-results (mapcar #'dspec:object-dspec methods)))))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector + +(defmethod emacs-inspect ((o t)) + (lispworks-inspect o)) + +(defmethod emacs-inspect ((o function)) + (lispworks-inspect o)) + +;; FIXME: slot-boundp-using-class in LW works with names so we can't +;; use our method in swank.lisp. +(defmethod emacs-inspect ((o standard-object)) + (lispworks-inspect o)) + +(defun lispworks-inspect (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name () fn)) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (make-mailbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(let ((alist '()) + (lock (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (lock) + (cdr (assoc name alist))))) + + +(defimplementation set-default-initial-binding (var form) + (setq mp:*process-initial-bindings* + (acons var `(eval (quote ,form)) + mp:*process-initial-bindings* ))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :idle (mp:process-idle-time thread))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args)) diff --git a/elpa/slime-20200319.1939/swank/match.lisp b/elpa/slime-20200319.1939/swank/match.lisp new file mode 100644 index 00000000..d6200db5 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/match.lisp @@ -0,0 +1,242 @@ +;; +;; SELECT-MATCH macro (and IN macro) +;; +;; Copyright 1990 Stephen Adams +;; +;; You are free to copy, distribute and make derivative works of this +;; source provided that this copyright notice is displayed near the +;; beginning of the file. No liability is accepted for the +;; correctness or performance of the code. If you modify the code +;; please indicate this fact both at the place of modification and in +;; this copyright message. +;; +;; Stephen Adams +;; Department of Electronics and Computer Science +;; University of Southampton +;; SO9 5NH, UK +;; +;; sra@ecs.soton.ac.uk +;; + +;; +;; Synopsis: +;; +;; (select-match expression +;; (pattern action+)*) +;; +;; --- or --- +;; +;; (select-match expression +;; pattern => expression +;; pattern => expression +;; ...) +;; +;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) +;; | symbol ;matches anything +;; | 'anything ;must be EQUAL +;; | (pattern = pattern) ;both patterns must match +;; | (#'function pattern) ;predicate test +;; | (pattern . pattern) ;cons cell +;; + +;; Example +;; +;; (select-match item +;; (('if e1 e2 e3) 'if-then-else) ;(1) +;; ((#'oddp k) 'an-odd-integer) ;(2) +;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) +;; (other 'anything-else)) ;(4) +;; +;; Notes +;; +;; . Each pattern is tested in turn. The first match is taken. +;; +;; . If no pattern matches, an error is signalled. +;; +;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. +;; numbers, strings, characters, etc.) match things which are EQUAL. +;; +;; . Quoted patterns (which are CONSTANTP) are constants. +;; +;; . Symbols match anything. The symbol is bound to the matched item +;; for the execution of the actions. +;; For example, (SELECT-MATCH '(1 2 3) +;; (1 . X) => X) +;; returns (2 3) because X is bound to the cdr of the candidate. +;; +;; . The two pattern match (p1 = p2) can be used to name parts +;; of the matched structure. For example, (ALL = (HD . TL)) +;; matches a cons cell. ALL is bound to the cons cell, HD to its car +;; and TL to its tail. +;; +;; . A predicate test applies the predicate to the item being matched. +;; If the predicate returns NIL then the match fails. +;; If it returns truth, then the nested pattern is matched. This is +;; often just a symbol like K in the example. +;; +;; . Care should be taken with the domain values for predicate matches. +;; If, in the above eg, item is not an integer, an error would occur +;; during the test. A safer pattern would be +;; (#'integerp (#'oddp k)) +;; This would only test for oddness of the item was an integer. +;; +;; . A single symbol will match anything so it can be used as a default +;; case, like OTHER above. +;; + +(in-package swank/match) + +(defmacro match (expression &body patterns) + `(select-match ,expression ,@patterns)) + +(defmacro select-match (expression &rest patterns) + (let* ((do-let (not (atom expression))) + (key (if do-let (gensym) expression)) + (cbody (expand-select-patterns key patterns)) + (cform `(cond . ,cbody))) + (if do-let + `(let ((,key ,expression)) ,cform) + cform))) + +(defun expand-select-patterns (key patterns) + (if (eq (second patterns) '=>) + (expand-select-patterns-style-2 key patterns) + (expand-select-patterns-style-1 key patterns))) + +(defun expand-select-patterns-style-1 (key patterns) + (if (null patterns) + `((t (error "Case select pattern match failure on ~S" ,key))) + (let* ((pattern (caar patterns)) + (actions (cdar patterns)) + (rest (cdr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-1 key rest)))))) + +(defun expand-select-patterns-style-2 (key patterns) + (cond ((null patterns) + `((t (error "Case select pattern match failure on ~S" ,key)))) + (t (when (or (< (length patterns) 3) + (not (eq (second patterns) '=>))) + (error "Illegal patterns: ~S" patterns)) + (let* ((pattern (first patterns)) + (actions (list (third patterns))) + (rest (cdddr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-2 key rest))))))) + +(defun compile-select-test (key pattern) + (let ((tests (remove t (compile-select-tests key pattern)))) + (cond + ;; note AND does this anyway, but this allows us to tell if + ;; the pattern will always match. + ((null tests) t) + ((= (length tests) 1) (car tests)) + (t `(and . ,tests))))) + +(defun compile-select-tests (key pattern) + (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) + ((symbolp pattern) 'eq) + (t 'equal)) + ,key ,pattern))) + ((symbolp pattern) '(t)) + ((select-double-match? pattern) + (append + (compile-select-tests key (first pattern)) + (compile-select-tests key (third pattern)))) + ((select-predicate? pattern) + (append + `((,(second (first pattern)) ,key)) + (compile-select-tests key (second pattern)))) + ((consp pattern) + (append + `((consp ,key)) + (compile-select-tests (cs-car key) (car + pattern)) + (compile-select-tests (cs-cdr key) (cdr + pattern)))) + (t (error "Illegal select pattern: ~S" pattern)))) + + +(defun compile-select-bindings (key pattern action) + (cond ((constantp pattern) '()) + ((symbolp pattern) + (if (select-in-tree pattern action) + `((,pattern ,key)) + '())) + ((select-double-match? pattern) + (append + (compile-select-bindings key (first pattern) action) + (compile-select-bindings key (third pattern) action))) + ((select-predicate? pattern) + (compile-select-bindings key (second pattern) action)) + ((consp pattern) + (append + (compile-select-bindings (cs-car key) (car pattern) + action) + (compile-select-bindings (cs-cdr key) (cdr pattern) + action))))) + +(defun select-in-tree (atom tree) + (or (eq atom tree) + (if (consp tree) + (or (select-in-tree atom (car tree)) + (select-in-tree atom (cdr tree)))))) + +(defun select-double-match? (pattern) + ;; ( = ) + (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) + (null (cdddr pattern)) + (eq (second pattern) '=))) + +(defun select-predicate? (pattern) + ;; ((function ) ) + (and (consp pattern) + (consp (cdr pattern)) + (null (cddr pattern)) + (consp (first pattern)) + (consp (cdr (first pattern))) + (null (cddr (first pattern))) + (eq (caar pattern) 'function))) + +(defun cs-car (exp) + (cs-car/cdr 'car exp + '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) + (cdar . cadar) (cddr . caddr) + (caaar . caaaar) (caadr . caaadr) (cadar . caadar) + (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) + (cddar . caddar) (cdddr . cadddr)))) + +(defun cs-cdr (exp) + (cs-car/cdr 'cdr exp + '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) + (cdar . cddar) (cddr . cdddr) + (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) + (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) + (cddar . cdddar) (cdddr . cddddr)))) + +(defun cs-car/cdr (op exp table) + (if (and (consp exp) (= (length exp) 2)) + (let ((replacement (assoc (car exp) table))) + (if replacement + `(,(cdr replacement) ,(second exp)) + `(,op ,exp))) + `(,op ,exp))) + +;; (setf c1 '(select-match x (a 1) (b 2 3 4))) +;; (setf c2 '(select-match (car y) +;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ +;; else)))) +;; (setf c3 '(select-match (caddr y) +;; ((all = (x y)) (list x y all)) +;; ((a '= b) (list 'assign a b)) +;; ((#'oddp k) (1+ k))))) + + diff --git a/elpa/slime-20200319.1939/swank/mezzano.lisp b/elpa/slime-20200319.1939/swank/mezzano.lisp new file mode 100644 index 00000000..df9fadbb --- /dev/null +++ b/elpa/slime-20200319.1939/swank/mezzano.lisp @@ -0,0 +1,700 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mezzano.lisp --- SLIME backend for Mezzano +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mezzano + (:use cl swank/backend)) + +(in-package swank/mezzano) + +;;; swank-mop + +(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs + :class-direct-default-initargs + :specializer-direct-methods + :generic-function-declarations)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + '()) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + '()) + +(defimplementation gray-package-name () + "MEZZANO.GRAY") + +;;;; TCP server + +(defclass listen-socket () + ((%listener :initarg :listener))) + +(defimplementation create-socket (host port &key backlog) + (make-instance 'listen-socket + :listener (mezzano.network.tcp:tcp-listen + host + port + :backlog (or backlog 10)))) + +(defimplementation local-port (socket) + (mezzano.network.tcp:tcp-listener-local-port (slot-value socket '%listener))) + +(defimplementation close-socket (socket) + (mezzano.network.tcp:close-tcp-listener (slot-value socket '%listener))) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore external-format buffering timeout)) + (loop + (let ((value (mezzano.network.tcp:tcp-accept (slot-value socket '%listener) + :wait-p nil))) + (if value + (return value) + ;; Poke standard-input every now and then to keep the console alive. + (progn (listen) + (sleep 0.05)))))) + +(defimplementation preferred-communication-style () + :spawn) + +;;;; Unix signals +;;;; ???? + +(defimplementation getpid () + 0) + +;;;; Compilation + +(defun signal-compiler-condition (condition severity) + (signal 'compiler-condition + :original-condition condition + :severity severity + :message (format nil "~A" condition) + :location nil)) + +(defimplementation call-with-compilation-hooks (func) + (handler-bind + ((error + (lambda (c) + (signal-compiler-condition c :error))) + (warning + (lambda (c) + (signal-compiler-condition c :warning))) + (style-warning + (lambda (c) + (signal-compiler-condition c :style-warning)))) + (funcall func))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore buffer line column policy)) + (let* ((*load-pathname* (ignore-errors (pathname filename))) + (*load-truename* (when *load-pathname* + (ignore-errors (truename *load-pathname*)))) + (sys.int::*top-level-form-number* `(:position ,position))) + (with-compilation-hooks () + (eval (read-from-string (concatenate 'string "(progn " string " )"))))) + t) + +(defimplementation swank-compile-file (input-file output-file load-p + external-format + &key policy) + (with-compilation-hooks () + (multiple-value-prog1 + (compile-file input-file + :output-file output-file + :external-format external-format) + (when load-p + (load output-file))))) + +(defimplementation find-external-format (coding-system) + (if (or (equal coding-system "utf-8") + (equal coding-system "utf-8-unix")) + :default + nil)) + +;;;; Debugging + +;; Definitely don't allow this. +(defimplementation install-debugger-globally (function) + (declare (ignore function)) + nil) + +(defvar *current-backtrace*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*current-backtrace* '())) + (let ((prev-fp nil)) + (sys.int::map-backtrace + (lambda (i fp) + (push (list (1- i) fp prev-fp) *current-backtrace*) + (setf prev-fp fp)))) + (setf *current-backtrace* (reverse *current-backtrace*)) + ;; Drop the topmost frame, which is finished call to MAP-BACKTRACE. + (pop *current-backtrace*) + ;; And the next one for good measure. + (pop *current-backtrace*) + (funcall debugger-loop-fn))) + +(defimplementation compute-backtrace (start end) + (subseq *current-backtrace* start end)) + +(defimplementation print-frame (frame stream) + (format stream "~S" (sys.int::function-from-frame frame))) + +(defimplementation frame-source-location (frame-number) + (let* ((frame (nth frame-number *current-backtrace*)) + (fn (sys.int::function-from-frame frame))) + (function-location fn))) + +(defimplementation frame-locals (frame-number) + (loop + with frame = (nth frame-number *current-backtrace*) + for (name id location repr) in (sys.int::frame-locals frame) + collect (list :name name + :id id + :value (sys.int::read-frame-slot frame location repr)))) + +(defimplementation frame-var-value (frame-number var-id) + (let* ((frame (nth frame-number *current-backtrace*)) + (locals (sys.int::frame-locals frame)) + (info (nth var-id locals))) + (if info + (destructuring-bind (name id location repr) + info + (declare (ignore id)) + (values (sys.int::read-frame-slot frame location repr) name)) + (error "Invalid variable id ~D for frame number ~D." + var-id frame-number)))) + +;;;; Definition finding + +(defun top-level-form-position (pathname tlf) + (ignore-errors + (with-open-file (s pathname) + (loop + repeat tlf + do (with-standard-io-syntax + (let ((*read-suppress* t) + (*read-eval* nil)) + (read s nil)))) + (let ((default (make-pathname :host (pathname-host s)))) + (make-location `(:file ,(enough-namestring s default)) + `(:position ,(1+ (file-position s)))))))) + +(defun function-location (function) + "Return a location object for FUNCTION." + (let* ((info (sys.int::function-debug-info function)) + (pathname (sys.int::debug-info-source-pathname info)) + (tlf (sys.int::debug-info-source-top-level-form-number info))) + (cond ((and (consp tlf) + (eql (first tlf) :position)) + (let ((default (make-pathname :host (pathname-host pathname)))) + (make-location `(:file ,(enough-namestring pathname default)) + `(:position ,(second tlf))))) + (t + (top-level-form-position pathname tlf))))) + +(defun method-definition-name (name method) + `(defmethod ,name + ,@(mezzano.clos:method-qualifiers method) + ,(mapcar (lambda (x) + (typecase x + (mezzano.clos:class + (mezzano.clos:class-name x)) + (mezzano.clos:eql-specializer + `(eql ,(mezzano.clos:eql-specializer-object x))) + (t x))) + (mezzano.clos:method-specializers method)))) + +(defimplementation find-definitions (name) + (let ((result '())) + (labels + ((frob-fn (dspec fn) + (let ((loc (function-location fn))) + (when loc + (push (list dspec loc) result)))) + (try-fn (name) + (when (valid-function-name-p name) + (when (and (fboundp name) + (not (and (symbolp name) + (or (special-operator-p name) + (macro-function name))))) + (let ((fn (fdefinition name))) + (cond ((typep fn 'mezzano.clos:standard-generic-function) + (dolist (m (mezzano.clos:generic-function-methods fn)) + (frob-fn (method-definition-name name m) + (mezzano.clos:method-function m)))) + (t + (frob-fn `(defun ,name) fn))))) + (when (compiler-macro-function name) + (frob-fn `(define-compiler-macro ,name) + (compiler-macro-function name)))))) + (try-fn name) + (try-fn `(setf name)) + (try-fn `(sys.int::cas name)) + (when (and (symbolp name) + (get name 'sys.int::setf-expander)) + (frob-fn `(define-setf-expander ,name) + (get name 'sys.int::setf-expander))) + (when (and (symbolp name) + (macro-function name)) + (frob-fn `(defmacro ,name) + (macro-function name)))) + result)) + +;;;; XREF +;;; Simpler variants. + +(defun find-all-frefs () + (let ((frefs (make-array 500 :adjustable t :fill-pointer 0)) + (keep-going t)) + (loop + (when (not keep-going) + (return)) + (adjust-array frefs (* (array-dimension frefs 0) 2)) + (setf keep-going nil + (fill-pointer frefs) 0) + ;; Walk the wired area looking for FREFs. + (sys.int::walk-area + :wired + (lambda (object address size) + (when (sys.int::function-reference-p object) + (when (not (vector-push object frefs)) + (setf keep-going t)))))) + (remove-duplicates (coerce frefs 'list)))) + +(defimplementation list-callers (function-name) + (let ((fref-for-fn (sys.int::function-reference function-name)) + (callers '())) + (loop + for fref in (find-all-frefs) + for fn = (sys.int::function-reference-function fref) + for name = (sys.int::function-reference-name fref) + when fn + do + (cond ((typep fn 'standard-generic-function) + (dolist (m (mezzano.clos:generic-function-methods fn)) + (let* ((mf (mezzano.clos:method-function m)) + (mf-frefs (get-all-frefs-in-function mf))) + (when (member fref-for-fn mf-frefs) + (push `((defmethod ,name + ,@(mezzano.clos:method-qualifiers m) + ,(mapcar #'specializer-name + (mezzano.clos:method-specializers m))) + ,(function-location mf)) + callers))))) + ((member fref-for-fn + (get-all-frefs-in-function fn)) + (push `((defun ,name) ,(function-location fn)) callers)))) + callers)) + +(defun specializer-name (specializer) + (if (typep specializer 'standard-class) + (mezzano.clos:class-name specializer) + specializer)) + +(defun get-all-frefs-in-function (function) + (when (sys.int::funcallable-std-instance-p function) + (setf function (sys.int::funcallable-std-instance-function function))) + (when (sys.int::closure-p function) + (setf function (sys.int::%closure-function function))) + (loop + for i below (sys.int::function-pool-size function) + for entry = (sys.int::function-pool-object function i) + when (sys.int::function-reference-p entry) + collect entry + when (compiled-function-p entry) ; closures + append (get-all-frefs-in-function entry))) + +(defimplementation list-callees (function-name) + (let* ((fn (fdefinition function-name)) + ;; Grovel around in the function's constant pool looking for + ;; function-references. These may be for #', but they're + ;; probably going to be for normal calls. + ;; TODO: This doesn't work well on interpreted functions or + ;; funcallable instances. + (callees (remove-duplicates (get-all-frefs-in-function fn)))) + (loop + for fref in callees + for name = (sys.int::function-reference-name fref) + for fn = (sys.int::function-reference-function fref) + when fn + collect `((defun ,name) ,(function-location fn))))) + +;;;; Documentation + +(defimplementation arglist (name) + (let ((macro (when (symbolp name) + (macro-function name))) + (fn (if (functionp name) + name + (ignore-errors (fdefinition name))))) + (cond + (macro + (get name 'sys.int::macro-lambda-list)) + (fn + (cond + ((typep fn 'mezzano.clos:standard-generic-function) + (mezzano.clos:generic-function-lambda-list fn)) + (t + (function-lambda-list fn)))) + (t :not-available)))) + +(defun function-lambda-list (function) + (sys.int::debug-info-lambda-list + (sys.int::function-debug-info function))) + +(defimplementation type-specifier-p (symbol) + (cond + ((or (get symbol 'sys.int::type-expander) + (get symbol 'sys.int::compound-type) + (get symbol 'sys.int::type-symbol)) + t) + (t :not-available))) + +(defimplementation function-name (function) + (sys.int::function-name function)) + +(defimplementation valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (or (eq (first form) 'setf) + (eq (first form) 'sys.int::cas)) + (symbolp (second form)))))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (when (boundp symbol) + (setf (getf result :variable) nil)) + (when (and (fboundp symbol) + (not (macro-function symbol))) + (setf (getf result :function) + (function-docstring symbol))) + (when (fboundp `(setf ,symbol)) + (setf (getf result :setf) + (function-docstring `(setf ,symbol)))) + (when (get symbol 'sys.int::setf-expander) + (setf (getf result :setf) nil)) + (when (special-operator-p symbol) + (setf (getf result :special-operator) nil)) + (when (macro-function symbol) + (setf (getf result :macro) nil)) + (when (compiler-macro-function symbol) + (setf (getf result :compiler-macro) nil)) + (when (type-specifier-p symbol) + (setf (getf result :type) nil)) + (when (find-class symbol nil) + (setf (getf result :class) nil)) + result)) + +(defun function-docstring (function-name) + (let* ((definition (fdefinition function-name)) + (debug-info (sys.int::function-debug-info definition))) + (sys.int::debug-info-docstring debug-info))) + +;;;; Multithreading + +;; FIXME: This should be a weak table. +(defvar *thread-ids-for-emacs* (make-hash-table)) +(defvar *next-thread-id-for-emacs* 0) +(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex + "SWANK thread ID table")) + +(defimplementation spawn (fn &key name) + (mezzano.supervisor:make-thread fn :name name)) + +(defimplementation thread-id (thread) + (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*) + (let ((id (gethash thread *thread-ids-for-emacs*))) + (when (null id) + (setf id (incf *next-thread-id-for-emacs*) + (gethash thread *thread-ids-for-emacs*) id + (gethash id *thread-ids-for-emacs*) thread)) + id))) + +(defimplementation find-thread (id) + (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*) + (gethash id *thread-ids-for-emacs*))) + +(defimplementation thread-name (thread) + (mezzano.supervisor:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "~:(~A~)" (mezzano.supervisor:thread-state thread))) + +(defimplementation current-thread () + (mezzano.supervisor:current-thread)) + +(defimplementation all-threads () + (mezzano.supervisor:all-threads)) + +(defimplementation thread-alive-p (thread) + (not (eql (mezzano.supervisor:thread-state thread) :dead))) + +(defimplementation interrupt-thread (thread fn) + (mezzano.supervisor:establish-thread-foothold thread fn)) + +(defimplementation kill-thread (thread) + ;; Documentation says not to execute unwind-protected sections, but there's + ;; no way to do that. + ;; And killing threads at arbitrary points without unwinding them is a good + ;; way to hose the system. + (mezzano.supervisor:terminate-thread thread)) + +(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock")) +(defvar *mailboxes* (list)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mezzano.supervisor:make-mutex)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + ;; Use weak pointers to avoid holding on to dead threads forever. + (mezzano.supervisor:with-mutex (*mailbox-lock*) + ;; Flush forgotten threads. + (setf *mailboxes* + (remove-if-not #'sys.int::weak-pointer-value *mailboxes*)) + (loop + for entry in *mailboxes* + do + (multiple-value-bind (key value livep) + (sys.int::weak-pointer-pair entry) + (when (eql key thread) + (return value))) + finally + (let ((mb (make-mailbox :thread thread))) + (push (sys.int::make-weak-pointer thread mb) *mailboxes*) + (return mb))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mezzano.supervisor:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defvar *receive-if-sleep-time* 0.02) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mezzano.supervisor:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t)))) + (sleep *receive-if-sleep-time*)))) + +(defvar *registered-threads* (make-hash-table)) +(defvar *registered-threads-lock* + (mezzano.supervisor:make-mutex "registered threads lock")) + +(defimplementation register-thread (name thread) + (declare (type symbol name)) + (mezzano.supervisor:with-mutex (*registered-threads-lock*) + (etypecase thread + (null + (remhash name *registered-threads*)) + (mezzano.supervisor:thread + (setf (gethash name *registered-threads*) thread)))) + nil) + +(defimplementation find-registered (name) + (mezzano.supervisor:with-mutex (*registered-threads-lock*) + (values (gethash name *registered-threads*)))) + +(defimplementation wait-for-input (streams &optional timeout) + (loop + (let ((ready '())) + (dolist (s streams) + (when (or (listen s) + (and (typep s 'mezzano.network.tcp::tcp-stream) + (mezzano.network.tcp::tcp-connection-closed-p s))) + (push s ready))) + (when ready + (return ready)) + (when (check-slime-interrupts) + (return :interrupt)) + (when timeout + (return '())) + (sleep 1) + (when (numberp timeout) + (decf timeout 1) + (when (not (plusp timeout)) + (return '())))))) + +;;;; Locks + +(defstruct recursive-lock + mutex + (depth 0)) + +(defimplementation make-lock (&key name) + (make-recursive-lock + :mutex (mezzano.supervisor:make-mutex name))) + +(defimplementation call-with-lock-held (lock function) + (cond ((mezzano.supervisor:mutex-held-p + (recursive-lock-mutex lock)) + (unwind-protect + (progn (incf (recursive-lock-depth lock)) + (funcall function)) + (decf (recursive-lock-depth lock)))) + (t + (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock)) + (multiple-value-prog1 + (funcall function) + (assert (eql (recursive-lock-depth lock) 0))))))) + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + ;; TODO: Unicode characters too. + (loop + for names in sys.int::*char-name-alist* + append + (loop + for name in (rest names) + when (funcall matchp prefix name) + collect name))) + +;;;; Inspector + +(defmethod emacs-inspect ((o function)) + (case (sys.int::%object-tag o) + (#.sys.int::+object-tag-function+ + (label-value-line* + (:name (sys.int::function-name o)) + (:arglist (arglist o)) + (:debug-info (sys.int::function-debug-info o)))) + (#.sys.int::+object-tag-closure+ + (append + (label-value-line :function (sys.int::%closure-function o)) + `("Closed over values:" (:newline)) + (loop + for i below (sys.int::%closure-length o) + append (label-value-line i (sys.int::%closure-value o i))))) + (t + (call-next-method)))) + +(defmethod emacs-inspect ((o sys.int::weak-pointer)) + (label-value-line* + (:key (sys.int::weak-pointer-key o)) + (:value (sys.int::weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sys.int::function-reference)) + (label-value-line* + (:name (sys.int::function-reference-name o)) + (:function (sys.int::function-reference-function o)))) + +(defmethod emacs-inspect ((object structure-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(swank::all-slots-for-inspector object)))) + +(in-package :swank) + +(defmethod all-slots-for-inspector ((object structure-object)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (swank-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'swank-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (swank-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) diff --git a/elpa/slime-20200319.1939/swank/mkcl.lisp b/elpa/slime-20200319.1939/swank/mkcl.lisp new file mode 100644 index 00000000..3b9df978 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/mkcl.lisp @@ -0,0 +1,933 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mkcl.lisp --- SLIME backend for MKCL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mkcl + (:use cl swank/backend)) + +(in-package swank/mkcl) + +;;(declaim (optimize (debug 3))) + +(defvar *tmp*) + +(defimplementation gray-package-name () + '#:gray) + +(eval-when (:compile-toplevel :load-toplevel) + + (swank/backend::import-swank-mop-symbols :clos + ;; '(:eql-specializer + ;; :eql-specializer-object + ;; :generic-function-declarations + ;; :specializer-direct-methods + ;; :compute-applicable-methods-using-classes) + nil + )) + + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (mkcl:octets (si:utf-8 string))) + +(defimplementation utf8-to-string (octets) + (string (si:utf-8 octets))) + + +;;;; TCP Server + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the sb-bsd-sockets package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'sockets)) + + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EINTR." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t ;; bogus + :input t ;; bogus + :buffering buffering ;; bogus + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format + )) + +(defimplementation preferred-communication-style () + :spawn + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (si:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, MKCL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + + +;;;; Unix signals + +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + +(defimplementation getpid () + (mkcl:getpid)) + +(defimplementation set-default-directory (directory) + (mk-ext::chdir (namestring directory)) + (default-directory)) + +(defimplementation default-directory () + (namestring (mk-ext:getcwd))) + +(defmacro progf (plist &rest forms) + `(let (_vars _vals) + (do ((p ,plist (cddr p))) + ((endp p)) + (push (car p) _vars) + (push (cadr p) _vals)) + (progv _vars _vals ,@forms) + ) + ) + +(defvar *inferior-lisp-sleeping-post* nil) + +(defimplementation quit-lisp () + (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams. + (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) + ;;(mk-ext:quit :verbose t) + )) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +#| +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) +|# + +#| +(defun condition-location (condition) + (let ((file (compiler:compiler-message-file condition)) + (position (compiler:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) +|# + +(defun condition-location (condition) + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* ; + ;; (if compiler::*current-function* ; + ;; (make-location (list :file *compile-filename*) ; + ;; (list :function-name ; + ;; (symbol-name ; + ;; (slot-value compiler::*current-function* ; + ;; 'compiler::name)))) ; + (if (typep condition 'compiler::compiler-message) + (make-location (list :file (namestring (compiler:compiler-message-file condition))) + (list :end-position (compiler:compiler-message-file-end-position condition))) + (list :error "No location found.")) + ) + ) + +(defun handle-compiler-message (condition) + (unless (typep condition 'compiler::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (compiler:compiler-fatal-error :error) + (compiler:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((compiler:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (handler-bind (#| + (compiler::compiler-note + #'(lambda (n) + (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil)) + (compiler::compiler-warning + #'(lambda (w) + (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil)) + (compiler::compiler-error + #'(lambda (e) + (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil)) + |# + ) + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file input-file :output-file output-file :external-format external-format) + (values output-truename warnings-p + (or failure-p + (and load-p (not (load output-truename)))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (when position (file-position position)) + (compile-from-stream s))))) + +(defun compile-from-stream (stream) + (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX")) + output-truename + warnings-p + failure-p + ) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (progn + (multiple-value-setq (output-truename warnings-p failure-p) + (compile-file file)) + (and (not failure-p) (load output-truename))) + (when (probe-file file) (delete-file file)) + (when (probe-file output-truename) (delete-file output-truename))))) + + +;;;; Documentation + +(defun grovel-docstring-for-arglist (name type) + (flet ((compute-arglist-offset (docstring) + (when docstring + (let ((pos1 (search "Args: " docstring))) + (if pos1 + (+ pos1 6) + (let ((pos2 (search "Syntax: " docstring))) + (when pos2 + (+ pos2 8)))))))) + (let* ((docstring (si::get-documentation name type)) + (pos (compute-arglist-offset docstring))) + (if pos + (multiple-value-bind (arglist errorp) + (ignore-errors + (values (read-from-string docstring t nil :start pos))) + (if (or errorp (not (listp arglist))) + :not-available + arglist + )) + :not-available )))) + +(defimplementation arglist (name) + (cond ((and (symbolp name) (special-operator-p name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((and (symbolp name) (macro-function name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((or (functionp name) (fboundp name)) + (multiple-value-bind (name fndef) + (if (functionp name) + (values (function-name name) name) + (values name (fdefinition name))) + (let ((fle (function-lambda-expression fndef))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t (typecase fndef + (generic-function (clos::generic-function-lambda-list fndef)) + (compiled-function (grovel-docstring-for-arglist name 'function)) + (function :not-available))))))) + (t :not-available))) + +(defimplementation function-name (f) + (si:compiled-function-name f) + ) + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the walker package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'walker)) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:macroexpand-all form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + #+(or) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name))) + nil) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::compiled-function-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defmacro find-ihs-top (x) + (declare (ignore x)) + '(si::ihs-top)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* (;;(*tpl-commands* si::tpl-commands) + (*ihs-base* 0) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + ;;(*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* to *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (mkcl:fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *tmp* *backtrace*) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) + (funcall fun))) + +(defimplementation compute-backtrace (start end) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (loop for f in (subseq *backtrace* start end) + collect f)) + +(defimplementation format-sldb-condition (condition) + "Format a condition for display in SLDB." + ;;(princ-to-string condition) + (format nil "~A~%In thread: ~S" condition mt:*thread*) + ) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::compiled-function-file fun) + (and file (make-location + `(:file ,(if (stringp file) file (namestring file))) + ;;`(:position ,position) + `(:end-position , position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record frame) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (mkcl:fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (let ((function (first frame))) + (let ((fname +;;; (cond ((symbolp function) function) +;;; ((si:instancep function) (slot-value function 'name)) +;;; ((compiled-function-p function) +;;; (or (si::compiled-function-name function) 'lambda)) +;;; (t :zombi)) + (si::get-fname function) + )) + (if (eq fname 'si::bytecode) + (format stream "~A [Evaluation of: ~S]" + fname (function-lambda-expression function)) + (format stream "~A" fname) + ) + (when (si::closurep function) + (format stream + ", closure generated from ~A" + (si::get-fname (si:closure-producer function))) + ) + ) + ) + ) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-in-env form env))) + +#| +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) +|# + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (list* + (format nil "~S is an ordinary stream~%" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + ((si:instancep o) ;;t + (let* ((cl (si:instance-class o)) + (slots (clos::class-slots cl))) + (list* (format nil "~S is an instance of class ~A~%" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos::slot-definition-name x)) + (value (if (slot-boundp o name) + (clos::slot-value o name) + "Unbound" + ))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))) + (t (list (format nil "~A" o))))) + +;;;; Definitions + +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) + +(defimplementation find-source-location (obj) + (setf *tmp* obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) + (if (and file pos) + (make-location + `(:file ,(if (stringp file) file (namestring file))) + `(:end-position ,pos) ;; `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (file-position s pos) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + +;;;; Profiling + + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the profile package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'profile)) + + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) + + +;;;; Threads + +(defvar *thread-id-counter* 0) + +(defvar *thread-id-counter-lock* + (mt:make-lock :name "thread id counter lock")) + +(defun next-thread-id () + (mt:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*)) + ) + +(defparameter *thread-id-map* (make-hash-table)) +(defparameter *id-thread-map* (make-hash-table)) + +(defvar *thread-id-map-lock* + (mt:make-lock :name "thread id map lock")) + +(defparameter +default-thread-local-variables+ + '(*macroexpand-hook* + *default-pathname-defaults* + *readtable* + *random-state* + *compile-print* + *compile-verbose* + *load-print* + *load-verbose* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + )) + +(defun thread-local-default-bindings () + (let (local) + (dolist (var +default-thread-local-variables+ local) + (setq local (acons var (symbol-value var) local)) + ))) + +;; mkcl doesn't have weak pointers +(defimplementation spawn (fn &key name initial-bindings) + (let* ((local-defaults (thread-local-default-bindings)) + (thread + ;;(mt:make-thread :name name) + (mt:make-thread :name name + :initial-bindings (nconc initial-bindings + local-defaults)) + ) + (id (next-thread-id))) + (mt:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) + (mt:thread-preset + thread + #'(lambda () + (unwind-protect + (progn + ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) + (mt:thread-detach nil) + (funcall fn)) + (progn + ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) + (mt:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) + (remhash id *thread-id-map*)) + ;;(format t "~&Finished thread: ~S~%" name) (finish-output) + )))) + (mt:thread-enable thread) + (mt:thread-yield) + thread + )) + +(defimplementation thread-id (thread) + (block thread-id + (mt:with-lock (*thread-id-map-lock*) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) + +(defimplementation find-thread (id) + (mt:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + +(defimplementation thread-name (thread) + (mt:thread-name thread)) + +(defimplementation thread-status (thread) + (if (mt:thread-active-p thread) + "RUNNING" + "STOPPED")) + +(defimplementation make-lock (&key name) + (mt:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mt:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mt:*thread*) + +(defimplementation all-threads () + (mt:all-threads)) + +(defimplementation interrupt-thread (thread fn) + (mt:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (mt:interrupt-thread thread #'mt:terminate-thread) + ) + +(defimplementation thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) +(defvar *mailboxes* (list)) +(declaim (type list *mailboxes*)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + locked-by + (mutex (mt:make-lock :name "thread mailbox")) + (semaphore (mt:make-semaphore)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mt:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (handler-case + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) +;; (mt:interrupt-thread +;; thread +;; (lambda () +;; (mt:with-lock (mutex) +;; (setf (mailbox.queue mbox) +;; (nconc (mailbox.queue mbox) (list message)))))) + +;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" +;; mt:*thread* thread message) (finish-output) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + ;;(format t "*") (finish-output) + (handler-case + (mt:semaphore-signal (mailbox.semaphore mbox)) + (condition (condition) + (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) + ;;(break) + )) + (setf (mailbox.locked-by mbox) nil) + ) + ;;(format t "+") (finish-output) + ) + (condition (condition) + (format t "~&Error in send: ~S~%" condition) (finish-output)) + ) + ) + +;; (defimplementation receive () +;; (block got-mail +;; (let* ((mbox (mailbox mt:*thread*)) +;; (mutex (mailbox.mutex mbox))) +;; (loop +;; (mt:with-lock (mutex) +;; (if (mailbox.queue mbox) +;; (return-from got-mail (pop (mailbox.queue mbox))))) +;; ;;interrupt-thread will halt this if it takes longer than 1sec +;; (sleep 1))))) + + +(defimplementation receive-if (test &optional timeout) + (handler-case + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + got-one) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) + (handler-case + (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) + (condition (condition) + (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) + (finish-output) + nil + ) + ) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (setf (mailbox.locked-by mbox) nil) + ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) + (return (car tail)))) + (setf (mailbox.locked-by mbox) nil) + ) + + ;;(format t "/ ~S~%" mt:*thread*) (finish-output) + (when (eq timeout t) (return (values nil t))) +;; (unless got-one +;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%")) + ) + ) + (condition (condition) + (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) + nil + ) + ) + ) + + +(defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + +;; + +;;#+windows +(defimplementation doze-in-repl () + (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) + ;;(loop (sleep 1)) + (mt:semaphore-wait *inferior-lisp-sleeping-post*) + (mk-ext:quit :verbose t) + ) + diff --git a/elpa/slime-20200319.1939/swank/rpc.lisp b/elpa/slime-20200319.1939/swank/rpc.lisp new file mode 100644 index 00000000..e30cc2cc --- /dev/null +++ b/elpa/slime-20200319.1939/swank/rpc.lisp @@ -0,0 +1,162 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/rpc) + + +;;;;; Input + +(define-condition swank-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader swank-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader swank-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'swank-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (swank/backend:utf8-to-string octets) + (error (c) + (error 'swank-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *validate-input* nil + "Set to true to require input that more strictly conforms to the protocol") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *validate-input* + (validating-read string) + (read-from-string string))))) + +(defun validating-read (string) + (with-input-from-string (*standard-input* string) + (simple-read))) + +(defun simple-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (let ((c (read-char))) + (case c + (#\( (loop collect (simple-read) + while (ecase (read-char) + (#\) nil) + (#\space t)))) + (#\' `(quote ,(simple-read))) + (t + (cond + ((digit-char-p c) + (parse-integer + (map 'simple-string #'identity + (loop for ch = c then (read-char nil nil) + while (and ch (digit-char-p ch)) + collect ch + finally (unread-char ch))))) + ((or (member c '(#\: #\")) (alpha-char-p c)) + (unread-char c) + (read-preserving-whitespace)) + (t (error "Invalid character ~:c" c))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (swank/backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (swank/backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# diff --git a/elpa/slime-20200319.1939/swank/sbcl.lisp b/elpa/slime-20200319.1939/swank/sbcl.lisp new file mode 100644 index 00000000..2bc0ec22 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/sbcl.lisp @@ -0,0 +1,2037 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(defpackage swank/sbcl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/sbcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) + (sb-c::insert-step-conditions 0) + (sb-c::insert-debug-catch 0))) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (with-symbol 'enable-stepping 'sb-impl)) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (with-symbol 'hash-table-weakness 'sb-ext)) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (with-symbol 'who-calls 'sb-introspect)) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (with-symbol 'frame-has-debug-tag-p 'sb-debug)) + ;; ... for :setf :inverse info (1.1.17) + (defun sbcl-with-setf-inverse-meta-info () + (boolean-to-feature-expression + ;; going through FIND-SYMBOL since META-INFO was renamed from + ;; TYPE-INFO in 1.2.10. + (let ((sym (find-symbol "META-INFO" "SB-C"))) + (and sym + (fboundp sym) + (funcall sym :setf :inverse ())))))) + +;;; swank-mop + +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;; stream support + +(defimplementation gray-package-name () + "SB-GRAY") + +;; Pretty printer calls this, apparently +(defmethod sb-gray:stream-line-length + ((s sb-gray:fundamental-character-input-stream)) + nil) + +;;; Connection info + +(defimplementation lisp-implementation-type-name () + "sbcl") + +;; Declare return type explicitly to shut up STYLE-WARNINGS about +;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. +(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) +(defimplementation getpid () + (sb-posix:getpid)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format '(:utf8 :replacement + #+sb-unicode #\Replacement_Character + #-sb-unicode #\? ))) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format '(:utf8 :replacement + #+sb-unicode #\Replacement_Character + #-sb-unicode #\? ))) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :sb-thread *features*) :spawn) + ((member :win32 *features*) nil) + (t :fd-handler))) + + +(defun resolve-hostname (host) + "Returns valid IPv4 or IPv6 address for the host." + ;; get all IPv4 and IPv6 addresses as a list + (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host))) + ;; remove protocols for which we don't have an address + (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents))) + ;; Return the first one or nil, + ;; but actually, it shouln't return nil, because + ;; get-host-by-name will signal NAME-SERVICE-ERROR condition + ;; if there isn't any address for the host. + (first addresses))) + + +(defimplementation create-socket (host port &key backlog) + (let* ((host-ent (resolve-hostname host)) + (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets) + ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10) + 'sb-bsd-sockets:inet6-socket) + (t + 'sb-bsd-sockets:inet-socket)) + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port) + + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) + + +;; The SIGIO stuff should probably be removed as it's unlikey that +;; anybody uses it. +#-win32 +(progn + (defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (sb-sys:invoke-interruption + (lambda () + (sb-sys:with-interrupts + (funcall function))))))) + + (defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + + (defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (sb-sys:with-interrupts + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*))) + + (defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) + + (defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid)) + (values)) + + (defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + + (defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket))) + + +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + +(defvar *wait-for-input-called*) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (when (boundp '*wait-for-input-called*) + (setq *wait-for-input-called* t)) + (let ((*wait-for-input-called* nil)) + (loop + (let ((ready (remove-if-not #'input-ready-p streams))) + (when ready (return ready))) + (when (check-slime-interrupts) + (return :interrupt)) + (when *wait-for-input-called* + (return :interrupt)) + (when timeout + (return nil)) + (sleep 0.1)))) + +(defun fd-stream-input-buffer-empty-p (stream) + (let ((buffer (sb-impl::fd-stream-ibuf stream))) + (or (not buffer) + (= (sb-impl::buffer-head buffer) + (sb-impl::buffer-tail buffer))))) + +#-win32 +(defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl) + (eq :regular (sb-impl::fd-stream-fd-type stream)) + (not (sb-impl::sysread-may-block-p stream)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix"))) + +;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, +;; 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation filename-to-pathname (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation set-default-directory (directory) + (let ((directory (truename (merge-pathnames directory)))) + (sb-posix:chdir directory) + (setf *default-pathname-defaults* directory) + (default-directory))) + +(defun make-socket-io-stream (socket external-format buffering) + (let ((args `(:output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler swank:*communication-style*) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + ;; Don't use ECASE since SBCL also has :host-feature, + ;; don't need to handle it or anything else appearing in + ;; the future or in erronous code. + (case (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (when filename + (loop for (nil pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Packages + +#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext) +(defimplementation package-local-nicknames (package) + (sb-ext:package-local-nicknames package)) + +;;; Utilities + +#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-lambda-list fname)) + +#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the + ;; FLAGS would have to be fully qualified when used inside a + ;; declaration. So we strip those as long as there's no + ;; better way. (FIXME) + `(&any ,@(remove-if-not + #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect) +(defmethod type-specifier-arglist :around (typespec-operator) + (multiple-value-bind (arglist foundp) + (sb-introspect:deftype-lambda-list typespec-operator) + (if foundp arglist (call-next-method)))) + +(defimplementation type-specifier-p (symbol) + (or (sb-ext:valid-type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defvar *buffer-name* nil) +(defvar *buffer-tmpfile* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition (real-condition condition) + (sb-c::find-error-context nil)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-ext:compiler-note :note) + (sb-c:compiler-error :error) + (reader-error :read-error) + (error :error) + #+#.(swank/backend:with-symbol early-deprecation-warning sb-ext) + (sb-ext::early-deprecation-warning :early-deprecation-warning) + #+#.(swank/backend:with-symbol late-deprecation-warning sb-ext) + (sb-ext::late-deprecation-warning :late-deprecation-warning) + #+#.(swank/backend:with-symbol final-deprecation-warning sb-ext) + (sb-ext::final-deprecation-warning :final-deprecation-warning) + #+#.(swank/backend:with-symbol redefinition-warning + sb-kernel) + (sb-kernel:redefinition-warning + :redefinition) + (style-warning :style-warning) + (warning :warning)) + :references (condition-references condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (compiler-note-location condition context))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (condition context) + (flet ((bailout () + (return-from compiler-note-location + (make-error-location "No error location available")))) + (cond (context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context))) + ((typep condition 'reader-error) + (let* ((stream (stream-error-stream condition)) + ;; If STREAM is, for example, a STRING-INPUT-STREAM, + ;; an error will be signaled since PATHNAME only + ;; accepts a "stream associated with a file" which + ;; is a complicated predicate and hard to test + ;; portably. + (file (ignore-errors (pathname stream)))) + (unless (and file (open-stream-p stream)) + (bailout)) + (if (compiling-from-buffer-p file) + ;; The stream position for e.g. "comma not inside + ;; backquote" is at the character following the + ;; comma, :offset is 0-based, hence the 1-. + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (1- (file-position stream)))) + (progn + (assert (compiling-from-file-p file)) + ;; No 1- because :position is 1-based. + (make-location (list :file (namestring file)) + (list :position (file-position stream))))))) + (t (bailout))))) + +(defun compiling-from-buffer-p (filename) + (and *buffer-name* + ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P + ;; in LOCATE-COMPILER-NOTE, and allows handling nested + ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). + ;; + ;; PROBE-FILE to handle tempfile directory being a symlink. + (pathnamep filename) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (and true1 (equal true1 true2))))) + +(defun compiling-from-file-p (filename) + (and (pathnamep filename) + (or (null *buffer-name*) + (null *buffer-tmpfile*) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (not (and true1 (equal true1 true2))))))) + +(defun compiling-from-generated-code-p (filename source) + (and (eq filename :lisp) (stringp source))) + +(defun locate-compiler-note (file source-path source) + (cond ((compiling-from-buffer-p file) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + ((compiling-from-file-p file) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (namestring file)) + (list :position (and position + (1+ position)))))) + ((compiling-from-generated-code-p file source) + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" + file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (and (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" + enclosing source)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind + ;; N.B. Even though these handlers are called HANDLE-FOO they + ;; actually decline, i.e. the signalling of the original + ;; condition continues upward. + ((sb-c:fatal-compiler-error #'handle-notification-condition) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (error #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +;;; HACK: SBCL 1.2.12 shipped with a bug where +;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there +;;; were no policy restrictions in place. This workaround ensures the +;;; existence of at least one dummy restriction. +(handler-case (sb-ext:restrict-compiler-policy) + (error () (sb-ext:restrict-compiler-policy 'debug))) + +(defun compiler-policy (qualities) + "Return compiler policy qualities present in the QUALITIES alist. +QUALITIES is an alist with (quality . value)" + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop with policy = (sb-ext:restrict-compiler-policy) + for (quality) in qualities + collect (cons quality + (or (cdr (assoc quality policy)) + 0)))) + +(defun (setf compiler-policy) (policy) + (declare (ignorable policy)) + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop for (qual . value) in policy + do (sb-ext:restrict-compiler-policy qual value))) + +(defmacro with-compiler-policy (policy &body body) + (let ((current-policy (gensym))) + `(let ((,current-policy (compiler-policy ,policy))) + (setf (compiler-policy) ,policy) + (unwind-protect (progn ,@body) + (setf (compiler-policy) ,current-policy))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (multiple-value-bind (output-file warnings-p failure-p) + (with-compiler-policy policy + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :external-format external-format))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string))) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (tempnam nil "slime")) + +(defvar *trap-load-time-warnings* t) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column)) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (*buffer-tmpfile* (temp-file-name))) + (labels ((load-it (filename) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-package (package-name *package*) + :emacs-position position + :emacs-string string) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) + (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error + :external-format :utf-8) + (write-string string s)) + (unwind-protect + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) + (ignore-errors + (delete-file *buffer-tmpfile*) + (delete-file (compile-file-pathname *buffer-tmpfile*))))))) + +;;;; Definitions + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (getf *definition-types* type)) + +(defun make-dspec (type name source-location) + (list* (definition-specifier type) + name + (sb-introspect::definition-source-description source-location))) + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for defsrcs = (sb-introspect:find-definition-sources-by-name name type) + for filtered-defsrcs = (if (eq type :generic-function) + (remove :invalid defsrcs + :key #'categorize-definition-source) + defsrcs) + append (loop for defsrc in filtered-defsrcs collect + (list (make-dspec type name defsrc) + (converting-errors-to-error-location + (definition-source-for-emacs defsrc + type name)))))) + +(defimplementation find-source-location (obj) + (flet ((general-type-of (obj) + (typecase obj + (method :method) + (generic-function :generic-function) + (function :function) + (structure-class :structure-class) + (class :class) + (method-combination :method-combination) + (package :package) + (condition :condition) + (structure-object :structure-object) + (standard-object :standard-object) + (t :thing))) + (to-string (obj) + (typecase obj + ;; Packages are possibly named entities. + (package (princ-to-string obj)) + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (princ-to-string obj))))) + (converting-errors-to-error-location + (let ((defsrc (sb-introspect:find-definition-source obj))) + (definition-source-for-emacs defsrc + (general-type-of obj) + (to-string obj)))))) + +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defun categorize-definition-source (definition-source) + (with-definition-source (pathname form-path character-offset plist) + definition-source + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun form-number-position (definition-source stream) + (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) + (form-number (sb-introspect:definition-source-form-number definition-source))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun file-form-number-position (definition-source) + (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) + (filename (sb-introspect:definition-source-pathname definition-source)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (form-number-position definition-source s))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun string-form-number-position (definition-source string) + (with-input-from-string (s string) + (form-number-position definition-source s))) + +(defun definition-source-buffer-location (definition-source) + (with-definition-source (form-path character-offset plist) definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory)) + start + end) + (with-debootstrapping + (or + (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (setf (values start end) + (and (sb-introspect:definition-source-form-number definition-source) + (string-form-number-position definition-source emacs-string))) + (setf (values start end) + (source-path-string-position form-path emacs-string)))) + (setf start character-offset + end most-positive-fixnum))) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*))))))))) + +(defun definition-source-file-location (definition-source) + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (or (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (and (sb-introspect:definition-source-form-number definition-source) + (ignore-errors (file-form-number-position definition-source))) + (ignore-errors + (source-file-position namestring file-write-date + form-path)))) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (namestring (sb-introspect:definition-source-pathname + definition-source))) + (location-position buffer) + (location-hints buffer)))) + +(defun definition-source-for-emacs (definition-source type name) + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + meaningful information." + type name))))) + +(defun source-file-position (filename write-date form-path) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (with-debootstrapping + (source-path-string-position form-path source)))) + +(defun source-hint-snippet (filename write-date position) + (read-snippet-from-string (get-source-code filename write-date) position)) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (definition-source-for-emacs (sb-introspect:find-definition-source function) + :function + (or name (function-name function)))) + +(defun setf-expander (symbol) + (or + #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info) + (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (and (setf-expander symbol) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (setf-expander symbol))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank/sbcl::sbcl-with-xref-p) +(progn + (defmacro defxref (name &optional fn-name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name (if fn-name + fn-name + name)) + "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands) + #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect) + (defxref who-specializes who-specializes-directly)) + +(defun source-location-for-xref-data (xref-data) + (destructuring-bind (name . defsrc) xref-data + (list name (converting-errors-to-error-location + (definition-source-for-emacs defsrc 'function name))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (function-name fn))) + (list name (converting-errors-to-error-location + (function-source-location fn name))))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (sb-cltl2:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (sb-walker:walk-form + form environment + (lambda (form context environment) + (declare (ignore context)) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + +;;; Debugging + +;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger +;;; than just a hook into BREAK. In particular, it'll make +;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather +;;; than the native debugger. That should probably be considered a +;;; feature. + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(sb-int:named-lambda swank-invoke-debugger-hook + (condition old-hook) + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defun set-break-hook (hook) + (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + +(defun call-with-break-hook (hook continuation) + (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall continuation))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (set-break-hook function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let ((*sldb-stack-top* + (if (and (not *debug-swank-backend*) + sb-debug:*stack-top-hint*) + #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + (sb-debug::resolve-stack-top-hint) + #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + sb-debug:*stack-top-hint* + (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +#+#.(swank/sbcl::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sldb-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sldb-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sldb-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sldb-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (call-with-break-hook hook fun)))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream + :allow-other-keys t + :emergency-best-effort t)) + +(defimplementation frame-restartable-p (frame) + #+#.(swank/sbcl::sbcl-with-restart-frame) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) + +(defimplementation frame-call (frame-number) + (multiple-value-bind (name args) + (sb-debug::frame-call (nth-frame frame-number)) + (with-output-to-string (stream) + (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (sb-debug::ensure-printable-object name) stream)) + (let ((args (sb-debug::ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))))))))) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource)) + (package (getf plist :emacs-package)) + (*package* (or (and package + (find-package package)) + *package*))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location))) + #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (if (sb-di:debug-source-namestring dsource) + (file-source-location code-location) + (lisp-source-location code-location))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100))) + (condition swank:*swank-debugger-condition*)) + (if (and (typep condition 'sb-impl::step-form-condition) + (search "SB-IMPL::WITH-STEPPING-ENABLED" source + :test #'char-equal) + (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) + ;; The initial form is utterly uninteresting -- and almost + ;; certainly right there in the REPL. + (make-error-location "Stepping...") + (make-location `(:source-form ,source) '(:position 1))))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (read-snippet-from-string emacs-string pos))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,pos) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,pos) + `(:snippet ,snippet))))))) + +(defun code-location-debug-source-name (code-location) + (namestring (truename (#.(swank/backend:choose-symbol + 'sb-c 'debug-source-name + 'sb-c 'debug-source-namestring) + (sb-di::code-location-debug-source code-location))))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in source-path-parser + +(defimplementation frame-source-location (index) + (converting-errors-to-error-location + (code-location-source-location + (sb-di:frame-code-location (nth-frame index))))) + +(defvar *keep-non-valid-locals* nil) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) + (loc (sb-di:frame-code-location frame)) + (vars (if *keep-non-valid-locals* + all-vars + (remove-if (lambda (var) + (ecase (sb-di:debug-var-validity var loc) + (:valid nil) + ((:invalid :unknown) t))) + all-vars))) + more-context + more-count) + (values (loop for v across vars + unless + (case (debug-var-info v) + (:more-context + (setf more-context (debug-var-value v frame loc)) + t) + (:more-count + (setf more-count (debug-var-value v frame loc)) + t)) + collect v) + more-context more-count))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':))) + +(defun debug-var-info (var) + ;; Introduced by SBCL 1.0.49.76. + (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) + (when (and s (fboundp s)) + (funcall s var)))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame))) + (multiple-value-bind (vars more-context more-count) + (frame-debug-vars frame) + (let ((locals + (loop for v in vars + collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + (if (and more-context more-count) + (append locals + (list + (list :name + ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE + ;; specially. + (or (find-symbol "MORE" :sb-debug) 'more) + :id 0 + :value (multiple-value-list + (sb-c:%more-arg-values + more-context + 0 more-count))))) + locals))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (multiple-value-bind (vars more-context more-count) + (frame-debug-vars frame) + (let* ((loc (sb-di:frame-code-location frame)) + (dvar (if (= var (length vars)) + ;; If VAR is out of bounds, it must be the fake var + ;; we made up for &MORE. + (return-from frame-var-value + (multiple-value-list (sb-c:%more-arg-values + more-context + 0 more-count))) + (nth var vars)))) + (debug-var-value dvar frame loc))))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) + (when fun + (let ((name (function-name fun))) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) + +#+#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call + frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation print-condition (condition stream) + (let ((sb-int:*print-condition-references* nil)) + (princ condition stream))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + (cond ((sb-di::indirect-value-cell-p o) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (list* (string-right-trim '(#\Newline) text) + '(:newline) + (if label + (loop for (l . v) in parts + append (label-value-line l v)) + (loop for value in parts + for i from 0 + append (label-value-line i value)))))))) + +(defmethod emacs-inspect ((o function)) + (cond ((sb-kernel:simple-fun-p o) + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o)))) + ((sb-kernel:closurep o) + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i))))) + (t (call-next-method o)))) + +(defmethod emacs-inspect ((o sb-kernel:code-component)) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:entry-points (sb-kernel:%code-entry-points o)) + (:debug-info (sb-kernel:%code-debug-info o))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below + (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words + 'sb-kernel 'get-header-data) + o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + ,(with-output-to-string (s) + (sb-disassem:disassemble-code-component o :stream s))))) + +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) + (label-value-line* + (:value (sb-ext:weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sb-kernel:fdefn)) + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o)))) + +(defmethod emacs-inspect :around ((o generic-function)) + (append + (call-next-method) + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD")) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "Running" + "Stopped")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-recursive-lock (mutex) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + (waitq (mailbox.waitqueue mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sb-thread:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (sb-thread:condition-wait waitq mutex))))) + + (let ((alist '()) + (mutex (sb-thread:make-mutex :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (sb-thread:with-mutex (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (sb-thread:thread + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (sb-thread:with-mutex (mutex) + (cdr (assoc name alist)))))) + +(defimplementation quit-lisp () + #+#.(swank/backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(swank/backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace ) +;; (trace :methods ') ;to trace all methods of the gf +;; (trace (method ? (+))) +;; can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) + +;;; Floating point + +(defimplementation float-nan-p (float) + (sb-ext:float-nan-p float)) + +(defimplementation float-infinity-p (float) + (sb-ext:float-infinity-p float)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (error "execv(3) returned."))) + (sb-alien:free-alien a-args)))) + + (defun runtime-pathname () + #+#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + sb-ext:*runtime-pathname* + #-#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + (car sb-ext:*posix-argv*)) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--swank-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename (runtime-pathname)))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +#-win32 +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) + +(pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defun sbcl-version>= (&rest subversions) + #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) + #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + nil) + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator + #-#.(swank/backend:with-symbol 'arg-list 'sb-int) + (lambda (function &rest args) + (sbcl-wrap spec before after replace function args)) + #+#.(swank/backend:with-symbol 'arg-list 'sb-int) + (if (sbcl-version>= 1 1 16) + (lambda () + (sbcl-wrap spec before after replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))) + `(sbcl-wrap ',spec ,before ,after ,replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))))) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(defun sbcl-wrap (spec before after replace function args) + (declare (ignore spec)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list (if replace + (funcall replace + args) + (apply function args)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl) +(progn + (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) + (sexp-in-bounds-p (sb-impl::comma-expr s) i)) + + (defmethod sexp-ref ((s sb-impl::comma) i) + (sexp-ref (sb-impl::comma-expr s) i))) diff --git a/elpa/slime-20200319.1939/swank/scl.lisp b/elpa/slime-20200319.1939/swank/scl.lisp new file mode 100644 index 00000000..ac68c8e5 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/scl.lisp @@ -0,0 +1,1726 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/scl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/scl) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backlog 5)))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + '#:ext) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (and enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error ) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse + (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers + #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (multiple-value-bind (args winp) + (ext:function-arglist fun) + (if winp args :not-available))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation pathname-to-filename (pathname) + (ext:unix-namestring pathname nil)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol + (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (list* (format nil "~A is a function.~%" o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +(defmethod emacs-inspect ((o array)) + (cond ((kernel:array-header-p o) + (list* (format nil "~A is an array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (list* (format nil "~A is an simple-array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod emacs-inspect ((o simple-vector)) + (list* (format nil "~A is a vector.~%" o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil)) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (sys:without-interrupts + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) + (make-mailbox)))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread))) + +#+nil +(defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox thread:*thread*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sys:without-interrupts + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) diff --git a/elpa/slime-20200319.1939/swank/source-file-cache.lisp b/elpa/slime-20200319.1939/swank/source-file-cache.lisp new file mode 100644 index 00000000..e639ea11 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/source-file-cache.lisp @@ -0,0 +1,136 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(defpackage swank/source-file-cache + (:use cl) + (:import-from swank/backend + defimplementation buffer-first-change + guess-external-format + find-external-format) + (:export + get-source-code + source-cache-get ;FIXME: isn't it odd that both are exported? + + *source-snippet-size* + read-snippet + read-snippet-from-string + )) + +(in-package swank/source-file-cache) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let* ((string (make-string (file-length s))) + (length (read-sequence string s))) + (subseq string 0 length)))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+sbcl (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun read-snippet-from-string (string &optional position) + (with-input-from-string (s string) + (read-snippet s position))) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream nil nil) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) diff --git a/elpa/slime-20200319.1939/swank/source-path-parser.lisp b/elpa/slime-20200319.1939/swank/source-path-parser.lisp new file mode 100644 index 00000000..f7f29f13 --- /dev/null +++ b/elpa/slime-20200319.1939/swank/source-path-parser.lisp @@ -0,0 +1,242 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(defpackage swank/source-path-parser + (:use cl) + (:export + read-source-form + source-path-string-position + source-path-file-position + source-path-source-position + + sexp-in-bounds-p + sexp-ref) + (:shadow ignore-errors)) + +(in-package swank/source-path-parser) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(eval-when (:compile-toplevel) + (defmacro ignore-errors (&rest forms) + ;;`(progn . ,forms) ; for debugging + `(cl:ignore-errors . ,forms))) + +(defun make-sharpdot-reader (orig-sharpdot-reader) + (lambda (s c n) + ;; We want things like M-. to work regardless of any #.-fu in + ;; the source file that is to be visited. (For instance, when a + ;; file contains #. forms referencing constants that do not + ;; currently exist in the image.) + (ignore-errors (funcall orig-sharpdot-reader s c n)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (lambda (stream char) + (let ((start (1- (file-position stream))) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + #+(or) + (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" + start values end (char-code char) char) + (when values + (destructuring-bind (&optional existing-start &rest existing-end) + (car (gethash (car values) source-map)) + ;; Some macros may return what a sub-call to another macro + ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, + ;; once from #\# and once from #\(. If the saved form + ;; is a subform, don't save it again. + (unless (and existing-start existing-end + (<= start existing-start end) + (<= start existing-end end)) + (push (cons start end) (gethash (car values) source-map))))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + (declare (type readtable readtable) (type hash-table source-map)) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (flet ((install-special-sharpdot-reader (rt) + (let ((fun (ignore-errors + (get-dispatch-macro-character #\# #\. rt)))) + (when fun + (let ((wrapper (make-sharpdot-reader fun))) + (set-dispatch-macro-character #\# #\. wrapper rt))))) + (install-wrappers (rt) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fun nt) (get-macro-character char rt) + (when fun + (let ((wrapper (make-source-recorder fun source-map))) + (set-macro-character char wrapper nt rt)))))))) + (let ((rt (copy-readtable readtable))) + (install-special-sharpdot-reader rt) + (install-wrappers rt) + rt))) + +;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. +;; Should be possible as we only need the right "list structure" and +;; not the right atoms. +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (*read-suppress* nil) + (start (file-position stream)) + (form (ignore-errors (read stream))) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun starts-with-p (string prefix) + (declare (type string string prefix)) + (not (mismatch string prefix + :end1 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun extract-package (line) + (declare (type string line)) + (let ((name (cadr (read-from-string line)))) + (find-package name))) + +#+(or) +(progn + (assert (extract-package "(in-package cl)")) + (assert (extract-package "(cl:in-package cl)")) + (assert (extract-package "(in-package \"CL\")")) + (assert (extract-package "(in-package #:cl)"))) + +;; FIXME: do something cleaner than this. +(defun readtable-for-package (package) + ;; KLUDGE: due to the load order we can't reference the swank + ;; package. + (funcall (read-from-string "swank::guess-buffer-readtable") + (string-upcase (package-name package)))) + +;; Search STREAM for a "(in-package ...)" form. Use that to derive +;; the values for *PACKAGE* and *READTABLE*. +;; +;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends +;; use the same heuristic and to avoid the need to access +;; swank::guess-buffer-readtable from here. +(defun guess-reader-state (stream) + (let* ((point (file-position stream)) + (pkg *package*)) + (file-position stream 0) + (loop for line = (read-line stream nil nil) do + (when (not line) (return)) + (when (or (starts-with-p line "(in-package ") + (starts-with-p line "(cl:in-package ")) + (let ((p (extract-package line))) + (when p (setf pkg p))) + (return))) + (file-position stream point) + (values (readtable-for-package pkg) pkg))) + +(defun skip-whitespace (stream) + (peek-char t stream nil nil)) + +;; Skip over N toplevel forms. +(defun skip-toplevel-forms (n stream) + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream)) + (skip-whitespace stream))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) + (let (#+sbcl + (*features* (append *features* + (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl))))) + (skip-toplevel-forms n stream) + (read-and-record-source-map stream)))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + ;; We go this long way round, and don't directly operate on the file + ;; stream because FILE-POSITION (used above) is not totally savy even + ;; on file character streams; on SBCL, FILE-POSITION returns the binary + ;; offset, and not the character offset---screwing up on Unicode. + (let ((toplevel-number (first path)) + (buffer)) + (with-open-file (file filename) + (skip-toplevel-forms (1+ toplevel-number) file) + (let ((endpos (file-position file))) + (setq buffer (make-array (list endpos) :element-type 'character + :initial-element #\Space)) + (assert (file-position file 0)) + (read-sequence buffer file :end endpos))) + (source-path-string-position path buffer))) + +(defgeneric sexp-in-bounds-p (sexp i) + (:method ((list list) i) + (< i (loop for e on list + count t))) + (:method ((sexp t) i) nil)) + +(defgeneric sexp-ref (sexp i) + (:method ((s list) i) (elt s i))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for i in path + for f = form then (if (sexp-in-bounds-p f i) + (sexp-ref f i)) + collect f))) + ;; select the first subform present in source-map + (loop for form in (nreverse forms) + for ((start . end) . rest) = (gethash form source-map) + when (and start end (not rest)) + return (return (values start end))))) diff --git a/elpa/slime-20200319.1939/xref.lisp b/elpa/slime-20200319.1939/xref.lisp new file mode 100644 index 00000000..e09a1504 --- /dev/null +++ b/elpa/slime-20200319.1939/xref.lisp @@ -0,0 +1,2906 @@ +;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. +;;; 7-APR-12 heller Break lines at 80 columns. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| + (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. + (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. + (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to \".lisp\". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#\: #\|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) + :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) + :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) + :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) + :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) + :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors) diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-common.el b/elpa/spacemacs-theme-20200322.1408/spacemacs-common.el new file mode 100644 index 00000000..d130bc90 --- /dev/null +++ b/elpa/spacemacs-theme-20200322.1408/spacemacs-common.el @@ -0,0 +1,1019 @@ +;;; spacemacs-common.el --- Color theme with a dark and light versions. + +;; Copyright (C) 2015-2018 Nasser Alshammari + +;; Author: Nasser Alshammari +;; URL: +;; +;; Version: 0.1 +;; Keywords: color, theme +;; Package-Requires: ((emacs "24")) + +;; Initially created with the help of emacs-theme-generator, . + +;; This program 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. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of Emacs. + +;;; Commentary: + +;; This is a color theme for spacemacs . +;; It comes with two versions, dark and light and should work well in +;; a 256 color terminal. + +;;; Code: + +(defgroup spacemacs-theme nil + "Spacemacs-theme options." + :group 'faces) + +(defcustom spacemacs-theme-comment-bg t + "Use a background for comment lines." + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-comment-italic nil + "Enable italics for comments and also disable background." + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-keyword-italic nil + "Enable italics for keywords." + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-org-agenda-height nil + "If non-nil, use varying text heights for agenda items. + +Note that if you change this to a non-nil value, you may want to +also adjust the value of `org-agenda-tags-column'. If that is set +to 'auto, tags may not be properly aligned. " + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-org-height t + "Use varying text heights for org headings." + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-org-bold t + "Inherit text bold for org headings" + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-org-priority-bold t + "Inherit text bold for priority items in agenda view" + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-org-highlight nil + "Highlight org headings." + :type 'boolean + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-custom-colors nil + "Specify a list of custom colors." + :type 'alist + :group 'spacemacs-theme) + +(defcustom spacemacs-theme-underline-parens t + "If non-nil, underline matching parens when using `show-paren-mode' or similar." + :type 'boolean + :group 'spacemacs-theme) + +(defun true-color-p () + (or + (display-graphic-p) + (= (tty-display-color-cells) 16777216))) + +(defun create-spacemacs-theme (variant theme-name) + (let ((class '((class color) (min-colors 89))) ;; ~~ Dark ~~ ~~ Light ~~ + ;; GUI TER GUI TER + ;; generic + (act1 (if (eq variant 'dark) (if (true-color-p) "#222226" "#121212") (if (true-color-p) "#e7e5eb" "#d7dfff"))) + (act2 (if (eq variant 'dark) (if (true-color-p) "#5d4d7a" "#444444") (if (true-color-p) "#d3d3e7" "#afafd7"))) + (base (if (eq variant 'dark) (if (true-color-p) "#b2b2b2" "#b2b2b2") (if (true-color-p) "#655370" "#5f5f87"))) + (base-dim (if (eq variant 'dark) (if (true-color-p) "#686868" "#585858") (if (true-color-p) "#a094a2" "#afafd7"))) + (bg1 (if (eq variant 'dark) (if (true-color-p) "#292b2e" "#262626") (if (true-color-p) "#fbf8ef" "#ffffff"))) + (bg2 (if (eq variant 'dark) (if (true-color-p) "#212026" "#1c1c1c") (if (true-color-p) "#efeae9" "#e4e4e4"))) + (bg3 (if (eq variant 'dark) (if (true-color-p) "#100a14" "#121212") (if (true-color-p) "#e3dedd" "#d0d0d0"))) + (bg4 (if (eq variant 'dark) (if (true-color-p) "#0a0814" "#080808") (if (true-color-p) "#d2ceda" "#bcbcbc"))) + (border (if (eq variant 'dark) (if (true-color-p) "#5d4d7a" "#111111") (if (true-color-p) "#b3b9be" "#b3b9be"))) + (cblk (if (eq variant 'dark) (if (true-color-p) "#cbc1d5" "#b2b2b2") (if (true-color-p) "#655370" "#5f5f87"))) + (cblk-bg (if (eq variant 'dark) (if (true-color-p) "#2f2b33" "#262626") (if (true-color-p) "#e8e3f0" "#ffffff"))) + (cblk-ln (if (eq variant 'dark) (if (true-color-p) "#827591" "#af5faf") (if (true-color-p) "#9380b2" "#af5fdf"))) + (cblk-ln-bg (if (eq variant 'dark) (if (true-color-p) "#373040" "#333333") (if (true-color-p) "#ddd8eb" "#dfdfff"))) + (cursor (if (eq variant 'dark) (if (true-color-p) "#e3dedd" "#d0d0d0") (if (true-color-p) "#100a14" "#121212"))) + (const (if (eq variant 'dark) (if (true-color-p) "#a45bad" "#d75fd7") (if (true-color-p) "#4e3163" "#8700af"))) + (comment (if (eq variant 'dark) (if (true-color-p) "#2aa1ae" "#008787") (if (true-color-p) "#2aa1ae" "#008787"))) + (comment-light (if (eq variant 'dark) (if (true-color-p) "#2aa1ae" "#008787") (if (true-color-p) "#a49da5" "#008787"))) + (comment-bg (if (eq variant 'dark) (if (true-color-p) "#292e34" "#262626") (if (true-color-p) "#ecf3ec" "#ffffff"))) + (comp (if (eq variant 'dark) (if (true-color-p) "#c56ec3" "#d75fd7") (if (true-color-p) "#6c4173" "#8700af"))) + (err (if (eq variant 'dark) (if (true-color-p) "#e0211d" "#e0211d") (if (true-color-p) "#e0211d" "#e0211d"))) + (func (if (eq variant 'dark) (if (true-color-p) "#bc6ec5" "#d75fd7") (if (true-color-p) "#6c3163" "#8700af"))) + (head1 (if (eq variant 'dark) (if (true-color-p) "#4f97d7" "#268bd2") (if (true-color-p) "#3a81c3" "#268bd2"))) + (head1-bg (if (eq variant 'dark) (if (true-color-p) "#293239" "#262626") (if (true-color-p) "#edf1ed" "#ffffff"))) + (head2 (if (eq variant 'dark) (if (true-color-p) "#2d9574" "#2aa198") (if (true-color-p) "#2d9574" "#2aa198"))) + (head2-bg (if (eq variant 'dark) (if (true-color-p) "#293235" "#262626") (if (true-color-p) "#edf2e9" "#ffffff"))) + (head3 (if (eq variant 'dark) (if (true-color-p) "#67b11d" "#67b11d") (if (true-color-p) "#67b11d" "#5faf00"))) + (head3-bg (if (eq variant 'dark) (if (true-color-p) "#293235" "#262626") (if (true-color-p) "#edf2e9" "#ffffff"))) + (head4 (if (eq variant 'dark) (if (true-color-p) "#b1951d" "#875f00") (if (true-color-p) "#b1951d" "#875f00"))) + (head4-bg (if (eq variant 'dark) (if (true-color-p) "#32322c" "#262626") (if (true-color-p) "#f6f1e1" "#ffffff"))) + (highlight (if (eq variant 'dark) (if (true-color-p) "#444155" "#444444") (if (true-color-p) "#d3d3e7" "#d7d7ff"))) + (highlight-dim (if (eq variant 'dark) (if (true-color-p) "#3b314d" "#444444") (if (true-color-p) "#e7e7fc" "#d7d7ff"))) + (keyword (if (eq variant 'dark) (if (true-color-p) "#4f97d7" "#268bd2") (if (true-color-p) "#3a81c3" "#268bd2"))) + (lnum (if (eq variant 'dark) (if (true-color-p) "#44505c" "#444444") (if (true-color-p) "#a8a8bf" "#af87af"))) + (mat (if (eq variant 'dark) (if (true-color-p) "#86dc2f" "#86dc2f") (if (true-color-p) "#ba2f59" "#af005f"))) + (meta (if (eq variant 'dark) (if (true-color-p) "#9f8766" "#af875f") (if (true-color-p) "#da8b55" "#df5f5f"))) + (str (if (eq variant 'dark) (if (true-color-p) "#2d9574" "#2aa198") (if (true-color-p) "#2d9574" "#2aa198"))) + (suc (if (eq variant 'dark) (if (true-color-p) "#86dc2f" "#86dc2f") (if (true-color-p) "#42ae2c" "#00af00"))) + (ttip (if (eq variant 'dark) (if (true-color-p) "#9a9aba" "#888888") (if (true-color-p) "#8c799f" "#5f5f87"))) + (ttip-sl (if (eq variant 'dark) (if (true-color-p) "#5e5079" "#333333") (if (true-color-p) "#c8c6dd" "#afafff"))) + (ttip-bg (if (eq variant 'dark) (if (true-color-p) "#34323e" "#444444") (if (true-color-p) "#e2e0ea" "#dfdfff"))) + (type (if (eq variant 'dark) (if (true-color-p) "#ce537a" "#df005f") (if (true-color-p) "#ba2f59" "#af005f"))) + (var (if (eq variant 'dark) (if (true-color-p) "#7590db" "#8787d7") (if (true-color-p) "#715ab1" "#af5fd7"))) + (war (if (eq variant 'dark) (if (true-color-p) "#dc752f" "#dc752f") (if (true-color-p) "#dc752f" "#dc752f"))) + + ;; colors + (aqua (if (eq variant 'dark) (if (true-color-p) "#2d9574" "#2aa198") (if (true-color-p) "#2d9574" "#2aa198"))) + (aqua-bg (if (eq variant 'dark) (if (true-color-p) "#293235" "#262626") (if (true-color-p) "#edf2e9" "#ffffff"))) + (green (if (eq variant 'dark) (if (true-color-p) "#67b11d" "#67b11d") (if (true-color-p) "#67b11d" "#5faf00"))) + (green-bg (if (eq variant 'dark) (if (true-color-p) "#293235" "#262626") (if (true-color-p) "#edf2e9" "#ffffff"))) + (green-bg-s (if (eq variant 'dark) (if (true-color-p) "#29422d" "#262626") (if (true-color-p) "#dae6d0" "#ffffff"))) + (cyan (if (eq variant 'dark) (if (true-color-p) "#28def0" "#00ffff") (if (true-color-p) "#21b8c7" "#008080"))) + (red (if (eq variant 'dark) (if (true-color-p) "#f2241f" "#d70000") (if (true-color-p) "#f2241f" "#d70008"))) + (red-bg (if (eq variant 'dark) (if (true-color-p) "#3c2a2c" "#262626") (if (true-color-p) "#faede4" "#ffffff"))) + (red-bg-s (if (eq variant 'dark) (if (true-color-p) "#512e31" "#262626") (if (true-color-p) "#eed9d2" "#ffffff"))) + (blue (if (eq variant 'dark) (if (true-color-p) "#4f97d7" "#268bd2") (if (true-color-p) "#3a81c3" "#268bd2"))) + (blue-bg (if (eq variant 'dark) (if (true-color-p) "#293239" "#262626") (if (true-color-p) "#edf1ed" "#d7d7ff"))) + (blue-bg-s (if (eq variant 'dark) (if (true-color-p) "#2d4252" "#262626") (if (true-color-p) "#d1dcdf" "#d7d7ff"))) + (magenta (if (eq variant 'dark) (if (true-color-p) "#a31db1" "#af00df") (if (true-color-p) "#a31db1" "#800080"))) + (yellow (if (eq variant 'dark) (if (true-color-p) "#b1951d" "#875f00") (if (true-color-p) "#b1951d" "#875f00"))) + (yellow-bg (if (eq variant 'dark) (if (true-color-p) "#32322c" "#262626") (if (true-color-p) "#f6f1e1" "#ffffff")))) + + (cl-loop for (cvar . val) in spacemacs-theme-custom-colors + do (set cvar val)) + + (custom-theme-set-faces + theme-name + +;;;;; basics + `(cursor ((,class (:background ,cursor)))) + `(custom-button ((,class :background ,bg2 :foreground ,base :box (:line-width 2 :style released-button)))) + `(default ((,class (:background ,bg1 :foreground ,base)))) + `(default-italic ((,class (:italic t)))) + `(error ((,class (:foreground ,err)))) + `(eval-sexp-fu-flash ((,class (:background ,suc :foreground ,bg1)))) + `(eval-sexp-fu-flash-error ((,class (:background ,err :foreground ,bg1)))) + `(font-lock-builtin-face ((,class (:foreground ,keyword)))) + `(font-lock-comment-face ((,class (:foreground ,(if spacemacs-theme-comment-italic comment-light comment) :background ,(when spacemacs-theme-comment-bg comment-bg) :slant ,(if spacemacs-theme-comment-italic 'italic 'normal))))) + `(font-lock-constant-face ((,class (:foreground ,const)))) + `(font-lock-doc-face ((,class (:foreground ,meta)))) + `(font-lock-function-name-face ((,class (:foreground ,func :inherit bold)))) + `(font-lock-keyword-face ((,class (:inherit bold :foreground ,keyword :slant ,(if spacemacs-theme-keyword-italic 'italic 'normal))))) + `(font-lock-negation-char-face ((,class (:foreground ,const)))) + `(font-lock-preprocessor-face ((,class (:foreground ,func)))) + `(font-lock-reference-face ((,class (:foreground ,const)))) + `(font-lock-string-face ((,class (:foreground ,str)))) + `(font-lock-type-face ((,class (:foreground ,type :inherit bold)))) + `(font-lock-variable-name-face ((,class (:foreground ,var)))) + `(font-lock-warning-face ((,class (:foreground ,war :background ,bg1)))) + `(fringe ((,class (:background ,bg1 :foreground ,base)))) + `(header-line ((,class :background ,bg2))) + `(highlight ((,class (:foreground ,base :background ,highlight)))) + `(hl-line ((,class (:background ,bg2 :extend t)))) + `(isearch ((,class (:foreground ,bg1 :background ,mat)))) + `(lazy-highlight ((,class (:background ,green-bg-s :weight normal)))) + `(link ((,class (:foreground ,comment :underline t)))) + `(link-visited ((,class (:foreground ,comp :underline t)))) + `(match ((,class (:background ,highlight :foreground ,mat)))) + `(minibuffer-prompt ((,class (:inherit bold :foreground ,keyword)))) + `(page-break-lines ((,class (:foreground ,act2)))) + `(region ((,class (:background ,highlight :extend t)))) + `(secondary-selection ((,class (:background ,bg3)))) + `(shadow ((,class (:foreground ,base-dim)))) + `(success ((,class (:foreground ,suc)))) + `(tooltip ((,class (:background ,ttip-sl :foreground ,base :bold nil :italic nil :underline nil)))) + `(vertical-border ((,class (:foreground ,border)))) + `(warning ((,class (:foreground ,war)))) + `(widget-button-pressed ((,class (:foreground ,base)))) + +;;;;; ace-window + `(aw-leading-char-face ((,class (:foreground ,func :weight bold :height 2.0 :box (:line-width 1 :color ,keyword :style released-button))))) + +;;;;; ahs + `(ahs-face ((,class (:background ,highlight)))) + `(ahs-plugin-whole-buffer-face ((,class (:background ,mat :foreground ,bg1)))) + +;;;;; anzu-mode + `(anzu-mode-line ((,class (:foreground ,yellow :inherit bold)))) + +;;;;; auto-complete + `(ac-completion-face ((,class (:background ,ttip-bg :foreground ,ttip)))) + +;;;;; avy + `(avy-lead-face ((,class (:background ,green-bg :foreground ,green)))) + `(avy-lead-face-0 ((,class (:background ,green-bg :foreground ,yellow)))) + `(avy-lead-face-1 ((,class (:background ,green-bg :foreground ,magenta)))) + `(avy-lead-face-2 ((,class (:background ,green-bg :foreground ,blue)))) + +;;;;; calfw + `(cfw:face-title ((,class (:foreground ,head1 :height 2.0 :weight bold :inherit variable-pitch)))) + `(cfw:face-header ((,class (:foreground ,base :weight bold)))) + `(cfw:face-saturday ((,class (:foreground ,base :weight bold)))) + `(cfw:face-sunday ((,class (:foreground ,base :weight bold)))) + `(cfw:face-holiday ((,class (:foreground ,head1 :weight bold)))) + `(cfw:face-grid ((,class (:foreground ,border)))) + `(cfw:face-default-content ((,class (:foreground ,green)))) + `(cfw:face-periods ((,class (:foreground ,cyan)))) + `(cfw:face-day-title ((,class (:background ,head1-bg)))) + `(cfw:face-default-day ((,class (:foreground ,base :weight bold)))) + `(cfw:face-annotation ((,class (:foreground ,aqua)))) + `(cfw:face-disable ((,class (:foreground ,base-dim)))) + `(cfw:face-today-title ((,class (:background ,blue :weight bold)))) + `(cfw:face-today ((,class (:background ,head1-bg :weight bold)))) + `(cfw:face-select ((,class (:background ,magenta :weight bold)))) + `(cfw:face-toolbar ((,class (:foreground ,base :background ,bg1)))) + `(cfw:face-toolbar-button-off ((,class (:foreground ,base :weight bold)))) + `(cfw:face-toolbar-button-on ((,class (:foreground ,base :weight bold)))) + +;;;;; centaur-tabs + `(centaur-tabs-default ((,class (:background ,bg1 :foreground ,bg1)))) + `(centaur-tabs-selected ((,class (:background ,bg1 :foreground ,base :weight bold)))) + `(centaur-tabs-unselected ((,class (:background ,bg2 :foreground ,base-dim :weight light)))) + `(centaur-tabs-selected-modified ((,class (:background ,bg1 + :foreground ,blue :weight bold)))) + `(centaur-tabs-unselected-modified ((,class (:background ,bg2 :weight light + :foreground ,blue)))) + `(centaur-tabs-active-bar-face ((,class (:background ,keyword)))) + `(centaur-tabs-modified-marker-selected ((,class (:inherit 'centaur-tabs-selected :foreground,keyword)))) + `(centaur-tabs-modified-marker-unselected ((,class (:inherit 'centaur-tabs-unselected :foreground,keyword)))) + +;;;;; cider + `(cider-enlightened ((,class (:background nil :box (:color ,yellow :line-width -1 :style nil) :foreground ,yellow)))) + `(cider-enlightened-local ((,class (:foreground ,yellow)))) + `(cider-instrumented-face ((,class (:background nil :box (:color ,red :line-width -1 :style nil) :foreground ,red)))) + `(cider-result-overlay-face ((,class (:background nil :box (:color ,blue :line-width -1 :style nil) :foreground ,blue)))) + `(cider-test-error-face ((,class (:background ,war :foreground ,bg1)))) + `(cider-test-failure-face ((,class (:background ,err :foreground ,bg1)))) + `(cider-test-success-face ((,class (:background ,suc :foreground ,bg1)))) + `(cider-traced-face ((,class :box (:color ,cyan :line-width -1 :style nil)))) + +;;;;; company + `(company-echo-common ((,class (:background ,base :foreground ,bg1)))) + `(company-preview ((,class (:background ,ttip-bg :foreground ,ttip)))) + `(company-preview-common ((,class (:background ,ttip-bg :foreground ,base)))) + `(company-preview-search ((,class (:inherit match)))) + `(company-scrollbar-bg ((,class (:background ,bg2)))) + `(company-scrollbar-fg ((,class (:background ,act2)))) + `(company-template-field ((,class (:inherit region)))) + `(company-tooltip ((,class (:background ,ttip-bg :foreground ,ttip)))) + `(company-tooltip-annotation ((,class (:foreground ,type)))) + `(company-tooltip-common ((,class (:background ,ttip-bg :foreground ,keyword)))) + `(company-tooltip-common-selection ((,class (:foreground ,keyword)))) + `(company-tooltip-mouse ((,class (:inherit highlight)))) + `(company-tooltip-search ((,class (:inherit match)))) + `(company-tooltip-selection ((,class (:background ,ttip-sl :foreground ,base)))) + +;;;;; diff + `(diff-added ((,class :background nil :foreground ,green :extend t))) + `(diff-changed ((,class :background nil :foreground ,blue))) + `(diff-header ((,class :background ,cblk-ln-bg :foreground ,func :extend t))) + `(diff-file-header ((,class :background ,cblk-ln-bg :foreground ,cblk :extend t))) + `(diff-indicator-added ((,class :background nil :foreground ,green :extend t))) + `(diff-indicator-changed ((,class :background nil :foreground ,blue))) + `(diff-indicator-removed ((,class :background nil :foreground ,red))) + `(diff-refine-added ((,class :background ,green :foreground ,bg1))) + `(diff-refine-changed ((,class :background ,blue :foreground ,bg1))) + `(diff-refine-removed ((,class :background ,red :foreground ,bg1))) + `(diff-removed ((,class :background nil :foreground ,red :extend t))) + +;;;;; diff-hl + `(diff-hl-change ((,class :background ,blue-bg-s :foreground ,blue))) + `(diff-hl-delete ((,class :background ,red-bg-s :foreground ,red))) + `(diff-hl-insert ((,class :background ,green-bg-s :foreground ,green))) + +;;;;; dired + `(dired-directory ((,class (:foreground ,keyword :background ,bg1 :inherit bold)))) + `(dired-flagged ((,class (:foreground ,red)))) + `(dired-header ((,class (:foreground ,comp :inherit bold)))) + `(dired-ignored ((,class (:inherit shadow)))) + `(dired-mark ((,class (:foreground ,comp :inherit bold)))) + `(dired-marked ((,class (:foreground ,magenta :inherit bold)))) + `(dired-perm-write ((,class (:foreground ,base :underline t)))) + `(dired-symlink ((,class (:foreground ,cyan :background ,bg1 :inherit bold)))) + `(dired-warning ((,class (:foreground ,war)))) + +;;;;; doom-modeline + `(doom-modeline-bar ((,class (:background ,keyword)))) + +;;;;; ediff + `(ediff-current-diff-A ((,class(:background ,red-bg :foreground ,red :extend t)))) + `(ediff-current-diff-Ancestor ((,class(:background ,aqua-bg :foreground ,aqua :extend t)))) + `(ediff-current-diff-B ((,class(:background ,green-bg :foreground ,green :extend t)))) + `(ediff-current-diff-C ((,class(:background ,blue-bg :foreground ,blue :extend t)))) + `(ediff-even-diff-A ((,class(:background ,bg3 :extend t)))) + `(ediff-even-diff-Ancestor ((,class(:background ,bg3 :extend t)))) + `(ediff-even-diff-B ((,class(:background ,bg3 :extend t)))) + `(ediff-even-diff-C ((,class(:background ,bg3 :extend t)))) + `(ediff-fine-diff-A ((,class(:background ,red :foreground ,bg1 :extend t)))) + `(ediff-fine-diff-Ancestor ((,class(:background nil :inherit bold :extend t)))) + `(ediff-fine-diff-B ((,class(:background ,green :foreground ,bg1)))) + `(ediff-fine-diff-C ((,class(:background ,blue :foreground ,bg1)))) + `(ediff-odd-diff-A ((,class(:background ,bg4 :extend t)))) + `(ediff-odd-diff-Ancestor ((,class(:background ,bg4 :extend t)))) + `(ediff-odd-diff-B ((,class(:background ,bg4 :extend t)))) + `(ediff-odd-diff-C ((,class(:background ,bg4 :extend t)))) + +;;;;; ein + `(ein:cell-input-area((,class (:background ,bg2)))) + `(ein:cell-input-prompt ((,class (:foreground ,suc)))) + `(ein:cell-output-prompt ((,class (:foreground ,err)))) + `(ein:notification-tab-normal ((,class (:foreground ,keyword)))) + `(ein:notification-tab-selected ((,class (:foreground ,suc :inherit bold)))) + +;;;;; eldoc + `(eldoc-highlight-function-argument ((,class (:foreground ,mat :inherit bold)))) + +;;;;; elfeed + `(elfeed-search-date-face ((,class (:foreground ,head2)))) + `(elfeed-search-feed-face ((,class (:foreground ,blue)))) + `(elfeed-search-tag-face ((,class (:foreground ,func)))) + `(elfeed-search-title-face ((,class (:foreground ,var)))) + `(elfeed-search-unread-title-face ((,class (:foreground ,base)))) + +;;;;; enh-ruby + `(enh-ruby-op-face ((,class (:background ,bg1 :foreground ,base)))) + `(enh-ruby-string-delimiter-face ((,class (:foreground ,str)))) + +;;;;; erc + `(erc-input-face ((,class (:foreground ,func)))) + `(erc-my-nick-face ((,class (:foreground ,keyword)))) + `(erc-nick-default-face ((,class (:foreground ,keyword)))) + `(erc-nick-prefix-face ((,class (:foreground ,yellow)))) + `(erc-notice-face ((,class (:foreground ,str)))) + `(erc-prompt-face ((,class (:foreground ,mat :inherit bold)))) + `(erc-timestamp-face ((,class (:foreground ,keyword)))) + +;;;;; eshell + `(eshell-ls-archive ((,class (:foreground ,red :inherit bold)))) + `(eshell-ls-backup ((,class (:inherit font-lock-comment-face)))) + `(eshell-ls-clutter ((,class (:inherit font-lock-comment-face)))) + `(eshell-ls-directory ((,class (:foreground ,keyword :inherit bold)))) + `(eshell-ls-executable ((,class (:foreground ,suc :inherit bold)))) + `(eshell-ls-missing ((,class (:inherit font-lock-warning-face)))) + `(eshell-ls-product ((,class (:inherit font-lock-doc-face)))) + `(eshell-ls-special ((,class (:foreground ,yellow :inherit bold)))) + `(eshell-ls-symlink ((,class (:foreground ,cyan :inherit bold)))) + `(eshell-ls-unreadable ((,class (:foreground ,base)))) + `(eshell-prompt ((,class (:foreground ,keyword :inherit bold)))) + +;;;;; ESS + `(ess-assignment-face ((,class (:foreground ,type :inherit bold)))) + `(ess-backquoted-face ((,class (:foreground ,var)))) + `(ess-constant-face ((,class (:inherit font-lock-constant-face)))) + `(ess-f-t-face ((,class (:inherit font-lock-constant-face)))) + `(ess-function-call-face ((,class (:foreground ,func)))) + `(ess-keyword-face ((,class (:inherit font-lock-keyword-face)))) + `(ess-matrix-face ((,class (:foreground ,base-dim)))) + `(ess-modifiers-face ((,class (:foreground ,keyword)))) + `(ess-numbers-face ((,class (:inherit font-lock-constant-face)))) + `(ess-operator-face ((,class (:foreground ,var)))) + `(ess-paren-face ((,class (:foreground ,blue)))) + `(ess-r-control-flow-keyword-face ((,class (:foreground ,keyword)))) + `(ess-r-signal-keyword-face ((,class (:foreground ,war)))) + +;;;;; evil + `(evil-ex-lazy-highlight ((,class (:background ,mat :foreground ,bg1)))) + `(evil-ex-substitute-matches ((,class (:background ,red-bg :foreground ,red)))) + `(evil-ex-substitute-replacement ((,class (:background ,green-bg :foreground ,green)))) + +;;;;; evil-goggles + `(evil-goggles--pulse-face ((,class (:background ,yellow-bg :foreground ,yellow)))) + `(evil-goggles-change-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-commentary-face ((,class (:background ,aqua-bg :foreground ,aqua)))) + `(evil-goggles-delete-face ((,class (:background ,red-bg-s :foreground ,red)))) + `(evil-goggles-fill-and-move-face ((,class (:background ,green-bg-s :foreground ,green)))) + `(evil-goggles-indent-face ((,class (:background ,green-bg-s :foreground ,green)))) + `(evil-goggles-join-face ((,class (:background ,green-bg-s :foreground ,green)))) + `(evil-goggles-nerd-commenter-face ((,class (:background ,aqua-bg :foreground ,aqua)))) + `(evil-goggles-paste-face ((,class (:background ,green-bg-s :foreground ,green)))) + `(evil-goggles-record-macro-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-replace-with-register-face ((,class (:background ,yellow-bg :foreground ,yellow)))) + `(evil-goggles-set-marker-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-shift-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-surround-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-yank-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-undo-redo-add-face ((,class (:background ,green-bg-s :foreground ,green)))) + `(evil-goggles-undo-redo-change-face ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(evil-goggles-undo-redo-remove-face ((,class (:background ,red-bg-s :foreground ,red)))) + +;;;;; evil-mc + `(evil-mc-cursor-bar-face ((,class (:foreground ,aqua)))) + `(evil-mc-cursor-default-face ((,class (:background ,aqua :foreground ,bg4)))) + `(evil-mc-cursor-hbar-face ((,class (:foreground ,aqua)))) + `(evil-mc-region-face ((,class (:inherit highlight)))) + +;;;;; flycheck + `(flycheck-error + ((,(append '((supports :underline (:style line))) class) + (:underline (:style line :color ,err))) + (,class (:foreground ,base :background ,err :inherit bold :underline t)))) + `(flycheck-error-list-checker-name ((,class (:foreground ,keyword)))) + `(flycheck-fringe-error ((,class (:foreground ,err :inherit bold)))) + `(flycheck-fringe-info ((,class (:foreground ,keyword :inherit bold)))) + `(flycheck-fringe-warning ((,class (:foreground ,war :inherit bold)))) + `(flycheck-info + ((,(append '((supports :underline (:style line))) class) + (:underline (:style line :color ,keyword))) + (,class (:foreground ,base :background ,keyword :inherit bold :underline t)))) + `(flycheck-warning + ((,(append '((supports :underline (:style line))) class) + (:underline (:style line :color ,war))) + (,class (:foreground ,base :background ,war :inherit bold :underline t)))) + +;;;;; flymake + `(flymake-error ((,(append '((supports :underline (:style line))) class) + (:underline (:style line :color ,err))) + (,class (:foreground ,base :background ,err :inherit bold :underline t)))) + `(flymake-note ((,(append '((supports :underline (:style line))) class) + (:underline (:style wave :color ,keyword))) + (,class (:foreground ,base :background ,keyword :inherit bold :underline t)))) + `(flymake-warning ((,(append '((supports :underline (:style line))) class) + (:underline (:style line :color ,war))) + (,class (:foreground ,base :background ,war :inherit bold :underline t)))) + +;;;;; flyspell + `(flyspell-incorrect ((,(append '((supports :underline (:style line))) class) + (:underline (:style wave :color ,war))) + (,class (:foreground ,base :background ,war :inherit bold :underline t)))) + `(flyspell-duplicate ((,(append '((supports :underline (:style line))) class) + (:underline (:style wave :color ,keyword))) + (,class (:foreground ,base :background ,keyword :inherit bold :underline t)))) + +;;;;; jabber + `(jabber-activity-face ((,class (:inherit bold :foreground ,red)))) + `(jabber-activity-personal-face ((,class (:inherit bold :foreground ,blue)))) + `(jabber-chat-error ((,class (:inherit bold :foreground ,red)))) + `(jabber-chat-prompt-foreign ((,class (:inherit bold :foreground ,red)))) + `(jabber-chat-prompt-local ((,class (:inherit bold :foreground ,blue)))) + `(jabber-chat-prompt-system ((,class (:inherit bold :foreground ,green)))) + `(jabber-chat-text-foreign ((,class (:foreground ,base)))) + `(jabber-chat-text-local ((,class (:foreground ,base)))) + `(jabber-rare-time-face ((,class (:foreground ,green)))) + `(jabber-roster-user-away ((,class (:foreground ,yellow)))) + `(jabber-roster-user-chatty ((,class (:inherit bold :foreground ,green)))) + `(jabber-roster-user-dnd ((,class (:foreground ,red)))) + `(jabber-roster-user-error ((,class (:foreground ,err)))) + `(jabber-roster-user-offline ((,class (:foreground ,base)))) + `(jabber-roster-user-online ((,class (:inherit bold :foreground ,green)))) + `(jabber-roster-user-xa ((,class (:foreground ,aqua)))) + +;;;;; git-gutter-fr + `(git-gutter-fr:added ((,class (:foreground ,green :inherit bold)))) + `(git-gutter-fr:deleted ((,class (:foreground ,war :inherit bold)))) + `(git-gutter-fr:modified ((,class (:foreground ,keyword :inherit bold)))) + +;;;;; git-timemachine + `(git-timemachine-minibuffer-detail-face ((,class (:foreground ,blue :inherit bold :background ,blue-bg)))) + +;;;;; gnus + `(gnus-emphasis-highlight-words ((,class (:background ,suc :foreground ,bg1)))) + `(gnus-header-content ((,class (:foreground ,keyword)))) + `(gnus-header-from ((,class (:foreground ,var)))) + `(gnus-header-name ((,class (:foreground ,comp)))) + `(gnus-header-subject ((,class (:foreground ,func :inherit bold)))) + `(gnus-summary-cancelled ((,class (:background ,war :foreground ,bg1)))) + +;;;;; guide-key + `(guide-key/highlight-command-face ((,class (:foreground ,base)))) + `(guide-key/key-face ((,class (:foreground ,keyword)))) + `(guide-key/prefix-command-face ((,class (:foreground ,keyword :inherit bold)))) + +;;;;; helm + `(helm-bookmark-directory ((,class (:inherit helm-ff-directory)))) + `(helm-bookmark-file ((,class (:foreground ,base)))) + `(helm-bookmark-gnus ((,class (:foreground ,comp)))) + `(helm-bookmark-info ((,class (:foreground ,comp)))) + `(helm-bookmark-man ((,class (:foreground ,comp)))) + `(helm-bookmark-w3m ((,class (:foreground ,comp)))) + `(helm-buffer-directory ((,class (:foreground ,base :background ,bg1)))) + `(helm-buffer-file ((,class (:foreground ,base :background ,bg1)))) + `(helm-buffer-not-saved ((,class (:foreground ,comp :background ,bg1)))) + `(helm-buffer-process ((,class (:foreground ,keyword :background ,bg1)))) + `(helm-buffer-saved-out ((,class (:foreground ,base :background ,bg1)))) + `(helm-buffer-size ((,class (:foreground ,base :background ,bg1)))) + `(helm-candidate-number ((,class (:background ,bg1 :foreground ,keyword :inherit bold)))) + `(helm-ff-directory ((,class (:foreground ,keyword :background ,bg1 :inherit bold)))) + `(helm-ff-dotted-directory ((,class (:foreground ,keyword :background ,bg1 :inherit bold)))) + `(helm-ff-dotted-symlink-directory ((,class (:foreground ,cyan :background ,bg1 :inherit bold)))) + `(helm-ff-executable ((,class (:foreground ,suc :background ,bg1 :weight normal)))) + `(helm-ff-file ((,class (:foreground ,base :background ,bg1 :weight normal)))) + `(helm-ff-invalid-symlink ((,class (:foreground ,red :background ,bg1 :inherit bold)))) + `(helm-ff-prefix ((,class (:foreground ,bg1 :background ,keyword :weight normal)))) + `(helm-ff-symlink ((,class (:foreground ,cyan :background ,bg1 :inherit bold)))) + `(helm-grep-cmd-line ((,class (:foreground ,base :background ,bg1)))) + `(helm-grep-file ((,class (:foreground ,base :background ,bg1)))) + `(helm-grep-finish ((,class (:foreground ,base :background ,bg1)))) + `(helm-grep-lineno ((,class (:foreground ,type :background ,bg1 :inherit bold)))) + `(helm-grep-match ((,class (:foreground nil :background nil :inherit helm-match)))) + `(helm-header ((,class (:foreground ,base :background ,bg1 :underline nil :box nil)))) + `(helm-header-line-left-margin ((,class (:foreground ,keyword :background ,nil)))) + `(helm-match ((,class (:background ,head1-bg :foreground ,head1)))) + `(helm-match-item ((,class (:background ,head1-bg :foreground ,head1)))) + `(helm-moccur-buffer ((,class (:foreground ,var :background ,bg1)))) + `(helm-selection ((,class (:background ,highlight)))) + `(helm-selection-line ((,class (:background ,bg2)))) + `(helm-separator ((,class (:foreground ,comp :background ,bg1)))) + `(helm-source-header ((,class (:background ,comp :foreground ,bg1 :inherit bold)))) + `(helm-time-zone-current ((,class (:foreground ,keyword :background ,bg1)))) + `(helm-time-zone-home ((,class (:foreground ,comp :background ,bg1)))) + `(helm-visible-mark ((,class (:foreground ,keyword :background ,bg3)))) + +;;;;; helm-swoop + `(helm-swoop-target-line-block-face ((,class (:foreground ,base :background ,highlight)))) + `(helm-swoop-target-line-face ((,class (:background ,highlight)))) + `(helm-swoop-target-word-face ((,class (:background ,highlight :foreground ,mat)))) + +;;;;; highlights + `(hi-green ((,class (:foreground ,green :background ,green-bg)))) + `(hi-yellow ((,class (:foreground ,yellow :background ,yellow-bg)))) + +;;;;; highlight-indentation + `(highlight-indentation-face ((,class (:background ,comment-bg)))) + +;;;;; highlight-symbol + `(highlight-symbol-face ((,class (:background ,bg2)))) + +;;;;; hydra + `(hydra-face-blue ((,class (:foreground ,blue)))) + `(hydra-face-red ((,class (:foreground ,red)))) + +;;;;; ido + `(ido-first-match ((,class (:foreground ,comp :inherit bold)))) + `(ido-only-match ((,class (:foreground ,mat :inherit bold)))) + `(ido-subdir ((,class (:foreground ,keyword)))) + `(ido-vertical-match-face ((,class (:foreground ,comp :underline nil)))) + +;;;;; info + `(info-header-xref ((,class (:foreground ,func :underline t)))) + `(info-menu ((,class (:foreground ,suc)))) + `(info-node ((,class (:foreground ,func :inherit bold)))) + `(info-quoted-name ((,class (:foreground ,keyword)))) + `(info-reference-item ((,class (:background nil :underline t :inherit bold)))) + `(info-string ((,class (:foreground ,str)))) + `(info-title-1 ((,class (:height 1.4 :inherit bold)))) + `(info-title-2 ((,class (:height 1.3 :inherit bold)))) + `(info-title-3 ((,class (:height 1.3)))) + `(info-title-4 ((,class (:height 1.2)))) + +;;;;; ivy + `(ivy-current-match ((,class (:background ,highlight :inherit bold)))) + `(ivy-minibuffer-match-face-1 ((,class (:inherit bold)))) + `(ivy-minibuffer-match-face-2 ((,class (:foreground ,head1 :underline t)))) + `(ivy-minibuffer-match-face-3 ((,class (:foreground ,head4 :underline t)))) + `(ivy-minibuffer-match-face-4 ((,class (:foreground ,head3 :underline t)))) + `(ivy-remote ((,class (:foreground ,cyan)))) + +;;;;; ivy-posframe + `(ivy-posframe ((,class (:background ,bg3)))) + +;;;;; latex + `(font-latex-bold-face ((,class (:foreground ,comp)))) + `(font-latex-italic-face ((,class (:foreground ,keyword :italic t)))) + `(font-latex-match-reference-keywords ((,class (:foreground ,const)))) + `(font-latex-match-variable-keywords ((,class (:foreground ,var)))) + `(font-latex-sectioning-0-face ((,class (:inherit bold :foreground ,head3 :height ,(if spacemacs-theme-org-height 1.3 1.0) :background ,(when spacemacs-theme-org-highlight head3-bg))))) + `(font-latex-sectioning-1-face ((,class (:inherit bold :foreground ,head4 :height ,(if spacemacs-theme-org-height 1.3 1.0) :background ,(when spacemacs-theme-org-highlight head4-bg))))) + `(font-latex-sectioning-2-face ((,class (:inherit bold :foreground ,head1 :height ,(if spacemacs-theme-org-height 1.3 1.0) :background ,(when spacemacs-theme-org-highlight head1-bg))))) + `(font-latex-sectioning-3-face ((,class (:inherit bold :foreground ,head2 :height ,(if spacemacs-theme-org-height 1.2 1.0) :background ,(when spacemacs-theme-org-highlight head2-bg))))) + `(font-latex-sectioning-4-face ((,class (:bold nil :foreground ,head3 :height ,(if spacemacs-theme-org-height 1.1 1.0) :background ,(when spacemacs-theme-org-highlight head3-bg))))) + `(font-latex-sectioning-5-face ((,class (:bold nil :foreground ,head4 :background ,(when spacemacs-theme-org-highlight head4-bg))))) + `(font-latex-string-face ((,class (:foreground ,str)))) + `(font-latex-warning-face ((,class (:foreground ,war)))) + +;;;;; ledger-mode + `(ledger-font-directive-face ((,class (:foreground ,meta)))) + `(ledger-font-posting-amount-face ((,class (:foreground ,yellow)))) + `(ledger-font-posting-date-face ((,class (:foreground ,head1)))) + `(ledger-occur-xact-face ((,class (:background ,bg2)))) + +;;;;; linum-mode + `(linum ((,class (:foreground ,lnum :background ,bg2 :inherit default)))) + +;;;;; line-numbers + `(line-number ((,class (:foreground ,lnum :background ,bg2 :inherit default)))) + `(line-number-current-line ((,class (:foreground ,base :background ,bg2 :inherit line-number)))) + +;;;;; linum-relative + `(linum-relative-current-face ((,class (:foreground ,comp)))) + +;;;;; magit + `(magit-blame-culprit ((,class :background ,yellow-bg :foreground ,yellow))) + `(magit-blame-date ((,class :background ,yellow-bg :foreground ,green))) + `(magit-blame-hash ((,class :background ,yellow-bg :foreground ,func))) + `(magit-blame-header ((,class :background ,yellow-bg :foreground ,green))) + `(magit-blame-heading ((,class :background ,yellow-bg :foreground ,green))) + `(magit-blame-name ((,class :background ,yellow-bg :foreground ,yellow))) + `(magit-blame-sha1 ((,class :background ,yellow-bg :foreground ,func))) + `(magit-blame-subject ((,class :background ,yellow-bg :foreground ,yellow))) + `(magit-blame-summary ((,class :background ,yellow-bg :foreground ,yellow :extend t))) + `(magit-blame-time ((,class :background ,yellow-bg :foreground ,green))) + `(magit-branch ((,class (:foreground ,const :inherit bold)))) + `(magit-branch-current ((,class (:background ,blue-bg :foreground ,blue :inherit bold :box t)))) + `(magit-branch-local ((,class (:background ,blue-bg :foreground ,blue :inherit bold)))) + `(magit-branch-remote ((,class (:background ,aqua-bg :foreground ,aqua :inherit bold)))) + `(magit-diff-context-highlight ((,class (:background ,bg2 :foreground ,base :extend t)))) + `(magit-diff-hunk-heading ((,class (:background ,ttip-bg :foreground ,ttip :extend t)))) + `(magit-diff-hunk-heading-highlight ((,class (:background ,ttip-sl :foreground ,base :extend t)))) + `(magit-hash ((,class (:foreground ,var)))) + `(magit-hunk-heading ((,class (:background ,bg3 :extend t)))) + `(magit-hunk-heading-highlight ((,class (:background ,bg3 :extend t)))) + `(magit-item-highlight ((,class :background ,bg2 :extend t))) + `(magit-log-author ((,class (:foreground ,func)))) + `(magit-log-head-label-head ((,class (:background ,yellow :foreground ,bg1 :inherit bold)))) + `(magit-log-head-label-local ((,class (:background ,keyword :foreground ,bg1 :inherit bold)))) + `(magit-log-head-label-remote ((,class (:background ,suc :foreground ,bg1 :inherit bold)))) + `(magit-log-head-label-tags ((,class (:background ,magenta :foreground ,bg1 :inherit bold)))) + `(magit-log-head-label-wip ((,class (:background ,cyan :foreground ,bg1 :inherit bold)))) + `(magit-log-sha1 ((,class (:foreground ,str)))) + `(magit-process-ng ((,class (:foreground ,war :inherit bold)))) + `(magit-process-ok ((,class (:foreground ,func :inherit bold)))) + `(magit-reflog-amend ((,class (:foreground ,magenta)))) + `(magit-reflog-checkout ((,class (:foreground ,blue)))) + `(magit-reflog-cherry-pick ((,class (:foreground ,green)))) + `(magit-reflog-commit ((,class (:foreground ,green)))) + `(magit-reflog-merge ((,class (:foreground ,green)))) + `(magit-reflog-other ((,class (:foreground ,cyan)))) + `(magit-reflog-rebase ((,class (:foreground ,magenta)))) + `(magit-reflog-remote ((,class (:foreground ,cyan)))) + `(magit-reflog-reset ((,class (:foreground ,red)))) + `(magit-section-heading ((,class (:foreground ,keyword :inherit bold :extend t)))) + `(magit-section-highlight ((,class (:background ,bg2 :extend t)))) + `(magit-section-title ((,class (:background ,bg1 :foreground ,keyword :inherit bold)))) + +;;;;; man + `(Man-overstrike ((,class (:foreground ,head1 :inherit bold)))) + `(Man-reverse ((,class (:foreground ,highlight)))) + `(Man-underline ((,class (:foreground ,comp :underline t)))) + +;;;;; markdown + `(markdown-header-face-1 ((,class (:inherit bold :foreground ,head1 :height ,(if spacemacs-theme-org-height 1.3 1.0) :background ,(when spacemacs-theme-org-highlight head1-bg))))) + `(markdown-header-face-2 ((,class (:inherit bold :foreground ,head2 :height ,(if spacemacs-theme-org-height 1.2 1.0) :background ,(when spacemacs-theme-org-highlight head2-bg))))) + `(markdown-header-face-3 ((,class (:bold nil :foreground ,head3 :height ,(if spacemacs-theme-org-height 1.1 1.0) :background ,(when spacemacs-theme-org-highlight head3-bg))))) + `(markdown-header-face-4 ((,class (:bold nil :foreground ,head4 :background ,(when spacemacs-theme-org-highlight head4-bg))))) + `(markdown-header-face-5 ((,class (:bold nil :foreground ,head1)))) + `(markdown-header-face-6 ((,class (:bold nil :foreground ,head2)))) + `(markdown-table-face ((,class (:foreground ,base :background ,head1-bg)))) + +;;;;; mode-line + `(mode-line ((,class (:foreground ,base :background ,act1 :box (:color ,border :line-width 1))))) + `(mode-line-buffer-id ((,class (:inherit bold :foreground ,func)))) + `(mode-line-inactive ((,class (:foreground ,base :background ,bg1 :box (:color ,border :line-width 1))))) + +;;;;; mu4e + `(mu4e-attach-number-face ((,class (:foreground ,var)))) + `(mu4e-cited-1-face ((,class (:foreground ,head1)))) + `(mu4e-cited-2-face ((,class (:foreground ,head2)))) + `(mu4e-cited-3-face ((,class (:foreground ,head3)))) + `(mu4e-cited-4-face ((,class (:foreground ,head4)))) + `(mu4e-cited-5-face ((,class (:foreground ,head1)))) + `(mu4e-cited-6-face ((,class (:foreground ,head2)))) + `(mu4e-cited-7-face ((,class (:foreground ,head3)))) + `(mu4e-contact-face ((,class (:foreground ,func)))) + `(mu4e-draft-face ((,class (:foreground ,var)))) + `(mu4e-flagged-face ((,class (:foreground ,yellow :inherit bold)))) + `(mu4e-header-key-face ((,class (:foreground ,meta :inherit bold)))) + `(mu4e-header-title-face ((,class (:foreground ,keyword :inherit bold)))) + `(mu4e-header-marks-face ((,class (:foreground ,comp)))) + `(mu4e-header-value-face ((,class (:foreground ,keyword :inherit bold)))) + `(mu4e-header-highlight-face ((,class (:background ,highlight)))) + `(mu4e-highlight-face ((,class (:foreground ,comp)))) + `(mu4e-title-face ((,class (:foreground ,head2 :inherit bold)))) + `(mu4e-replied-face ((,class (:foreground ,green)))) + `(mu4e-modeline-face ((,class (:foreground ,yellow)))) + `(mu4e-special-header-value-face ((,class (:foreground ,green)))) + `(mu4e-unread-face ((,class (:foreground ,head1 :inherit bold)))) + `(mu4e-view-url-number-face ((,class (:foreground ,comp)))) + +;;;;; mu4e-maildirs + `(mu4e-maildirs-extension-maildir-hl-face ((,class (:foreground ,head1 :inherit bold)))) + +;;;;; notmuch + `(notmuch-search-date ((,class (:foreground ,func)))) + `(notmuch-search-flagged-face ((,class (:weight extra-bold)))) + `(notmuch-search-non-matching-authors ((,class (:foreground ,base-dim)))) + `(notmuch-search-unread-face ((,class (:background ,highlight-dim)))) + `(notmuch-tag-face ((,class (:foreground ,keyword)))) + `(notmuch-tag-flagged ((,class (:foreground ,war)))) + +;;;;; neotree + `(neo-dir-link-face ((,class (:foreground ,keyword :inherit bold)))) + `(neo-expand-btn-face ((,class (:foreground ,base)))) + `(neo-file-link-face ((,class (:foreground ,base)))) + `(neo-root-dir-face ((,class (:foreground ,func :inherit bold)))) + +;;;;; org + `(org-agenda-clocking ((,class (:background ,highlight :foreground ,comp)))) + `(org-agenda-date ((,class (:foreground ,var :height ,(if spacemacs-theme-org-agenda-height 1.1 1.0))))) + `(org-agenda-date-today ((,class (:foreground ,keyword :inherit bold :height ,(if spacemacs-theme-org-agenda-height 1.3 1.0))))) + `(org-agenda-date-weekend ((,class (:inherit bold :foreground ,var)))) + `(org-agenda-done ((,class (:foreground ,suc :height ,(if spacemacs-theme-org-agenda-height 1.2 1.0))))) + `(org-agenda-structure ((,class (:inherit bold :foreground ,comp)))) + `(org-block ((,class (:background ,cblk-bg :foreground ,cblk :extend t)))) + `(org-block-begin-line ((,class (:background ,cblk-ln-bg :foreground ,cblk-ln :extend t)))) + `(org-block-end-line ((,class (:background ,cblk-ln-bg :foreground ,cblk-ln :extend t)))) + `(org-clock-overlay ((,class (:foreground ,comp)))) + `(org-code ((,class (:foreground ,cyan)))) + `(org-column ((,class (:background ,highlight)))) + `(org-column-title ((,class (:background ,highlight)))) + `(org-date ((,class (:underline t :foreground ,var)))) + `(org-date-selected ((,class (:background ,func :foreground ,bg1)))) + `(org-document-info-keyword ((,class (:foreground ,meta)))) + `(org-document-title ((,class (:foreground ,func :inherit bold :height ,(if spacemacs-theme-org-height 1.4 1.0) :underline t)))) + `(org-done ((,class (:foreground ,suc :inherit bold :background ,green-bg)))) + `(org-ellipsis ((,class (:foreground ,keyword)))) + `(org-footnote ((,class (:underline t :foreground ,base)))) + `(org-hide ((,class (:foreground ,base)))) + `(org-kbd ((,class (:inherit region :foreground ,base :box (:line-width 1 :style released-button))))) + `(org-level-1 ((,class (:inherit bold :bold ,(if spacemacs-theme-org-bold 'unspecified nil) :foreground ,head1 :height ,(if spacemacs-theme-org-height 1.3 1.0) :background ,(when spacemacs-theme-org-highlight head1-bg))))) + `(org-level-2 ((,class (:inherit bold :bold ,(if spacemacs-theme-org-bold 'unspecified nil) :foreground ,head2 :height ,(if spacemacs-theme-org-height 1.2 1.0) :background ,(when spacemacs-theme-org-highlight head2-bg))))) + `(org-level-3 ((,class (:bold nil :foreground ,head3 :height ,(if spacemacs-theme-org-height 1.1 1.0) :background ,(when spacemacs-theme-org-highlight head3-bg))))) + `(org-level-4 ((,class (:bold nil :foreground ,head4 :background ,(when spacemacs-theme-org-highlight head4-bg))))) + `(org-level-5 ((,class (:bold nil :foreground ,head1)))) + `(org-level-6 ((,class (:bold nil :foreground ,head2)))) + `(org-level-7 ((,class (:bold nil :foreground ,head3)))) + `(org-level-8 ((,class (:bold nil :foreground ,head4)))) + `(org-link ((,class (:underline t :foreground ,comment)))) + `(org-meta-line ((,class (:foreground ,meta)))) + `(org-mode-line-clock-overrun ((,class (:foreground ,err)))) + `(org-priority ((,class (:foreground ,war :inherit bold :bold ,(if spacemacs-theme-org-priority-bold 'unspecified nil))))) + `(org-quote ((,class (:inherit org-block :slant italic)))) + `(org-scheduled ((,class (:foreground ,comp)))) + `(org-scheduled-today ((,class (:foreground ,func :height ,(if spacemacs-theme-org-agenda-height 1.2 1.0))))) + `(org-scheduled-previously ((,class (:foreground ,base :slant italic)))) + `(org-sexp-date ((,class (:foreground ,base)))) + `(org-special-keyword ((,class (:foreground ,func)))) + `(org-table ((,class (:foreground ,base :background ,head1-bg)))) + `(org-tag ((,class (:foreground ,meta)))) + `(org-time-grid ((,class (:foreground ,str)))) + `(org-todo ((,class (:foreground ,war :inherit bold :background ,yellow-bg)))) + `(org-upcoming-deadline ((,class (:foreground ,war :inherit org-priority)))) + `(org-upcoming-distant-deadline ((,class (:foreground ,suc :inherit org-priority)))) + `(org-verbatim ((,class (:foreground ,keyword)))) + `(org-verse ((,class (:inherit org-block :slant italic)))) + `(org-warning ((,class (:foreground ,err :inherit org-priority)))) + +;;;;; outline + `(outline-1 ((,class (:inherit org-level-1)))) + `(outline-2 ((,class (:inherit org-level-2)))) + `(outline-3 ((,class (:inherit org-level-3)))) + `(outline-4 ((,class (:inherit org-level-4)))) + `(outline-5 ((,class (:inherit org-level-5)))) + `(outline-6 ((,class (:inherit org-level-6)))) + `(outline-7 ((,class (:inherit org-level-7)))) + `(outline-8 ((,class (:inherit org-level-8)))) + +;;;;; perspective + `(persp-selected-face ((,class (:inherit bold :foreground ,func)))) + +;;;;; popup + `(popup-enu-selection-face ((,class (:background ,ttip-sl :foreground ,base)))) + `(popup-face ((,class (:background ,ttip-bg :foreground ,ttip)))) + `(popup-isearch-match ((,class (:inherit match)))) + `(popup-menu-face ((,class (:background ,ttip-bg :foreground ,base)))) + `(popup-menu-mouse-face ((,class (:inherit highlight)))) + `(popup-scroll-bar-background-face ((,class (:background ,bg2)))) + `(popup-scroll-bar-foreground-face ((,class (:background ,act2)))) + `(popup-tip-face ((,class (:background ,ttip-sl :foreground ,base :bold nil :italic nil :underline nil)))) + +;;;;; powerline + `(powerline-active1 ((,class (:background ,act2 :foreground ,base)))) + `(powerline-active2 ((,class (:background ,act2 :foreground ,base)))) + `(powerline-inactive1 ((,class (:background ,bg2 :foreground ,base)))) + `(powerline-inactive2 ((,class (:background ,bg2 :foreground ,base)))) + +;;;;; rainbow-delimiters + `(rainbow-delimiters-depth-1-face ((,class :foreground ,keyword))) + `(rainbow-delimiters-depth-2-face ((,class :foreground ,func))) + `(rainbow-delimiters-depth-3-face ((,class :foreground ,str))) + `(rainbow-delimiters-depth-4-face ((,class :foreground ,green))) + `(rainbow-delimiters-depth-5-face ((,class :foreground ,yellow))) + `(rainbow-delimiters-depth-6-face ((,class :foreground ,keyword))) + `(rainbow-delimiters-depth-7-face ((,class :foreground ,func))) + `(rainbow-delimiters-depth-8-face ((,class :foreground ,str))) + `(rainbow-delimiters-mismatched-face ((,class :foreground ,err :overline t))) + `(rainbow-delimiters-unmatched-face ((,class :foreground ,err :overline t))) + +;;;;; rcirc + `(rcirc-bright-nick ((,class (:background ,aqua-bg :foreground ,cyan)))) + `(rcirc-dim-nick ((,class (:foreground ,base-dim)))) + `(rcirc-keyword ((,class (:background ,green-bg-s :foreground ,green)))) + `(rcirc-timestamp ((,class (:foreground ,keyword)))) + `(rcirc-track-keyword ((,class (:background ,green :foreground ,bg1)))) + `(rcirc-url ((,class (:inherit link)))) + +;;;;; shm + `(shm-current-face ((,class (:background ,green-bg-s)))) + `(shm-quarantine-face ((,class (:background ,red-bg-s)))) + +;;;;; show-paren + `(show-paren-match ((,class (:foreground ,mat :inherit bold :underline ,(when spacemacs-theme-underline-parens t))))) + `(show-paren-match-expression ((,class (:background ,green-bg-s)))) + `(show-paren-mismatch ((,class (:foreground ,err :inherit bold :underline ,(when spacemacs-theme-underline-parens t))))) + +;;;;; smartparens + `(sp-pair-overlay-face ((,class (:background ,highlight :foreground nil)))) + `(sp-show-pair-match-face ((,class (:foreground ,mat :inherit bold :underline ,(when spacemacs-theme-underline-parens t))))) + +;;;;; smerge + `(smerge-base ((,class (:background ,yellow-bg :extend t)))) + `(smerge-markers ((,class (:background ,ttip-bg :foreground ,ttip :extend t)))) + `(smerge-mine ((,class (:background ,red-bg)))) + `(smerge-other ((,class (:background ,green-bg)))) + `(smerge-refined-added ((,class (:background ,green-bg-s :foreground ,green)))) + `(smerge-refined-changed ((,class (:background ,blue-bg-s :foreground ,blue)))) + `(smerge-refined-removed ((,class (:background ,red-bg-s :foreground ,red)))) + +;;;;; solaire + `(solaire-default-face ((,class (:inherit default :background ,bg2)))) + `(solaire-minibuffer-face ((,class (:inherit default :background ,bg2)))) + `(solaire-hl-line-face ((,class (:inherit hl-line :background ,bg2)))) + `(solaire-org-hide-face ((,class (:inherit org-hide :background ,bg2)))) + +;;;;; spaceline + `(spaceline-flycheck-error ((,class (:foreground ,err)))) + `(spaceline-flycheck-info ((,class (:foreground ,keyword)))) + `(spaceline-flycheck-warning((,class (:foreground ,war)))) + `(spaceline-python-venv ((,class (:foreground ,comp)))) + +;;;;; spacemacs-specific + `(spacemacs-transient-state-title-face ((,class (:background nil :foreground ,comp :box nil :inherit bold)))) + +;;;;; swiper + `(swiper-line-face ((,class (:background ,highlight :inherit bold)))) + `(swiper-match-face-1 ((,class (:inherit bold)))) + `(swiper-match-face-2 ((,class (:foreground ,head1 :underline t)))) + `(swiper-match-face-3 ((,class (:foreground ,head4 :underline t)))) + `(swiper-match-face-4 ((,class (:foreground ,head3 :underline t)))) + +;;;;; tabbar + `(tabbar-button ((,class (:inherit tabbar-default )))) + `(tabbar-button-highlight ((,class (:inherit tabbar-default)))) + `(tabbar-default ((,class (:background ,bg1 :foreground ,head1 :height 0.9)))) + `(tabbar-highlight ((,class (:underline t)))) + `(tabbar-selected ((,class (:inherit tabbar-default :foreground ,func :weight bold)))) + `(tabbar-selected-modified ((,class (:inherit tabbar-default :foreground ,red :weight bold)))) + `(tabbar-separator ((,class (:inherit tabbar-default)))) + `(tabbar-unselected ((,class (:inherit tabbar-default :background ,bg1 :slant italic :weight light)))) + `(tabbar-unselected-modified ((,class (:inherit tabbar-unselected :background ,bg1 :foreground ,red)))) + +;;;;; term + `(term ((,class (:foreground ,base :background ,bg1)))) + `(term-color-black ((,class (:foreground ,bg4 :background ,bg4)))) + `(term-color-blue ((,class (:foreground ,keyword :background ,keyword)))) + `(term-color-cyan ((,class (:foreground ,cyan :background ,cyan)))) + `(term-color-green ((,class (:foreground ,green :background ,green)))) + `(term-color-magenta ((,class (:foreground ,magenta :background ,magenta)))) + `(term-color-red ((,class (:foreground ,red :background ,red)))) + `(term-color-white ((,class (:foreground ,base :background ,base)))) + `(term-color-yellow ((,class (:foreground ,yellow :background ,yellow)))) + +;;;;; vterm + `(vterm-color-default ((,class (:foreground ,base :background ,bg1)))) + ;; vterm-color-black used to render black color code. + ;; The foreground color is used as ANSI color 0 and the background + ;; color is used as ANSI color 8. + `(vterm-color-black ((,class (:foreground ,bg4 :background ,bg4)))) + `(vterm-color-blue ((,class (:foreground ,blue :background ,blue)))) + `(vterm-color-cyan ((,class (:foreground ,cyan :background ,cyan)))) + `(vterm-color-green ((,class (:foreground ,green :background ,green)))) + `(vterm-color-magenta ((,class (:foreground ,magenta :background ,magenta)))) + `(vterm-color-red ((,class (:foreground ,red :background ,red)))) + `(vterm-color-white ((,class (:foreground ,base :background ,base)))) + `(vterm-color-yellow ((,class (:foreground ,yellow :background ,yellow)))) + +;;;;; tide + `(tide-hl-identifier-face ((,class (:foreground ,yellow :background ,yellow-bg)))) + +;;;;; treemacs + `(treemacs-git-added-face ((,class (:foreground ,green :background ,green-bg)))) + `(treemacs-git-conflict-face ((,class (:foreground ,red :background ,red-bg)))) + `(treemacs-git-ignored-face ((,class (:foreground ,yellow)))) + `(treemacs-git-modified-face ((,class (:foreground ,blue :background ,blue-bg)))) + `(treemacs-git-untracked-face ((,class (:foreground ,aqua :background ,aqua-bg)))) + +;;;;; web-mode + `(web-mode-builtin-face ((,class (:inherit ,font-lock-builtin-face)))) + `(web-mode-comment-face ((,class (:inherit ,font-lock-comment-face)))) + `(web-mode-constant-face ((,class (:inherit ,font-lock-constant-face)))) + `(web-mode-current-element-highlight-face ((,class (:background ,bg3)))) + `(web-mode-doctype-face ((,class (:inherit ,font-lock-comment-face)))) + `(web-mode-function-name-face ((,class (:inherit ,font-lock-function-name-face)))) + `(web-mode-html-attr-name-face ((,class (:foreground ,func)))) + `(web-mode-html-attr-value-face ((,class (:foreground ,keyword)))) + `(web-mode-html-tag-face ((,class (:foreground ,keyword)))) + `(web-mode-keyword-face ((,class (:foreground ,keyword)))) + `(web-mode-string-face ((,class (:foreground ,str)))) + `(web-mode-symbol-face ((,class (:foreground ,type)))) + `(web-mode-type-face ((,class (:inherit ,font-lock-type-face)))) + `(web-mode-warning-face ((,class (:inherit ,font-lock-warning-face)))) + +;;;;; which-key + `(which-key-command-description-face ((,class (:foreground ,base)))) + `(which-key-group-description-face ((,class (:foreground ,keyword)))) + `(which-key-key-face ((,class (:foreground ,func :inherit bold)))) + `(which-key-separator-face ((,class (:background nil :foreground ,str)))) + `(which-key-special-key-face ((,class (:background ,func :foreground ,bg1)))) + +;;;;; which-function-mode + `(which-func ((,class (:foreground ,func)))) + +;;;;; whitespace-mode + `(whitespace-empty ((,class (:background nil :foreground ,yellow)))) + `(whitespace-indentation ((,class (:background nil :foreground ,war)))) + `(whitespace-line ((,class (:background nil :foreground ,comp)))) + `(whitespace-newline ((,class (:background nil :foreground ,comp)))) + `(whitespace-space ((,class (:background nil :foreground ,act2)))) + `(whitespace-space-after-tab ((,class (:background nil :foreground ,yellow)))) + `(whitespace-space-before-tab ((,class (:background nil :foreground ,yellow)))) + `(whitespace-tab ((,class (:background nil :foreground ,act2)))) + `(whitespace-trailing ((,class (:background ,err :foreground ,war)))) + +;;;;; other, need more work + `(ac-completion-face ((,class (:underline t :foreground ,keyword)))) + `(ffap ((,class (:foreground ,base)))) + `(flx-highlight-face ((,class (:foreground ,comp :underline nil)))) + `(icompletep-determined ((,class :foreground ,keyword))) + `(js2-external-variable ((,class (:foreground ,comp)))) + `(js2-function-param ((,class (:foreground ,const)))) + `(js2-jsdoc-html-tag-delimiter ((,class (:foreground ,str)))) + `(js2-jsdoc-html-tag-name ((,class (:foreground ,keyword)))) + `(js2-jsdoc-value ((,class (:foreground ,str)))) + `(js2-private-function-call ((,class (:foreground ,const)))) + `(js2-private-member ((,class (:foreground ,base)))) + `(js3-error-face ((,class (:underline ,war)))) + `(js3-external-variable-face ((,class (:foreground ,var)))) + `(js3-function-param-face ((,class (:foreground ,keyword)))) + `(js3-instance-member-face ((,class (:foreground ,const)))) + `(js3-jsdoc-tag-face ((,class (:foreground ,keyword)))) + `(js3-warning-face ((,class (:underline ,keyword)))) + `(slime-repl-inputed-output-face ((,class (:foreground ,comp)))) + `(trailing-whitespace ((,class :foreground nil :background ,err))) + `(undo-tree-visualizer-current-face ((,class :foreground ,keyword))) + `(undo-tree-visualizer-default-face ((,class :foreground ,base))) + `(undo-tree-visualizer-register-face ((,class :foreground ,comp))) + `(undo-tree-visualizer-unmodified-face ((,class :foreground ,var)))) + + (custom-theme-set-variables + theme-name + +;;;;; ansi-color-names + `(ansi-color-names-vector [,bg4 ,red ,green ,yellow ,blue ,magenta ,cyan ,base]) + +;;;;; hl-todo + `(hl-todo-keyword-faces '(("TODO" . ,war) + ("NEXT" . ,war) + ("THEM" . ,aqua) + ("PROG" . ,blue) + ("OKAY" . ,blue) + ("DONT" . ,red) + ("FAIL" . ,red) + ("DONE" . ,suc) + ("NOTE" . ,yellow) + ("KLUDGE" . ,yellow) + ("HACK" . ,yellow) + ("TEMP" . ,yellow) + ("FIXME" . ,war) + ("XXX+" . ,war) + ("\\?\\?\\?+" . ,war))) + + +;;;;; pdf-tools + `(pdf-view-midnight-colors '(,base . ,bg1))) + )) + + +;;;###autoload +(when load-file-name + (add-to-list 'custom-theme-load-path + (file-name-as-directory (file-name-directory load-file-name)))) + +(provide 'spacemacs-common) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; spacemacs-common.el ends here diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.el b/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.el new file mode 100644 index 00000000..7b5e33f3 --- /dev/null +++ b/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.el @@ -0,0 +1,7 @@ +(require 'spacemacs-common) + +(deftheme spacemacs-dark "Spacemacs theme, the dark version") + +(create-spacemacs-theme 'dark 'spacemacs-dark) + +(provide-theme 'spacemacs-dark) diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.elc b/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.elc new file mode 100644 index 00000000..f35e636c Binary files /dev/null and b/elpa/spacemacs-theme-20200322.1408/spacemacs-dark-theme.elc differ diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.el b/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.el new file mode 100644 index 00000000..4b68588d --- /dev/null +++ b/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.el @@ -0,0 +1,7 @@ +(require 'spacemacs-common) + +(deftheme spacemacs-light "Spacemacs theme, the light version") + +(create-spacemacs-theme 'light 'spacemacs-light) + +(provide-theme 'spacemacs-light) diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.elc b/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.elc new file mode 100644 index 00000000..06e314ca Binary files /dev/null and b/elpa/spacemacs-theme-20200322.1408/spacemacs-light-theme.elc differ diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-autoloads.el b/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-autoloads.el new file mode 100644 index 00000000..1cf5d534 --- /dev/null +++ b/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-autoloads.el @@ -0,0 +1,45 @@ +;;; spacemacs-theme-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "spacemacs-common" "spacemacs-common.el" (0 +;;;;;; 0 0 0)) +;;; Generated autoloads from spacemacs-common.el + +(when load-file-name (add-to-list 'custom-theme-load-path (file-name-as-directory (file-name-directory load-file-name)))) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spacemacs-common" '("create-spacemacs-theme" "true-color-p" "spacemacs-theme-"))) + +;;;*** + +;;;### (autoloads nil "spacemacs-dark-theme" "spacemacs-dark-theme.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from spacemacs-dark-theme.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spacemacs-dark-theme" '("spacemacs-dark"))) + +;;;*** + +;;;### (autoloads nil "spacemacs-light-theme" "spacemacs-light-theme.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from spacemacs-light-theme.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spacemacs-light-theme" '("spacemacs-light"))) + +;;;*** + +;;;### (autoloads nil nil ("spacemacs-theme-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; spacemacs-theme-autoloads.el ends here diff --git a/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-pkg.el b/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-pkg.el new file mode 100644 index 00000000..d243e01a --- /dev/null +++ b/elpa/spacemacs-theme-20200322.1408/spacemacs-theme-pkg.el @@ -0,0 +1,6 @@ +(define-package "spacemacs-theme" "20200322.1408" "Color theme with a dark and light versions" 'nil :keywords + '("color" "theme") + :url "https://github.com/nashamri/spacemacs-theme") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/websocket-20200321.102/websocket-autoloads.el b/elpa/websocket-20200321.102/websocket-autoloads.el new file mode 100644 index 00000000..63674c3d --- /dev/null +++ b/elpa/websocket-20200321.102/websocket-autoloads.el @@ -0,0 +1,22 @@ +;;; websocket-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "websocket" "websocket.el" (0 0 0 0)) +;;; Generated autoloads from websocket.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "websocket" '("websocket-"))) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; websocket-autoloads.el ends here diff --git a/elpa/websocket-20200321.102/websocket-pkg.el b/elpa/websocket-20200321.102/websocket-pkg.el new file mode 100644 index 00000000..44d2f748 --- /dev/null +++ b/elpa/websocket-20200321.102/websocket-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "websocket" "20200321.102" "Emacs WebSocket client and server" '((cl-lib "0.5")) :commit "31e122a9d7a1ae092e8f970df718fb8256e16574" :keywords '("communication" "websocket" "server") :authors '(("Andrew Hyatt" . "ahyatt@gmail.com")) :maintainer '("Andrew Hyatt" . "ahyatt@gmail.com") :url "https://github.com/ahyatt/emacs-websocket") diff --git a/elpa/websocket-20200321.102/websocket.el b/elpa/websocket-20200321.102/websocket.el new file mode 100644 index 00000000..4888fc7c --- /dev/null +++ b/elpa/websocket-20200321.102/websocket.el @@ -0,0 +1,1068 @@ +;;; websocket.el --- Emacs WebSocket client and server -*- lexical-binding:t -*- + +;; Copyright (c) 2013, 2016-2017 Free Software Foundation, Inc. + +;; Author: Andrew Hyatt +;; Homepage: https://github.com/ahyatt/emacs-websocket +;; Keywords: Communication, Websocket, Server +;; Package-Version: 20200321.102 +;; Version: 1.12 +;; Package-Requires: ((cl-lib "0.5")) +;; +;; This program 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 2 of the +;; License, or (at your option) any later version. +;; +;; This program 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 . + +;;; Commentary: +;; This implements RFC 6455, which can be found at +;; http://tools.ietf.org/html/rfc6455. +;; +;; This library contains code to connect Emacs as a client to a +;; websocket server, and for Emacs to act as a server for websocket +;; connections. +;; +;; Websockets clients are created by calling `websocket-open', which +;; returns a `websocket' struct. Users of this library use the +;; websocket struct, and can call methods `websocket-send-text', which +;; sends text over the websocket, or `websocket-send', which sends a +;; `websocket-frame' struct, enabling finer control of what is sent. +;; A callback is passed to `websocket-open' that will retrieve +;; websocket frames called from the websocket. Websockets are +;; eventually closed with `websocket-close'. +;; +;; Server functionality is similar. A server is started with +;; `websocket-server' called with a port and the callbacks to use, +;; which returns a process. The process can later be closed with +;; `websocket-server-close'. A `websocket' struct is also created +;; for every connection, and is exposed through the callbacks. + +(require 'bindat) +(require 'url-parse) +(require 'url-cookie) +(require 'seq) +(eval-when-compile (require 'cl-lib)) + +;;; Code: + +(cl-defstruct (websocket + (:constructor nil) + (:constructor websocket-inner-create)) + "A websocket structure. +This follows the W3C Websocket API, except translated to elisp +idioms. The API is implemented in both the websocket struct and +additional methods. Due to how defstruct slots are accessed, all +API methods are prefixed with \"websocket-\" and take a websocket +as an argument, so the distrinction between the struct API and +the additional helper APIs are not visible to the caller. + +A websocket struct is created with `websocket-open'. + +`ready-state' contains one of `connecting', `open', or +`closed', depending on the state of the websocket. + +The W3C API \"bufferedAmount\" call is not currently implemented, +since there is no elisp API to get the buffered amount from the +subprocess. There may, in fact, be output data buffered, +however, when the `on-message' or `on-close' callbacks are +called. + +`on-open', `on-message', `on-close', and `on-error' are described +in `websocket-open'. + +The `negotiated-extensions' slot lists the extensions accepted by +both the client and server, and `negotiated-protocols' does the +same for the protocols." + ;; API + (ready-state 'connecting) + client-data + on-open + on-message + on-close + on-error + negotiated-protocols + negotiated-extensions + (server-p nil :read-only t) + + ;; Other data - clients should not have to access this. + (url (cl-assert nil) :read-only t) + (protocols nil :read-only t) + (extensions nil :read-only t) + (conn (cl-assert nil) :read-only t) + ;; Only populated for servers, this is the server connection. + server-conn + accept-string + (inflight-input nil)) + +(defvar websocket-version "1.12" + "Version numbers of this version of websocket.el.") + +(defvar websocket-debug nil + "Set to true to output debugging info to a per-websocket buffer. +The buffer is ` *websocket URL debug*' where URL is the +URL of the connection.") + +(defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + "The websocket GUID as defined in RFC 6455. +Do not change unless the RFC changes.") + +(defvar websocket-callback-debug-on-error nil + "If true, when an error happens in a client callback, invoke the debugger. +Having this on can cause issues with missing frames if the debugger is +exited by quitting instead of continuing, so it's best to have this set +to nil unless it is especially needed.") + +(defmacro websocket-document-function (function docstring) + "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc." + (declare (indent defun) + (doc-string 2)) + `(put ',function 'function-documentation ,docstring)) + +(websocket-document-function websocket-on-open + "Accessor for websocket on-open callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-message + "Accessor for websocket on-message callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-close + "Accessor for websocket on-close callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-error + "Accessor for websocket on-error callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(defun websocket-genbytes (nbytes) + "Generate NBYTES random bytes." + (let ((s (make-string nbytes ?\s))) + (dotimes (i nbytes) + (aset s i (random 256))) + s)) + +(defun websocket-try-callback (websocket-callback callback-type websocket + &rest rest) + "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args. +If an error happens, it is handled according to +`websocket-callback-debug-on-error'." + ;; This looks like it should be able to done more efficiently, but + ;; I'm not sure that's the case. We can't do it as a macro, since + ;; we want it to change whenever websocket-callback-debug-on-error + ;; changes. + (let ((args rest) + (debug-on-error websocket-callback-debug-on-error)) + (push websocket args) + (if websocket-callback-debug-on-error + (condition-case err + (apply (funcall websocket-callback websocket) args) + ((debug error) (funcall (websocket-on-error websocket) + websocket callback-type err))) + (condition-case err + (apply (funcall websocket-callback websocket) args) + (error (funcall (websocket-on-error websocket) websocket + callback-type err)))))) + +(defun websocket-genkey () + "Generate a key suitable for the websocket handshake." + (base64-encode-string (websocket-genbytes 16))) + +(defun websocket-calculate-accept (key) + "Calculate the expect value of the accept header. +This is based on the KEY from the Sec-WebSocket-Key header." + (base64-encode-string + (sha1 (concat key websocket-guid) nil nil t))) + +(defun websocket-get-bytes (s n) + "From string S, retrieve the value of N bytes. +Return the value as an unsigned integer. The value N must be a +power of 2, up to 8. + +We support getting frames up to 536870911 bytes (2^29 - 1), +approximately 537M long." + (if (= n 8) + (let* ((32-bit-parts + (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val)) + (cval + (logior (lsh (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1)))) + (if (and (= (aref 32-bit-parts 0) 0) + (= (lsh (aref 32-bit-parts 1) -29) 0)) + cval + (signal 'websocket-unparseable-frame + (list "Frame value found too large to parse!")))) + ;; n is not 8 + (bindat-get-field + (condition-case _ + (bindat-unpack + `((:val + ,(cond ((= n 1) 'u8) + ((= n 2) 'u16) + ((= n 4) 'u32) + ;; This is an error with the library, + ;; not a user-facing, meaningful error. + (t (error + "websocket-get-bytes: Unknown N: %S" n))))) + s) + (args-out-of-range (signal 'websocket-unparseable-frame + (list (format "Frame unexpectedly short: %s" s))))) + :val))) + +(defun websocket-to-bytes (val nbytes) + "Encode the integer VAL in NBYTES of data. +NBYTES much be a power of 2, up to 8. + +This supports encoding values up to 536870911 bytes (2^29 - 1), +approximately 537M long." + (when (and (< nbytes 8) + (> val (expt 2 (* 8 nbytes)))) + ;; not a user-facing error, this must be caused from an error in + ;; this library + (error "websocket-to-bytes: Value %d could not be expressed in %d bytes" + val nbytes)) + (if (= nbytes 8) + (progn + (let* ((hi-32bits (lsh val -32)) + ;; This is just VAL on systems that don't have >= 32 bits. + (low-32bits (- val (lsh hi-32bits 32)))) + (when (or (> hi-32bits 0) (> (lsh low-32bits -29) 0)) + (signal 'websocket-frame-too-large (list val))) + (bindat-pack `((:val vec 2 u32)) + `((:val . [,hi-32bits ,low-32bits]))))) + (bindat-pack + `((:val ,(cond ((= nbytes 1) 'u8) + ((= nbytes 2) 'u16) + ((= nbytes 4) 'u32) + ;; Library error, not system error + (t (error "websocket-to-bytes: Unknown NBYTES: %S" nbytes))))) + `((:val . ,val))))) + +(defun websocket-get-opcode (s) + "Retrieve the opcode from first byte of string S." + (websocket-ensure-length s 1) + (let ((opcode (logand #xf (aref s 0)))) + (cond ((= opcode 0) 'continuation) + ((= opcode 1) 'text) + ((= opcode 2) 'binary) + ((= opcode 8) 'close) + ((= opcode 9) 'ping) + ((= opcode 10) 'pong)))) + +(defun websocket-get-payload-len (s) + "Parse out the payload length from the string S. +We start at position 0, and return a cons of the payload length and how +many bytes were consumed from the string." + (websocket-ensure-length s 1) + (let* ((initial-val (logand 127 (aref s 0)))) + (cond ((= initial-val 127) + (websocket-ensure-length s 9) + (cons (websocket-get-bytes (substring s 1) 8) 9)) + ((= initial-val 126) + (websocket-ensure-length s 3) + (cons (websocket-get-bytes (substring s 1) 2) 3)) + (t (cons initial-val 1))))) + +(cl-defstruct websocket-frame opcode payload length completep) + +(defun websocket-frame-text (frame) + "Given FRAME, return the payload as a utf-8 encoded string." + (cl-assert (websocket-frame-p frame)) + (decode-coding-string (websocket-frame-payload frame) 'utf-8)) + +(defun websocket-mask (key data) + "Using string KEY, mask string DATA according to the RFC. +This is used to both mask and unmask data." + ;; Returning the string as unibyte is important here. Because we set the + ;; string byte by byte, this results in a unibyte string. + (cl-loop + with result = (make-string (length data) ?x) + for i from 0 below (length data) + do (setf (seq-elt result i) (logxor (aref key (mod i 4)) (seq-elt data i))) + finally return result)) + +(defun websocket-ensure-length (s n) + "Ensure the string S has at most N bytes. +Otherwise we throw the error `websocket-incomplete-frame'." + (when (< (length s) n) + (throw 'websocket-incomplete-frame nil))) + +(defun websocket-encode-frame (frame should-mask) + "Encode the FRAME struct to the binary representation. +We mask the frame or not, depending on SHOULD-MASK." + (let* ((opcode (websocket-frame-opcode frame)) + (payload (websocket-frame-payload frame)) + (fin (websocket-frame-completep frame)) + (payloadp (and payload + (memq opcode '(continuation ping pong text binary)))) + (mask-key (when should-mask (websocket-genbytes 4)))) + (apply #'unibyte-string + (let ((val (append (list + (logior (pcase opcode + (`continuation 0) + (`text 1) + (`binary 2) + (`close 8) + (`ping 9) + (`pong 10)) + (if fin 128 0))) + (when payloadp + (list + (logior + (if should-mask 128 0) + (cond ((< (length payload) 126) (length payload)) + ((< (length payload) 65536) 126) + (t 127))))) + (when (and payloadp (>= (length payload) 126)) + (append (websocket-to-bytes + (length payload) + (cond ((< (length payload) 126) 1) + ((< (length payload) 65536) 2) + (t 8))) nil)) + (when (and payloadp should-mask) + (append mask-key nil)) + (when payloadp + (append (if should-mask (websocket-mask mask-key payload) + payload) + nil))))) + ;; We have to make sure the non-payload data is a full 32-bit frame + (if (= 1 (length val)) + (append val '(0)) val))))) + +(defun websocket-read-frame (s) + "Read from string S a `websocket-frame' struct with the contents. +This only gets complete frames. Partial frames need to wait until +the frame finishes. If the frame is not completed, return NIL." + (catch 'websocket-incomplete-frame + (websocket-ensure-length s 1) + (let* ((opcode (websocket-get-opcode s)) + (fin (logand 128 (aref s 0))) + (payloadp (memq opcode '(continuation text binary ping pong))) + (payload-len (when payloadp + (websocket-get-payload-len (substring s 1)))) + (maskp (and + payloadp + (= 128 (logand 128 (aref s 1))))) + (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len)))) + (payload-end (when payloadp (+ payload-start (car payload-len)))) + (unmasked-payload (when payloadp + (websocket-ensure-length s payload-end) + (substring s payload-start payload-end)))) + (make-websocket-frame + :opcode opcode + :payload + (if maskp + (let ((masking-key (substring s (+ 1 (cdr payload-len)) + (+ 5 (cdr payload-len))))) + (websocket-mask masking-key unmasked-payload)) + unmasked-payload) + :length (if payloadp payload-end 1) + :completep (> fin 0))))) + +(defun websocket-format-error (err) + "Format an error message like command level does. +ERR should be a cons of error symbol and error data." + + ;; Formatting code adapted from `edebug-report-error' + (concat (or (get (car err) 'error-message) + (format "peculiar error (%s)" (car err))) + (when (cdr err) + (format ": %s" + (mapconcat #'prin1-to-string + (cdr err) ", "))))) + +(defun websocket-default-error-handler (_websocket type err) + "The default error handler used to handle errors in callbacks." + (display-warning 'websocket + (format "in callback `%S': %s" + type + (websocket-format-error err)) + :error)) + +;; Error symbols in use by the library +(put 'websocket-unsupported-protocol 'error-conditions + '(error websocket-error websocket-unsupported-protocol)) +(put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol") +(put 'websocket-wss-needs-emacs-24 'error-conditions + '(error websocket-error websocket-unsupported-protocol + websocket-wss-needs-emacs-24)) +(put 'websocket-wss-needs-emacs-24 'error-message + "wss protocol is not supported for Emacs before version 24.") +(put 'websocket-received-error-http-response 'error-conditions + '(error websocket-error websocket-received-error-http-response)) +(put 'websocket-received-error-http-response 'error-message + "Error response received from websocket server") +(put 'websocket-invalid-header 'error-conditions + '(error websocket-error websocket-invalid-header)) +(put 'websocket-invalid-header 'error-message + "Invalid HTTP header sent") +(put 'websocket-illegal-frame 'error-conditions + '(error websocket-error websocket-illegal-frame)) +(put 'websocket-illegal-frame 'error-message + "Cannot send illegal frame to websocket") +(put 'websocket-closed 'error-conditions + '(error websocket-error websocket-closed)) +(put 'websocket-closed 'error-message + "Cannot send message to a closed websocket") +(put 'websocket-unparseable-frame 'error-conditions + '(error websocket-error websocket-unparseable-frame)) +(put 'websocket-unparseable-frame 'error-message + "Received an unparseable frame") +(put 'websocket-frame-too-large 'error-conditions + '(error websocket-error websocket-frame-too-large)) +(put 'websocket-frame-too-large 'error-message + "The frame being sent is too large for this emacs to handle") + +(defun websocket-intersect (a b) + "Simple list intersection, should function like Common Lisp's `intersection'." + (let ((result)) + (dolist (elem a (nreverse result)) + (when (member elem b) + (push elem result))))) + +(defun websocket-get-debug-buffer-create (websocket) + "Get or create the buffer corresponding to WEBSOCKET." + (let ((buf (get-buffer-create (format "*websocket %s debug*" + (websocket-url websocket))))) + (when (= 0 (buffer-size buf)) + (buffer-disable-undo buf)) + buf)) + +(defun websocket-debug (websocket msg &rest args) + "In the WEBSOCKET's debug buffer, send MSG, with format ARGS." + (when websocket-debug + (let ((buf (websocket-get-debug-buffer-create websocket))) + (save-excursion + (with-current-buffer buf + (goto-char (point-max)) + (insert "[WS] ") + (insert (apply #'format (append (list msg) args))) + (insert "\n")))))) + +(defun websocket-verify-response-code (output) + "Verify that OUTPUT contains a valid HTTP response code. +The only acceptable one to websocket is responce code 101. +A t value will be returned on success, and an error thrown +if not." + (unless (string-match "^HTTP/1.1 \\([[:digit:]]+\\)" output) + (signal 'websocket-invalid-header (list "Invalid HTTP status line"))) + (unless (equal "101" (match-string 1 output)) + (signal 'websocket-received-error-http-response + (list (string-to-number (match-string 1 output))))) + t) + +(defun websocket-parse-repeated-field (output field) + "From header-containing OUTPUT, parse out the list from a +possibly repeated field." + (let ((pos 0) + (extensions)) + (while (and pos + (string-match (format "\r\n%s: \\(.*\\)\r\n" field) + output pos)) + (when (setq pos (match-end 1)) + (setq extensions (append extensions (split-string + (match-string 1 output) ", ?"))))) + extensions)) + +(defun websocket-process-frame (websocket frame) + "Using the WEBSOCKET's filter and connection, process the FRAME. +This returns a lambda that should be executed when all frames have +been processed. If the frame has a payload, the lambda has the frame +passed to the filter slot of WEBSOCKET. If the frame is a ping, +the lambda has a reply with a pong. If the frame is a close, the lambda +has connection termination." + (let ((opcode (websocket-frame-opcode frame))) + (cond ((memq opcode '(continuation text binary)) + (lambda () (websocket-try-callback 'websocket-on-message 'on-message + websocket frame))) + ((eq opcode 'ping) + (lambda () (websocket-send websocket + (make-websocket-frame + :opcode 'pong + :payload (websocket-frame-payload frame) + :completep t)))) + ((eq opcode 'close) + (lambda () (delete-process (websocket-conn websocket)))) + (t (lambda ()))))) + +(defun websocket-process-input-on-open-ws (websocket text) + "This handles input processing for both the client and server filters." + (let ((current-frame) + (processing-queue) + (start-point 0)) + (while (setq current-frame (websocket-read-frame + (substring text start-point))) + (push (websocket-process-frame websocket current-frame) processing-queue) + (cl-incf start-point (websocket-frame-length current-frame))) + (when (> (length text) start-point) + (setf (websocket-inflight-input websocket) + (substring text start-point))) + (dolist (to-process (nreverse processing-queue)) + (funcall to-process)))) + +(defun websocket-send-text (websocket text) + "To the WEBSOCKET, send TEXT as a complete frame." + (websocket-send + websocket + (make-websocket-frame :opcode 'text + :payload (encode-coding-string + text 'raw-text) + :completep t))) + +(defun websocket-check (frame) + "Check FRAME for correctness, returning true if correct." + (or + ;; Text, binary, and continuation frames need payloads + (and (memq (websocket-frame-opcode frame) '(text binary continuation)) + (websocket-frame-payload frame)) + ;; Pings and pongs may optionally have them + (memq (websocket-frame-opcode frame) '(ping pong)) + ;; And close shouldn't have any payload, and should always be complete. + (and (eq (websocket-frame-opcode frame) 'close) + (not (websocket-frame-payload frame)) + (websocket-frame-completep frame)))) + +(defun websocket-send (websocket frame) + "To the WEBSOCKET server, send the FRAME. +This will raise an error if the frame is illegal. + +The error signaled may be of type `websocket-illegal-frame' if +the frame is malformed in some way, also having the condition +type of `websocket-error'. The data associated with the signal +is the frame being sent. + +If the websocket is closed a signal `websocket-closed' is sent, +also with `websocket-error' condition. The data in the signal is +also the frame. + +The frame may be too large for this buid of Emacs, in which case +`websocket-frame-too-large' is returned, with the data of the +size of the frame which was too large to process. This also has +the `websocket-error' condition." + (unless (websocket-check frame) + (signal 'websocket-illegal-frame (list frame))) + (websocket-debug websocket "Sending frame, opcode: %s payload: %s" + (websocket-frame-opcode frame) + (websocket-frame-payload frame)) + (websocket-ensure-connected websocket) + (unless (websocket-openp websocket) + (signal 'websocket-closed (list frame))) + (process-send-string (websocket-conn websocket) + ;; We mask only when we're a client, following the spec. + (websocket-encode-frame frame (not (websocket-server-p websocket))))) + +(defun websocket-openp (websocket) + "Check WEBSOCKET and return non-nil if the connection is open." + (and websocket + (not (eq 'close (websocket-ready-state websocket))) + (member (process-status (websocket-conn websocket)) '(open run)))) + +(defun websocket-close (websocket) + "Close WEBSOCKET and erase all the old websocket data." + (websocket-debug websocket "Closing websocket") + (websocket-try-callback 'websocket-on-close 'on-close websocket) + (when (websocket-openp websocket) + (websocket-send websocket + (make-websocket-frame :opcode 'close + :completep t)) + (setf (websocket-ready-state websocket) 'closed)) + (delete-process (websocket-conn websocket))) + +(defun websocket-ensure-connected (websocket) + "If the WEBSOCKET connection is closed, open it." + (unless (and (websocket-conn websocket) + (cl-ecase (process-status (websocket-conn websocket)) + ((run open listen) t) + ((stop exit signal closed connect failed nil) nil))) + (websocket-close websocket) + (websocket-open (websocket-url websocket) + :protocols (websocket-protocols websocket) + :extensions (websocket-extensions websocket) + :on-open (websocket-on-open websocket) + :on-message (websocket-on-message websocket) + :on-close (websocket-on-close websocket) + :on-error (websocket-on-error websocket)))) + +;;;;;;;;;;;;;;;;;;;;;; +;; Websocket client ;; +;;;;;;;;;;;;;;;;;;;;;; + +(cl-defun websocket-open (url &key protocols extensions (on-open 'identity) + (on-message (lambda (_w _f))) (on-close 'identity) + (on-error 'websocket-default-error-handler) + (nowait nil) (custom-header-alist nil)) + "Open a websocket connection to URL, returning the `websocket' struct. +The PROTOCOL argument is optional, and setting it will declare to +the server that this client supports the protocols in the list +given. We will require that the server also has to support that +protocols. + +Similar logic applies to EXTENSIONS, which is a list of conses, +the car of which is a string naming the extension, and the cdr of +which is the list of parameter strings to use for that extension. +The parameter strings are of the form \"key=value\" or \"value\". +EXTENSIONS can be NIL if none are in use. An example value would +be (\"deflate-stream\" . (\"mux\" \"max-channels=4\")). + +Cookies that are set via `url-cookie-store' will be used during +communication with the server, and cookies received from the +server will be stored in the same cookie storage that the +`url-cookie' package uses. + +Optionally you can specify +ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well. + +The ON-OPEN callback is called after the connection is +established with the websocket as the only argument. The return +value is unused. + +The ON-MESSAGE callback is called after receiving a frame, and is +called with the websocket as the first argument and +`websocket-frame' struct as the second. The return value is +unused. + +The ON-CLOSE callback is called after the connection is closed, or +failed to open. It is called with the websocket as the only +argument, and the return value is unused. + +The ON-ERROR callback is called when any of the other callbacks +have an error. It takes the websocket as the first argument, and +a symbol as the second argument either `on-open', `on-message', +or `on-close', and the error as the third argument. Do NOT +rethrow the error, or else you may miss some websocket messages. +You similarly must not generate any other errors in this method. +If you want to debug errors, set +`websocket-callback-debug-on-error' to t, but this also can be +dangerous is the debugger is quit out of. If not specified, +`websocket-default-error-handler' is used. + +For each of these event handlers, the client code can store +arbitrary data in the `client-data' slot in the returned +websocket. + +The following errors might be thrown in this method or in +websocket processing, all of them having the error-condition +`websocket-error' in addition to their own symbol: + +`websocket-unsupported-protocol': Data in the error signal is the +protocol that is unsupported. For example, giving a URL starting +with http by mistake raises this error. + +`websocket-wss-needs-emacs-24': Trying to connect wss protocol +using Emacs < 24 raises this error. You can catch this error +also by `websocket-unsupported-protocol'. + +`websocket-received-error-http-response': Data in the error +signal is the integer error number. + +`websocket-invalid-header': Data in the error is a string +describing the invalid header received from the server. + +`websocket-unparseable-frame': Data in the error is a string +describing the problem with the frame. + +`nowait': If NOWAIT is true, return without waiting for the +connection to complete. + +`custom-headers-alist': An alist of custom headers to pass to the +server. The car is the header name, the cdr is the header value. +These are different from the extensions because it is not related +to the websocket protocol. +" + (let* ((name (format "websocket to %s" url)) + (url-struct (url-generic-parse-url url)) + (key (websocket-genkey)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (conn (if (member (url-type url-struct) '("ws" "wss")) + (let* ((type (if (equal (url-type url-struct) "ws") + 'plain 'tls)) + (port (if (= 0 (url-port url-struct)) + (if (eq type 'tls) 443 80) + (url-port url-struct))) + (host (url-host url-struct))) + (if (eq type 'plain) + (make-network-process :name name :buffer nil :host host + :service port :nowait nowait) + (condition-case-unless-debug nil + (open-network-stream name nil host port :type type :nowait nowait) + (wrong-number-of-arguments + (signal 'websocket-wss-needs-emacs-24 (list "wss")))))) + (signal 'websocket-unsupported-protocol (list (url-type url-struct))))) + (websocket (websocket-inner-create + :conn conn + :url url + :on-open on-open + :on-message on-message + :on-close on-close + :on-error on-error + :protocols protocols + :extensions (mapcar 'car extensions) + :accept-string + (websocket-calculate-accept key)))) + (unless conn (error "Could not establish the websocket connection to %s" url)) + (process-put conn :websocket websocket) + (set-process-filter conn + (lambda (process output) + (let ((websocket (process-get process :websocket))) + (websocket-outer-filter websocket output)))) + (set-process-sentinel + conn + (websocket-sentinel url conn key protocols extensions custom-header-alist nowait)) + (set-process-query-on-exit-flag conn nil) + (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait) + websocket)) + +(defun websocket-sentinel (url conn key protocols extensions custom-header-alist nowait) + #'(lambda (process change) + (let ((websocket (process-get process :websocket))) + (websocket-debug websocket "State change to %s" change) + (let ((status (process-status process))) + (when (and nowait (eq status 'open)) + (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait)) + + (when (and (member status '(closed failed exit signal)) + (not (eq 'closed (websocket-ready-state websocket)))) + (websocket-try-callback 'websocket-on-close 'on-close websocket)))))) + +(defun websocket-ensure-handshake (url conn key protocols extensions custom-header-alist nowait) + (let ((url-struct (url-generic-parse-url url)) + (websocket (process-get conn :websocket))) + (when (and (eq 'connecting (websocket-ready-state websocket)) + (memq (process-status conn) + (list 'run (if nowait 'connect 'open)))) + (process-send-string conn + (format "GET %s HTTP/1.1\r\n" + (let ((path (url-filename url-struct))) + (if (> (length path) 0) path "/")))) + (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s" + key (websocket-accept-string websocket)) + (process-send-string conn + (websocket-create-headers + url key protocols extensions custom-header-alist))))) + +(defun websocket-process-headers (url headers) + "On opening URL, process the HEADERS sent from the server." + (when (string-match "Set-Cookie: \(.*\)\r\n" headers) + ;; The url-current-object is assumed to be set by + ;; url-cookie-handle-set-cookie. + (let ((url-current-object (url-generic-parse-url url))) + (url-cookie-handle-set-cookie (match-string 1 headers))))) + +(defun websocket-outer-filter (websocket output) + "Filter the WEBSOCKET server's OUTPUT. +This will parse headers and process frames repeatedly until there +is no more output or the connection closes. If the websocket +connection is invalid, the connection will be closed." + (websocket-debug websocket "Received: %s" output) + (let ((start-point) + (text (concat (websocket-inflight-input websocket) output)) + (header-end-pos)) + (setf (websocket-inflight-input websocket) nil) + ;; If we've received the complete header, check to see if we've + ;; received the desired handshake. + (when (and (eq 'connecting (websocket-ready-state websocket))) + (if (and (setq header-end-pos (string-match "\r\n\r\n" text)) + (setq start-point (+ 4 header-end-pos))) + (progn + (condition-case err + (progn + (websocket-verify-response-code text) + (websocket-verify-headers websocket text) + (websocket-process-headers (websocket-url websocket) text)) + (error + (websocket-close websocket) + (funcall (websocket-on-error websocket) + websocket 'on-open err))) + (setf (websocket-ready-state websocket) 'open) + (websocket-try-callback 'websocket-on-open 'on-open websocket)) + (setf (websocket-inflight-input websocket) text))) + (when (eq 'open (websocket-ready-state websocket)) + (websocket-process-input-on-open-ws + websocket (substring text (or start-point 0)))))) + +(defun websocket-verify-headers (websocket output) + "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid. +The output is assumed to have complete headers. This function +will either return t or call `error'. This has the side-effect +of populating the list of server extensions to WEBSOCKET." + (let ((accept-regexp + (concat "Sec-Web[Ss]ocket-Accept: " (regexp-quote (websocket-accept-string websocket))))) + (websocket-debug websocket "Checking for accept header regexp: %s" accept-regexp) + (unless (string-match accept-regexp output) + (signal 'websocket-invalid-header + (list "Incorrect handshake from websocket: is this really a websocket connection?")))) + (let ((case-fold-search t)) + (websocket-debug websocket "Checking for upgrade header") + (unless (string-match "\r\nUpgrade: websocket\r\n" output) + (signal 'websocket-invalid-header + (list "No 'Upgrade: websocket' header found"))) + (websocket-debug websocket "Checking for connection header") + (unless (string-match "\r\nConnection: upgrade\r\n" output) + (signal 'websocket-invalid-header + (list "No 'Connection: upgrade' header found"))) + (when (websocket-protocols websocket) + (dolist (protocol (websocket-protocols websocket)) + (websocket-debug websocket "Checking for protocol match: %s" + protocol) + (let ((protocols + (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n" + protocol) + output) + (list protocol) + (signal 'websocket-invalid-header + (list "Incorrect or missing protocol returned by the server."))))) + (setf (websocket-negotiated-protocols websocket) protocols)))) + (let* ((extensions (websocket-parse-repeated-field + output + "Sec-WebSocket-Extensions")) + (extra-extensions)) + (dolist (ext extensions) + (let ((x (cl-first (split-string ext "; ?")))) + (unless (or (member x (websocket-extensions websocket)) + (member x extra-extensions)) + (push x extra-extensions)))) + (when extra-extensions + (signal 'websocket-invalid-header + (list (format "Non-requested extensions returned by server: %S" + extra-extensions)))) + (setf (websocket-negotiated-extensions websocket) extensions))) + t) + +;;;;;;;;;;;;;;;;;;;;;; +;; Websocket server ;; +;;;;;;;;;;;;;;;;;;;;;; + +(defvar websocket-server-websockets nil + "A list of current websockets live on any server.") + +(cl-defun websocket-server (port &rest plist) + "Open a websocket server on PORT. +If the plist contains a `:host' HOST pair, this value will be +used to configure the addresses the socket listens on. The symbol +`local' specifies the local host. If unspecified or nil, the +socket will listen on all addresses. + +This also takes a plist of callbacks: `:on-open', `:on-message', +`:on-close' and `:on-error', which operate exactly as documented +in the websocket client function `websocket-open'. Returns the +connection, which should be kept in order to pass to +`websocket-server-close'." + (let* ((conn (make-network-process + :name (format "websocket server on port %s" port) + :server t + :family 'ipv4 + :noquery t + :filter 'websocket-server-filter + :log 'websocket-server-accept + :filter-multibyte nil + :plist plist + :host (plist-get plist :host) + :service port))) + conn)) + +(defun websocket-server-close (conn) + "Closes the websocket, as well as all open websockets for this server." + (let ((to-delete)) + (dolist (ws websocket-server-websockets) + (when (eq (websocket-server-conn ws) conn) + (if (eq (websocket-ready-state ws) 'closed) + (unless (member ws to-delete) + (push ws to-delete)) + (websocket-close ws)))) + (dolist (ws to-delete) + (setq websocket-server-websockets (remove ws websocket-server-websockets)))) + (delete-process conn)) + +(defun websocket-server-accept (server client _message) + "Accept a new websocket connection from a client." + (let ((ws (websocket-inner-create + :server-conn server + :conn client + :url client + :server-p t + :on-open (or (process-get server :on-open) 'identity) + :on-message (or (process-get server :on-message) (lambda (_ws _frame))) + :on-close (let ((user-method + (or (process-get server :on-close) 'identity))) + (lambda (ws) + (setq websocket-server-websockets + (remove ws websocket-server-websockets)) + (funcall user-method ws))) + :on-error (or (process-get server :on-error) + 'websocket-default-error-handler) + :protocols (process-get server :protocol) + :extensions (mapcar 'car (process-get server :extensions))))) + (unless (member ws websocket-server-websockets) + (push ws websocket-server-websockets)) + (process-put client :websocket ws) + (set-process-coding-system client 'binary 'binary) + (set-process-sentinel client + (lambda (process change) + (let ((websocket (process-get process :websocket))) + (websocket-debug websocket "State change to %s" change) + (when (and + (member (process-status process) '(closed failed exit signal)) + (not (eq 'closed (websocket-ready-state websocket)))) + (websocket-try-callback 'websocket-on-close 'on-close websocket))))))) + +(defun websocket-create-headers (url key protocol extensions custom-headers-alist) + "Create connections headers for the given URL, KEY, PROTOCOL, and EXTENSIONS. +Additionally, the CUSTOM-HEADERS-ALIST is passed from the client. +All these parameters are defined as in `websocket-open'." + (let* ((parsed-url (url-generic-parse-url url)) + (host-port (if (url-port-if-non-default parsed-url) + (format "%s:%s" (url-host parsed-url) (url-port parsed-url)) + (url-host parsed-url))) + (cookie-header (url-cookie-generate-header-lines + host-port (car (url-path-and-query parsed-url)) + (equal (url-type parsed-url) "wss")))) + (format (concat "Host: %s\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: %s\r\n" + "Sec-WebSocket-Version: 13\r\n" + (when protocol + (concat + (mapconcat + (lambda (protocol) + (format "Sec-WebSocket-Protocol: %s" protocol)) + protocol "\r\n") + "\r\n")) + (when extensions + (format "Sec-WebSocket-Extensions: %s\r\n" + (mapconcat + (lambda (ext) + (concat + (car ext) + (when (cdr ext) "; ") + (when (cdr ext) + (mapconcat 'identity (cdr ext) "; ")))) + extensions ", "))) + (when cookie-header cookie-header) + (concat (mapconcat (lambda (cons) (format "%s: %s" (car cons) (cdr cons))) + custom-headers-alist "\r\n") + (when custom-headers-alist "\r\n")) + "\r\n") + host-port + key + protocol))) + +(defun websocket-get-server-response (websocket client-protocols client-extensions) + "Get the websocket response from client WEBSOCKET." + (let ((separator "\r\n")) + (concat "HTTP/1.1 101 Switching Protocols" separator + "Upgrade: websocket" separator + "Connection: Upgrade" separator + "Sec-WebSocket-Accept: " + (websocket-accept-string websocket) separator + (let ((protocols + (websocket-intersect client-protocols + (websocket-protocols websocket)))) + (when protocols + (concat + (mapconcat + (lambda (protocol) (format "Sec-WebSocket-Protocol: %s" + protocol)) protocols separator) + separator))) + (let ((extensions (websocket-intersect + client-extensions + (websocket-extensions websocket)))) + (when extensions + (concat + (mapconcat + (lambda (extension) (format "Sec-Websocket-Extensions: %s" + extension)) extensions separator) + separator))) + separator))) + +(defun websocket-server-filter (process output) + "This acts on all OUTPUT from websocket clients PROCESS." + (let* ((ws (process-get process :websocket)) + (text (concat (websocket-inflight-input ws) output))) + (setf (websocket-inflight-input ws) nil) + (cond ((eq (websocket-ready-state ws) 'connecting) + ;; check for connection string + (let ((end-of-header-pos + (let ((pos (string-match "\r\n\r\n" text))) + (when pos (+ 4 pos))))) + (if end-of-header-pos + (progn + (let ((header-info (websocket-verify-client-headers text))) + (if header-info + (progn (setf (websocket-accept-string ws) + (websocket-calculate-accept + (plist-get header-info :key))) + (process-send-string + process + (websocket-get-server-response + ws (plist-get header-info :protocols) + (plist-get header-info :extensions))) + (setf (websocket-ready-state ws) 'open) + (websocket-try-callback 'websocket-on-open + 'on-open ws)) + (message "Invalid client headers found in: %s" output) + (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n") + (websocket-close ws))) + (when (> (length text) (+ 1 end-of-header-pos)) + (websocket-server-filter process (substring + text + end-of-header-pos)))) + (setf (websocket-inflight-input ws) text)))) + ((eq (websocket-ready-state ws) 'open) + (websocket-process-input-on-open-ws ws text)) + ((eq (websocket-ready-state ws) 'closed) + (message "WARNING: Should not have received further input on closed websocket"))))) + +(defun websocket-verify-client-headers (output) + "Verify the headers from the WEBSOCKET client connection in OUTPUT. +Unlike `websocket-verify-headers', this is a quieter routine. We +don't want to error due to a bad client, so we just print out +messages and a plist containing `:key', the websocket key, +`:protocols' and `:extensions'." + (cl-block nil + (let ((case-fold-search t) + (plist)) + (unless (string-match "HTTP/1.1" output) + (message "Websocket client connection: HTTP/1.1 not found") + (cl-return nil)) + (unless (string-match "^Host: " output) + (message "Websocket client connection: Host header not found") + (cl-return nil)) + (unless (string-match "^Upgrade: websocket\r\n" output) + (message "Websocket client connection: Upgrade: websocket not found") + (cl-return nil)) + (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output) + (setq plist (plist-put plist :key (match-string 1 output))) + (message "Websocket client connect: No key sent") + (cl-return nil)) + (unless (string-match "^Sec-WebSocket-Version: 13" output) + (message "Websocket client connect: Websocket version 13 not found") + (cl-return nil)) + (when (string-match "^Sec-WebSocket-Protocol:" output) + (setq plist (plist-put plist :protocols (websocket-parse-repeated-field + output + "Sec-Websocket-Protocol")))) + (when (string-match "^Sec-WebSocket-Extensions:" output) + (setq plist (plist-put plist :extensions (websocket-parse-repeated-field + output + "Sec-Websocket-Extensions")))) + plist))) + +(provide 'websocket) + +;;; websocket.el ends here diff --git a/elpa/websocket-20200321.102/websocket.elc b/elpa/websocket-20200321.102/websocket.elc new file mode 100644 index 00000000..9e53e65f Binary files /dev/null and b/elpa/websocket-20200321.102/websocket.elc differ