commit fa8c0263cde4bf1ccfbbf2ad30a473e2031c6417 Author: Lassi Kortela Date: Mon Apr 26 14:53:20 2021 +0300 Initial import from MIT Scheme commit 41967043bf1019564f0dbcfa61a92773d1e37037 subdirectory src/edwin some packaging scripts omitted diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..e7f049c --- /dev/null +++ b/AUTHORS @@ -0,0 +1,7 @@ +To find out what should go in this file, see "Information For +Maintainers of GNU Software" (maintain.texi), the section called +"Recording Changes". + +Matt Birkholz The conversion to a plugin, the monitor- + world command. +The MIT/GNU Scheme Team The original EDWIN option. diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..bf50f20 --- /dev/null +++ b/COPYING @@ -0,0 +1,482 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, 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 +this service 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 make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library 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 Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the + Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307 USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..75658c2 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,7 @@ +-*-Text-*- + +Please see the git commit log: + +$ git clone git://git.savannah.gnu.org/mit-scheme.git whatever +$ cd whatever/ +$ git log origin/master -- src/edwin/ | more diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..94005ac --- /dev/null +++ b/NEWS @@ -0,0 +1,28 @@ +mit-scheme-edwin NEWS -- history of user-visible changes. + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +02110-1301, USA. + +mit-scheme-edwin 3.117 - Matt Birkholz, 2018-10-09 +================================================== + +Initial plugin-ification. diff --git a/README b/README new file mode 100644 index 0000000..7e40449 --- /dev/null +++ b/README @@ -0,0 +1,47 @@ +The EDWIN option. + +This option extends Scheme with a source code (text) editor. It is +built in the GNU standard way: + + ./configure ... + make all + make check + make install + +The last command will attempt to create a subdirectory in the first +directory on Scheme's library path. If that directory is not writable +by you, super-user privileges may be required. + +You can put a writable directory at the front of your Scheme's library +path by setting the MITSCHEME_LIBRARY_PATH environment variable and +creating a short optiondb file. + + mkdir ~/.mit-scheme-x86-64 + echo "(further-load-options #t)" > ~/.mit-scheme-x86-64/optiondb.scm + export MITSCHEME_LIBRARY_PATH=\ + ~/.mit-scheme-x86-64:/usr/local/lib/mit-scheme-x86-64 + make install + +To use: call the global `edit' procedure, or specify --edit on the +Scheme command line. For more information see the MIT/GNU Scheme +User's Manual. + +Notes on the Edwin sources: + +If you want to add a new file to the source tree, you need to +modify the following three files: + + decls.scm + ed-ffi.scm + edwin.pkg + +If the file should be loaded into the default edwin band, you must also +edit the file: + + edwin.ldr + +If the file is to be autoloaded, you must edit the file: + + loadef.scm + +So, in either case, you have to change four files. diff --git a/TUTORIAL b/TUTORIAL new file mode 100644 index 0000000..86989cf --- /dev/null +++ b/TUTORIAL @@ -0,0 +1,786 @@ +Copyright (c) 1985 Free Software Foundation, Inc; See end for conditions. + +You are looking at the Emacs tutorial. It has been enhanced to +include features important to Edwin. + +Emacs commands generally involve the CONTROL key (sometimes labelled +CTRL or CTL) or the META key (sometimes labelled EDIT). Rather than +write out META or CONTROL each time we want you to prefix a character, +we'll use the following abbreviations: + + C- means hold the CONTROL key while typing the character + Thus, C-f would be: hold the CONTROL key and type f. + M- means hold the META or EDIT key down while typing . + If there is no META or EDIT key, type , release it, + then type the character . "" stands for the + key labelled "ALT" or "ESC". + +Important note: to end the Emacs session, type C-x C-c. (Two characters.) +The characters ">>" at the left margin indicate directions for you to +try using a command. For instance: +<> +>> Now type C-v (View next screen) to move to the next screen. + (go ahead, do it by depressing the control key and v together). + From now on, you'll be expected to do this whenever you finish + reading the screen. + +Note that there is an overlap when going from screen to screen; this +provides some continuity when moving through the file. + +The first thing that you need to know is how to move around from +place to place in the file. You already know how to move forward a +screen, with C-v. To move backwards a screen, type M-v (depress the +META key and type v, or type v if you don't have a META or EDIT +key). + +>> Try typing M-v and then C-v to move back and forth a few times. + + +SUMMARY +------- + +The following commands are useful for viewing screenfuls: + + C-v Move forward one screenful + M-v Move backward one screenful + C-l Clear screen and redisplay everything + putting the text near the cursor at the center. + (That's control-L, not control-1. + There is no such character as control-1.) + +>> Find the cursor and remember what text is near it. + Then type a C-l. + Find the cursor again and see what text is near it now. + + +BASIC CURSOR CONTROL +-------------------- + +Getting from screenful to screenful is useful, but how do you +reposition yourself within a given screen to a specific place? +There are several ways you can do this. One way (not the best, but +the most basic) is to use the commands Previous, Backward, Forward +and Next. As you can imagine these commands (which are given to +Emacs as C-p, C-b, C-f, and C-n respectively) move the cursor from +where it currently is to a new place in the given direction. Here, +in a more graphical form are the commands: + + (P)REVIOUS line, C-p + : + : + (B)ACKWARD, C-b .... Current cursor position .... (F)ORWARD, C-f + : + : + (N)EXT line, C-n + +>> Move the cursor to the line in the middle of that diagram + and type C-l to see the whole diagram centered in the screen. + +Rather than using these keys, you may find it easier at first to use +the cursor motion keys with the triangles on them (on the bottom right +of the keyboard). + +>> Move the cursor around using the cursor motion keys. + +>> Move into the line with C-f's and then up with C-p's. + See what C-p does when the cursor is in the middle of the line. + +Lines are separated by Newline characters. For most applications +there should normally be a Newline character at the end of the text, +as well, but it is up to you to make sure of this. A file can +validly exist without a Newline at the end. + +>> Try to C-b at the beginning of a line. Do a few more C-b's. + Then do C-f's back to the end of the line and beyond. + +When you go off the top or bottom of the screen, the text beyond +the edge is shifted onto the screen so that your instructions can +be carried out while keeping the cursor on the screen. + +>> Try to move the cursor off the bottom of the screen with C-n and + see what happens. + +If moving by characters is too slow, you can move by words. M-f +(Meta-f) moves forward a word and M-b moves back a word. + +>> Type a few M-f's and M-b's. Intersperse them with C-f's and C-b's. + +Notice the parallel between C-f and C-b on the one hand, and M-f and +M-b on the other hand. Very often Meta characters are used for +operations related to English text whereas Control characters operate +on the basic textual units that are independent of what you are +editing (characters, lines, etc). There is a similar parallel between +lines and sentences: C-a and C-e move to the beginning or end of a +line, and M-a and M-e move to the beginning or end of a sentence. + +>> Try a couple of C-a's, and then a couple of C-e's. + Try a couple of M-a's, and then a couple of M-e's. + +See how repeated C-a's do nothing, but repeated M-a's keep moving +farther. Do you think that this is right? + +Two other simple cursor motion commands are M-< (Meta Less-than), +which moves to the beginning of the file, and M-> (Meta Greater-than), +which moves to the end of the file. You probably don't need to try +them, since finding this spot again will be boring. On most terminals +the "<" is above the comma and you must use the shift key to type it. +On these terminals you must use the shift key to type M-< also; +without the shift key, you would be typing M-comma. + +The location of the cursor in the text is also called "point". To +paraphrase, the cursor shows on the screen where point is located in +the text. + +Here is a summary of simple moving operations including the word and +sentence moving commands: + + C-f Move forward a character + C-b Move backward a character + + M-f Move forward a word + M-b Move backward a word + + C-n Move to next line + C-p Move to previous line + + C-a Move to beginning of line + C-e Move to end of line + + M-a Move back to beginning of sentence + M-e Move forward to end of sentence + + M-< Go to beginning of file + M-> Go to end of file + +>> Try all of these commands now a few times for practice. + Since the last two will take you away from this screen, + you can come back here with M-v's and C-v's. These are + the most often used commands. + +Like all other commands in Emacs, these commands can be given +arguments which cause them to be executed repeatedly. The way you +give a command a repeat count is by typing C-u and then the digits +before you type the command. If you have a META or EDIT key, you can +omit the C-u if you hold down the META or EDIT key while you type the +digits. This is easier, but we recommend the C-u method because it +works on any terminal. + +For instance, C-u 8 C-f moves forward eight characters. + +>> Try giving a suitable argument to C-n or C-p to come as close + as you can to this line in one jump. + +The only apparent exception to this is the screen moving commands, +C-v and M-v. When given an argument, they scroll the screen up or +down by that many lines, rather than screenfuls. This proves to be +much more useful. + +>> Try typing C-u 8 C-v now. + +Did it scroll the screen up by 8 lines? If you would like to +scroll it down you can give an argument to M-v. + + +STOPPING EDWIN +-------------- + +If you incorrectly type a command, C-g will quit what it was doing +and allow you to enter it in again from scratch. Use C-g to discard +a numeric argument or the beginning of a command that you don't want +to finish. In Scheme or REPL mode, you can cancel a Scheme +evaluation by typing C-c C-c. You can tell if Scheme is evaluating +something by looking at the run-light for the word Eval instead of +Listen. + +>> Type C-u 100 to make a numeric arg of 100, then type C-g. + Now type C-f. How many characters does it move? + If you have typed an by mistake, you can get rid of it + with a C-g. + + +INSERTING AND DELETING +---------------------- + +If you want to insert text, just type it. Characters which you can +see, such as A, 7, *, etc. are taken by Emacs as text and inserted +immediately. Type (the carriage-return key) to insert a +Newline character. + +You can delete the last character you typed by typing . +More generally, deletes the character immediately before the +current cursor position. + +>> Do this now, type a few characters and then delete them + by typing a few times. Don't worry about this file + being changed; you won't affect the master tutorial. This is just + a copy of it. + +>> Now start typing text until you reach the right margin, and keep + typing. When a line of text gets too big for one line on the + screen, the line of text is "continued" onto a second screen line. + The backslash at the right margin indicates a line which has + been continued. +>> Use to delete the text until the line fits on one screen + line again. The continuation line goes away. + +>> Move the cursor to the beginning of a line and type . + This deletes the newline before the line and merges the line onto the + previous line. The resulting line may be too long to fit, in which + case it has a continuation line. + +>> Type to reinsert the Newline you deleted. + +Remember that most Emacs commands can be given a repeat count; +this includes characters which insert themselves. + +>> Try that now -- type C-u 8 * and see what happens. + +You've now learned the most basic way of typing something in +Emacs and correcting errors. You can delete by words or lines +as well. Here is a summary of the delete operations: + + delete the character just before the cursor + C-d delete the next character after the cursor + + M- kill the word immediately before the cursor + M-d kill the next word after the cursor + + C-k kill from the cursor position to end of line + M-k kill to the end of the current sentence + +Notice that and C-d vs M- and M-d extend the parallel +started by C-f and M-f (well, isn't really a control +character, but let's not worry about that). C-k and M-k are like C-e +and M-e, sort of, in that lines are opposite sentences. + +Now suppose you kill something, and then you decide that you want to +get it back? Well, whenever you kill something bigger than a +character, Emacs saves it for you. To yank it back, use C-y. You +can kill text in one place, move elsewhere, and then do C-y; this is +a good way to move text around. Note that the difference +between "Killing" and "Deleting" something is that "Killed" things +can be yanked back, and "Deleted" things cannot. Generally, the +commands that can destroy a lot of text save it, while the ones that +attack only one character, or nothing but blank lines and spaces, do +not save. + +For instance, type C-n a couple times to postion the cursor +at some line on this screen. + +>> Do this now, move the cursor and kill that line with C-k. + +Note that a single C-k kills the contents of the line, and a second +C-k kills the line itself, and make all the other lines move up. If +you give C-k a repeat count, it kills that many lines AND their +contents. + +The text that has just disappeared is saved so that you can +retrieve it. To retrieve the last killed text and put it where +the cursor currently is, type C-y. + +>> Try it; type C-y to yank the text back. + +Think of C-y as if you were yanking something back that someone +took away from you. Notice that if you do several C-k's in a row +the text that is killed is all saved together so that one C-y will +yank all of the lines. + +>> Do this now, type C-k several times. + +Now to retrieve that killed text: + +>> Type C-y. Then move the cursor down a few lines and type C-y + again. You now see how to copy some text. + +What do you do if you have some text you want to yank back, and then +you kill something else? C-y would yank the more recent kill. But +the previous text is not lost. You can get back to it using the M-y +command. After you have done C-y to get the most recent kill, typing +M-Y replaces that yanked text with the previous kill. Typing M-y +again and again brings in earlier and earlier kills. When you +have reached the text you are looking for, you can just go away and +leave it there. If you M-y enough times, you come back to the +starting point (the most recent kill). + +>> Kill a line, move around, kill another line. + Then do C-y to get back the second killed line. + Then do M-y and it will be replaced by the first killed line. + Do more M-y's and see what you get. Keep doing them until + the second kill line comes back, and then a few more. + If you like, you can try giving M-y positive and negative + arguments. + + +Evaluating Scheme Expressions +----------------------------- + +Now that you can insert characters, you can type expressions and have +them evaluated. Read through this sequence of steps and then try +them out. + + 1. Type: C-x b *scheme* to get into an evaluation buffer. + + 2. Type: (+ 1 5) + + 3. Type: C-x C-e to evaluate the expression. Make sure the point +is after the closing paren. + + 4. Notice that the result is always printed into the *scheme* +buffer. + + 5. Type: M-p to access the history. Change a 5 to a 10 and +evaluate the new expression agian. + + 6. Type: C-x b TUTORIAL to get back to this screen. + +>> Now try these steps out. + +UNDO +---- + +Any time you make a change to the text and wish you had not done so, +you can undo the change (return the text to its previous state) +with the undo command, C-x u. Normally, C-x u undoes one command's +worth of changes; if you repeat the C-x u several times in a row, +each time undoes one more command. There are two exceptions: +commands that made no change (just moved the cursor) do not count, +and self-inserting characters are often lumped together in groups +of up to 20. This is to reduce the number of C-x u's you have to type. + +>> Kill this line with C-k, then type C-x u and it should reappear. + +C-_ is another command for undoing; it is just the same as C-x u +but easier to type several times in a row. The problem with C-_ is +that on some keyboards it is not obvious how to type it. That is +why C-x u is provided as well. On some DEC terminals, you can type +C-_ by typing / while holding down CTRL. Illogical, but what can +you expect from DEC? + +Giving a numeric argument to C-_ or C-x u is equivalent to repeating +it as many times as the argument says. + + +FILES +----- + +In order to make the text you edit permanent, you must put it in a +file. Otherwise, it will go away when your invocation of Emacs goes +away. You put your editing in a file by "finding" the file. What +finding means is that you see the contents of the file in your Emacs; +and, loosely speaking, what you are editing is the file itself. +However, the changes still don't become permanent until you "save" the +file. This is so you can have control to avoid leaving a half-changed +file around when you don't want to. Even then, Emacs leaves the +original file under a changed name in case your changes turn out +to be a mistake. + +If you look near the bottom of the screen you will see a line that +begins and ends with dashes, and contains the string "Edwin: TUTORIAL". +Your copy of the Emacs tutorial is called "TUTORIAL". Whatever +file you find, that file's name will appear in that precise +spot. + +The commands for finding and saving files are unlike the other +commands you have learned in that they consist of two characters. +They both start with the character Control-x. There is a whole series +of commands that start with Control-x; many of them have to do with +files, buffers, and related things, and all of them consist of +Control-x followed by some other character. + +Another thing about the command for finding a file is that you have +to say what file name you want. We say the command "reads an argument +from the terminal" (in this case, the argument is the name of the +file). After you type the command + + C-x C-f Find a file + +Emacs asks you to type the file name. It echoes on the bottom +line of the screen. You are using the minibuffer now! this is +what the minibuffer is for. When you type to end the +file name, the minibuffer is no longer needed, so it disappears. + +>> Type C-x C-f, then type C-g. This cancels the minibuffer, + and also cancels the C-x C-f command that was using the + minibuffer. So you do not find any file. + +In a little while the file contents appear on the screen. You can +edit the contents. When you wish to make the changes permanent, +issue the command + + C-x C-s Save the file + +The contents of Emacs are written into the file. The first time you +do this, the original file is renamed to a new name so that it +is not lost. The new name is made by appending "~" to the end +of the original file's name. + +When saving is finished, Emacs prints the name of the file written. +You should save fairly often, so that you will not lose very much +work if the system should crash. + +>> Type C-x C-s, saving your copy of the tutorial. + This should print "Wrote .../TUTORIAL" at the bottom of the screen. + On VMS it will print "Wrote ...[...]TUTORIAL." + +To make a new file, just find it "as if" it already existed. Then +start typing in the text. When you ask to "save" the file, Emacs +will really create the file with the text that you have inserted. +From then on, you can consider yourself to be editing an already +existing file. + + +BUFFERS +------- + +If you find a second file with C-x C-f, the first file remains +inside Emacs. You can switch back to it by finding it again with +C-x C-f. This way you can get quite a number of files inside Emacs. + +The object inside Emacs which holds the text read from one file +is called a "buffer." Finding a file makes a new buffer inside Emacs. +To see a list of the buffers that exist in Emacs, type + + C-x C-b List buffers + +>> Try C-x C-b now. + +See how each buffer has a name, and it may also have a file name +for the file whose contents it holds. Some buffers do not correspond +to files. For example, the buffer named "*Buffer List*" does +not have any file. It is the buffer which contains the buffer +list that was made by C-x C-b. ANY text you see in an Emacs window +has to be in some buffer. + +>> Type C-x 1 to get rid of the buffer list. + +If you make changes to the text of one file, then find another file, +this does not save the first file. Its changes remain inside Emacs, +in that file's buffer. The creation or editing of the second file's +buffer has no effect on the first file's buffer. This is very useful, +but it also means that you need a convenient way to save the first +file's buffer. It would be a nuisance to have to switch back to +it with C-x C-f in order to save it with C-x C-s. So we have + + C-x s Save some buffers + +C-x s goes through the list of all the buffers you have +and finds the ones that contain files you have changed. +For each such buffer, C-x s asks you whether to save it. + + +EXTENDING THE COMMAND SET +------------------------- + +There are many, many more Emacs commands than could possibly be put +on all the control and meta characters. Emacs gets around this with +the X (eXtend) command. This comes in two flavors: + + C-x Character eXtend. Followed by one character. + M-x Named command eXtend. Followed by a long name. + +These are commands that are generally useful but used less than the +commands you have already learned about. You have already seen two +of them: the file commands C-x C-f to Find and C-x C-s to Save. +Another example is the command to tell Emacs that you'd like to stop +editing and get rid of Emacs. The command to do this is C-x C-c. +(Don't worry; it offers to save each changed file before it kills the +Emacs.) + +C-z is the usual way to exit Emacs, because it is always better not to +kill the Emacs if you are going to do any more editing. On systems +which allow it, C-z exits from Emacs to the shell but does not destroy +the Emacs; if you use the C shell, you can resume Emacs with the `fg' +command (or, more generally, with `%emacs', which works even if your +most recent job was some other). On systems where suspending is not +possible, C-z creates a subshell running under Emacs to give you the +chance to run other programs and return to Emacs afterward, but it +does not truly "exit" from Emacs. In this case, the shell command +`exit' is the usual way to get back to Emacs from the subshell. + +You would use C-x C-c if you were about to log out. You would +also use it to exit an Emacs invoked under mail handling programs +and other random utilities, since they may not believe you have +really finished using the Emacs if it continues to exist. + +There are many C-x commands. The ones you know are: + + C-x C-f Find file. + C-x C-s Save file. + C-x C-b List buffers. + C-x C-c Quit Emacs. + C-x u Undo. + +Named eXtended commands are commands which are used even less +frequently, or commands which are used only in certain modes. These +commands are usually called "functions". An example is the function +replace-string, which globally replaces one string with another. When +you type M-x, Emacs prompts you at the bottom of the screen with +M-x and you should type the name of the function you wish to call; in +this case, "replace-string". Just type "repl s" and Emacs will +complete the name. End the command name with . +Then type the two "arguments"--the string to be replaced, and the string +to replace it with--each one ended with a Return. + +>> Move the cursor to the blank line two lines below this one. + Then type M-x repla schangedaltered. + + Notice how this line has changed: you've replaced + the word c-h-a-n-g-e-d with "altered" wherever it occured + after the cursor. + + +MODE LINE +--------- + +If Emacs sees that you are typing commands slowly it shows them to you +at the bottom of the screen in an area called the "echo area." The echo +area contains the bottom line of the screen. The line immediately above +it is called the MODE LINE. The mode line says something like + +--**--Emacs: TUTORIAL (Fundamental)----58%------------- + +This is a very useful "information" line. + +You already know what the filename means--it is the file you have +found. What the --NN%-- means is that NN percent of the file is +above the top of the screen. If the top of the file is on the screen, +it will say --TOP-- instead of --00%--. If the bottom of the file is +on the screen, it will say --BOT--. If you are looking at a file so +small it all fits on the screen, it says --ALL--. + +The stars near the front mean that you have made changes to the text. +Right after you visit or save a file, there are no stars, just dashes. + +The part of the mode line inside the parentheses is to tell you what +modes you are in. The default mode is Fundamental which is what you +are in now. It is an example of a "major mode". There are several +major modes in Emacs for editing different languages and text, such +as Scheme mode, Text mode, etc. At any time one and only one major +mode is active, and its name can always be found in the mode line +just where "Fundamental" is now. Each major mode makes a few +commands behave differently. For example, there are commands for +creating comments in a program, and since each programming language +has a different idea of what a comment should look like, each major +mode has to insert comments differently. Each major mode is the name +of an extended command, which is how you get into the mode. For +example, M-X fundamental-mode is how to get into Fundamental mode. + +If you are going to be editing Scheme code, you should probably use +Text Mode. + +>> Type M-x scheme-mode. + +To get documentation on your current major mode, type C-h m. + +>> Use C-u C-v once or more to bring this line near the top of screen. +>> Type C-h m, to see how Scheme mode differs from Fundamental mode. +>> Type C-x 1 to remove the documentation from the screen. + +Major modes are called major because there are also minor modes. +They are called minor because they aren't alternatives to the major +modes, just minor modifications of them. Each minor mode can be +turned on or off by itself, regardless of what major mode you are in, +and regardless of the other minor modes. So you can use no minor +modes, or one minor mode, or any combination of several minor modes. + +SEARCHING +--------- + +Emacs can do searches for strings (these are groups of contiguous +characters or words) either forward through the file or backward +through it. To search for the string means that you are trying to +locate it somewhere in the file and have Emacs show you where the +occurrences of the string exist. This type of search is somewhat +different from what you may be familiar with. It is a search that is +performed as you type in the thing to search for. The command to +initiate a search is C-s for forward search, and C-r for reverse +search. BUT WAIT! Don't do them now. When you type C-s you'll +notice that the string "I-search" appears as a prompt in the echo +area. This tells you that Emacs is in what is called an incremental +search waiting for you to type the thing that you want to search for. + terminates a search. + +>> Now type C-s to start a search. SLOWLY, one letter at a time, + type the word 'cursor', pausing after you type each + character to notice what happens to the cursor. +>> Type C-s to find the next occurrence of "cursor". +>> Now type four times and see how the cursor moves. +>> Type to terminate the search. + +Did you see what happened? Emacs, in an incremental search, tries to +go to the occurrence of the string that you've typed out so far. To go +to the next occurrence of 'cursor' just type C-s again. If no such +occurrence exists Emacs beeps and tells you that it is a failing +search. C-g would also terminate the search. + +If you are in the middle of an incremental search and type , +you'll notice that the last character in the search string is erased +and the search backs up to the last place of the search. For +instance, suppose you currently have typed 'cu' and you see that your +cursor is at the first occurrence of 'cu'. If you now type , +the 'u' on the search line is erased and you'll be repositioned in the +text to the occurrence of 'c' where the search took you before you +typed the 'u'. This provides a useful means for backing up while you +are searching. + +If you are in the middle of a search and happen to type a control +character (other than a C-s or C-r, which tell Emacs to search for the +next occurrence of the string), the search is terminated. + +The C-s starts a search that looks for any occurrence of the search +string AFTER the current cursor position. But what if you want to +search for something earlier in the text? To do this, type C-r for +Reverse search. Everything that applies to C-s applies to C-r except +that the direction of the search is reversed. + + +RECURSIVE EDITING LEVELS +------------------------ + +Sometimes you will get into what is called a "recursive editing +level". This is indicated by square brackets in the mode line, +surrounding the parentheses around the major mode name. For +example, you might see [(Fundamental)] instead of (Fundamental). + +To get out of the recursive editing level, type + M-x top-level. + +>> Try that now; it should display "Back to top level" + at the bottom of the screen. + +In fact, you were ALREADY at top level (not inside a recursive editing +level) if you have obeyed instructions. M-x top-level does not care; +it gets out of any number of recursive editing levels, perhaps zero, +to get back to top level. + +You can't use C-g to get out of a recursive editing level because C-g +is used for discarding numeric arguments and partially typed commands +WITHIN the recursive editing level. + + +WINDOWS +------- + +Emacs can have several windows, each displaying its own text. +At this stage it is better not to go into the techniques of +using multiple windows. But you do need to know how to get +rid of extra windows that may appear to display help or +output from certain commands. It is simple: + + C-x 1 One window (i.e., kill all other windows). + +That is Control-x followed by the digit 1. +C-x 1 makes the window which the cursor is in become +the full screen, by getting rid of any other windows. + +>> Move the cursor to this line and type C-u 0 C-l. +>> Type Control-h k Control-f. + See how this window shrinks, while a new one appears + to display documentation on the Control-f command. + +>> Type C-x 1 and see the documentation listing window disappear. + + +GETTING MORE HELP +----------------- + +In this tutorial we have tried to supply just enough information to +get you started using Emacs. There is so much available in Emacs that +it would be impossible to explain it all here. However, you may want +to learn more about Emacs since it has numerous desirable features +that you don't know about yet. Emacs has a great deal of internal +documentation. All of these commands can be accessed through +the character Control-h, which we call "the Help character" +because of the function it serves. + +To use the HELP features, type the C-h character, and then a +character saying what kind of help you want. If you are REALLY lost, +type C-h ? and Emacs will tell you what kinds of help it can give. +If you have typed C-h and decide you don't want any help, just +type C-G to cancel it. + +The most basic HELP feature is C-h c. Type C-h, a c, and a +command character or sequence, and Emacs displays a very brief +description of the command. + +>> Type C-h c Control-p. + The message should be something like + + C-p runs the command previous-line + +This tells you the "name of the function". That is important in +writing Lisp code to extend Emacs; it also is enough to remind +you of what the command does if you have seen it before but did +not remember. + +Multi-character commands such as C-x C-s and (if you have no META or +EDIT key) v are also allowed after C-h c. + +To get more information on the command, use C-h k instead of C-h c. + +>> Type C-h k Control-p. + +This displays the documentation of the function, as well as its name, +in an Emacs window. When you are finished reading the output, type +C-x 1 to get rid of the help text. You do not have to do this right +away. You can do some editing based on the help text before you type +C-x 1. + +Here are some other useful C-h options: + + C-h f Describe a function. You type in the name of the + function. + +>> Try typing C-h f previous-line. + This prints all the information Emacs has about the + function which implements the C-P command. + + C-h a Command Apropos. Type in a keyword and Emacs will list + all the commands whose names contain that keyword. + These commands can all be invoked with Meta-x. + For some commands, Command Apropos will also list a one + or two character sequence which has the same effect. + +>> Type C-h a file. You will see a list of all M-x commands +with "file" in their names. You will also see commands +like C-x C-f and C-x C-w, listed beside the command names +find-file and write-file. + + +CONCLUSION +---------- + +Remember, to exit Emacs permanently use C-x C-c. To exit to a shell +temporarily, so that you can come back in, use C-z. + +This tutorial is meant to be understandable to all new users, so if +you found something unclear, don't sit and blame yourself - complain! + + +COPYING +------- + +This tutorial descends from a long line of Emacs tutorials +starting with the one written by Stuart Cracraft for the original Emacs. + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1985 Free Software Foundation + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are slightly different +but in the same spirit. Please read the file COPYING and then +do give copies of GNU Emacs to your friends. +Help stamp out software obstructionism ("ownership") by using, +writing, and sharing free software! diff --git a/edwin.cbf b/edwin.cbf new file mode 100644 index 0000000..ec6bc9e --- /dev/null +++ b/edwin.cbf @@ -0,0 +1,30 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Script to incrementally compile the editor (from .bins) + +(fluid-let ((compiler:coalescing-constant-warnings? #f)) + (compile-directory ".")) \ No newline at end of file diff --git a/edwin.ldr b/edwin.ldr new file mode 100644 index 0000000..525465e --- /dev/null +++ b/edwin.ldr @@ -0,0 +1,261 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;; program to load package contents +;;; **** This program (unlike most .ldr files) is not generated by a program. + +(declare (usual-integrations)) + +(lambda (package/loader key-alist) + (let ((to-avoid-list (if (file-exists? "edwin.bad") + (fasload "edwin.bad") + '())) + (bad-environment-tag '*bad-environment*)) + (let ((->environment + (lambda (spec) + (if (name->package spec) + (->environment spec) + (cons bad-environment-tag spec))))) + (define (load file env) + (cond ((string-member? file to-avoid-list) + (newline) + (write-string "* skipping ") + (write-string file) + false) + ((and (pair? env) + (eq? (car env) bad-environment-tag)) + (error "Attempting to load into non-existent package" + file (cdr env))) + (else (package/loader file env) + true))) + (define (load-set files env) + (if (null? files) + true + (let ((val (load (car files) env))) + (boolean-and val (load-set (cdr files) env))))) + (define (load-set-and-initialize! files env) + (and (load-set files env) + ((access initialize-package! env)))) + (define (lookup var) + (cond ((assq var key-alist) => cdr) + (else false))) + (define (load-case var alist env) + (for-each (lambda (key/file) + (and (eq? (lookup var) (car key/file)) + (load (cdr key/file) env))) + alist)) + (define string-member? (member-procedure string=?)) + (define (boolean-and a b) (and a b)) + + (if (memq (lookup 'os-type) '(unix nt)) + (begin + (load-option 'subprocess) + (load-option 'synchronous-subprocess))) + (load-option 'rb-tree) + (load-option 'hash-table) + (load-option 'regular-expression) + (load-option 'mime-codec) + + (let ((environment (->environment '(edwin)))) + (load "utils" environment) + (load "adapters" (->environment '(edwin adapters))) + (load "string" (->environment '(edwin string))) + (load "nvector" environment) + (load "ring" environment) + (load "strtab" environment) + (load "strpad" environment) + (load "macros" (->environment '(edwin macros))) + (load "class" environment) + (load "clscon" (->environment '(edwin class-constructor))) + (load "clsmac" (->environment '(edwin class-macros))) + (load "xform" + (->environment + '(edwin class-macros transform-instance-variables))) + (load "paths" environment) + (load "struct" environment) + (load "grpops" (->environment '(edwin group-operations))) + (load "txtprp" (->environment '(edwin text-properties))) + (load "regops" environment) + (load "motion" environment) + (load "search" environment) + (load "image" environment) + (load "comman" environment) + (load "docstr" environment) + (if (not (memq (lookup 'os-type) '(dos nt))) + (set! (access *external-doc-strings?* environment) #f)) + (load "comtab" (->environment '(edwin comtab))) + (load "modes" environment) + (load "buffer" environment) + (load "bufset" environment) + (load "display" (->environment '(edwin display-type))) + (load "screen" (->environment '(edwin screen))) + + (let ((environment (->environment '(edwin window)))) + (load "window" environment) + (load "utlwin" environment) + (load "bufwin" environment) + (load "bufwfs" environment) + (load "bufwiu" environment) + (load "bufwmc" environment) + (load "comwin" (->environment '(edwin window combination))) + (load "modwin" environment) + (load "buffrm" environment) + (load "edtfrm" environment)) + + (load "calias" environment) + (load "edtstr" environment) + (load "editor" environment) + (load "curren" environment) + ;; "undo" must be loaded after "editor": + (load "undo" (->environment '(edwin undo))) + (load "simple" environment) + (load "debuge" environment) + (load "modlin" (->environment '(edwin modeline-string))) + (load "input" (->environment '(edwin keyboard))) + (load "prompt" (->environment '(edwin prompt))) + (load "comred" (->environment '(edwin command-reader))) + (load "bufinp" (->environment '(edwin buffer-input-port))) + (load "bufout" (->environment '(edwin buffer-output-port))) + (load "winout" (->environment '(edwin window-output-port))) + (load "things" environment) + (load "tparse" environment) + (load "syntax" environment) + (load "regexp" (->environment '(edwin regular-expression))) + (load "comatch" environment) + (load "keyparse" (->environment '(edwin keyparser))) + (load "linden" (->environment '(edwin lisp-indentation))) + + (case (lookup 'os-type) + ((unix) + (load "unix" environment)) + ((dos nt) + (load "dos" environment) + (load "dosfile" environment))) + + (load "fileio" environment) + + (let ((env (->environment '(edwin screen console-screen)))) + (load-set-and-initialize! '("termcap" "tterm") env) + (if (memq (lookup 'os-type) '(dos nt)) + (begin + (load "ansi" env) + (if (load "bios" env) + ((access bios-initialize-package! env)))))) + + (case (lookup 'os-type) + ((nt) + (load-set-and-initialize! '("win32") + (->environment '(edwin screen win32))) + (load-set-and-initialize! '("key-w32") + (->environment '(edwin win32-keys)))) + ((unix) + (load "xterm" (->environment '(edwin screen x-screen))))) + + (load-case 'os-type + '((unix . "process") + (dos . "dosproc") + (nt . "process")) + (->environment '(edwin process))) + + (load "mousecom" environment) + (case (lookup 'os-type) + ((nt) (load "win32com" (->environment '(edwin win-commands))))) + ;; debug depends on button1-down defined in mousecom + (load "debug" (->environment '(edwin debugger))) + + (let ((env (->environment '(edwin dired)))) + (load "dired" env) + (case (lookup 'os-type) + ((unix) (load "dirunx" env)) + ((nt) (load "dirw32" env)))) + + (load "abbrev" environment) + (load "argred" (->environment '(edwin command-argument))) + (load "autold" environment) + (load "autosv" environment) + (load "basic" environment) + (load "bufcom" environment) + (load "bufmnu" (->environment '(edwin buffer-menu))) + (load "c-mode" environment) + (load "javamode" environment) + (load "cinden" (->environment '(edwin c-indentation))) + (load "comhst" environment) + (load "comint" environment) + (load "compile" environment) + (load "dabbrev" environment) + (load "evlcom" environment) + (load "filcom" environment) + (load "fill" environment) + (load "hlpcom" environment) + (load "info" (->environment '(edwin info))) + (load "intmod" (->environment '(edwin inferior-repl))) + (load "keymap" (->environment '(edwin command-summary))) + (load "kilcom" environment) + (load "kmacro" environment) + (load "lincom" environment) + (load "lspcom" environment) + (load "malias" (->environment '(edwin mail-alias))) + (load "motcom" environment) + (load "occur" (->environment '(edwin occurrence))) + (load "outline" environment) + ;;(load "rcs" (->environment '(edwin rcs))) + (load "reccom" (->environment '(edwin rectangle))) + (load "regcom" (->environment '(edwin register-command))) + (load "replaz" environment) + (load "rfc822" (->environment '(edwin rfc822))) + (load "rmail" (->environment '(edwin rmail))) + (load "rmailsum" (->environment '(edwin rmail))) + (load "rmailsrt" (->environment '(edwin rmail))) + (load "schmod" environment) + (load "sendmail" (->environment '(edwin sendmail))) + (load "sercom" environment) + (load "iserch" (->environment '(edwin incremental-search))) + (load "shell" environment) + (load "tagutl" (->environment '(edwin tags))) + (load "texcom" environment) + (load "htmlmode" environment) + (load "diff" (->environment '(edwin diff))) + (load "rcsparse" (->environment '(edwin rcs-parse))) + (load "vc" (->environment '(edwin vc))) + (load "vc-rcs" (->environment '(edwin vc))) + (load "vc-cvs" (->environment '(edwin vc))) + (load "vc-svn" (->environment '(edwin vc))) + (load "vc-bzr" (->environment '(edwin vc))) + (load "vc-git" (->environment '(edwin vc))) + (load "wincom" environment) + (load "scrcom" environment) + (load "modefs" environment) + (load "loadef" environment) + #| + (load-set-and-initialize! '("bochser" "bochsmod") + (->environment '(edwin bochser))) + |# + (load "notify" environment) + (load "world-monitor" environment) + (if (access *external-doc-strings?* environment) + (begin + (set! (access *external-doc-strings?* environment) false) + (warn "Remember to use ``dump-doc-strings''!"))))))) \ No newline at end of file diff --git a/edwin.pkg b/edwin.pkg new file mode 100644 index 0000000..aeebc2b --- /dev/null +++ b/edwin.pkg @@ -0,0 +1,1928 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Edwin Packaging + +(global-definitions "../runtime/") +(global-definitions "../xml/") + +(define-package (edwin) + (files "utils" + "nvector" + "ring" + "strtab" + "strpad" + "class" + + "paths" + "struct" ; low-level data structures + "regops" ; low-level editing operations + "motion" ; low-level mark movement + "search" ; search/match chars and strings + "comatch" ; combinatoric matcher + "image" ; character-display imaging + "comman" ; editor command/variable abstractions + "docstr" ; out-of-core documentation support + "modes" ; editor mode abstraction + "buffer" ; buffer abstraction + "bufset" ; buffer-set abstraction + + "edtstr" ; editor abstraction + "editor" ; editor top level + "curren" ; current state + "simple" ; simple editing operations + "debuge" ; edwin debugging tools + "calias" ; character aliasing + "things" ; generic text objects + "tparse" ; text parsing + "syntax" ; word and list parsing + "fileio" ; file <-> buffer + + "abbrev" ; abbrevs + "autold" ; autoloaded definitions + "autosv" ; auto save + "basic" ; basic commands + "bufcom" ; buffer commands + "comhst" ; command history + "dabbrev" ; M-x dabbrev-expand + "evlcom" ; evaluation commands + "filcom" ; file commands + "fill" ; text-fill commands + "hlpcom" ; help commands + "kilcom" ; kill commands + "kmacro" ; keyboard macros + "lincom" ; line commands + "lspcom" ; lisp commands + "motcom" ; motion commands + "mousecom" ; mouse commands + "replaz" ; replace commands + "schmod" ; scheme mode + "scrcom" ; frame commands + "sercom" ; search commands + "texcom" ; text commands + "wincom" ; window commands + + "modefs" ; fundamental mode + + "loadef" ; auto-load definitions + "c-mode" ; C mode + "javamode" ; Java mode + "htmlmode" ; HTML mode + "midas" ; MIDAS mode + "pasmod" ; Pascal mode + "tximod" ; Texinfo mode + "notify" ; mode-line notifications + "outline" ; outline minor mode + "sort" ; sorting commands + "webster" ; access a Webster server + "world-monitor" + ) + + (parent ()) + (import (runtime) + define-primitives + string-for-primitive + ucode-primitive + ucode-type) + (import (runtime char-syntax) + char-syntax-table/entries) + (import (runtime character) + bucky-bits->prefix) + (import (runtime microcode-tables) + fixed-objects-item + update-fixed-objects-item!) + (import (runtime port) + (make-port make-textual-port) + (make-port-type make-textual-port-type) + (port/input-channel input-port-channel) + (port/output-channel output-port-channel) + (port/state textual-port-state) + generic-port-operation:write-substring) + #| + (import (blowfish) + blowfish-encrypt-port + blowfish-file? + read-blowfish-file-header + write-blowfish-file-header) + (import (gdbm) + gdbm-close + gdbm-delete + gdbm-exists? + gdbm-fetch + gdbm-firstkey + gdbm-nextkey + gdbm-open + gdbm-reorganize + gdbm-store + gdbm_fast + gdbm_replace + gdbm_wrcreat) + |# + (export () + create-editor + create-editor-args + inhibit-editor-init-file? + reset-editor + reset-editor-windows + (save-editor-files debug-save-files)) + (export (edwin class-macros) + class-instance-transforms)) + +(define-package (edwin adapters) + (files "adapters") + (parent ()) + (export (edwin) + (call-with-append-file edwin:call-with-append-file) + (call-with-input-file edwin:call-with-input-file) + (call-with-output-file edwin:call-with-output-file) + char-set:graphic)) + +(define-package (edwin string) + (files "string") + (parent (edwin)) + (import (runtime character-set) + char-set-table) + (export (edwin) + (set-vector-8b-length! set-string-length!) + (vector-8b-length string-length) + (vector-8b-maximum-length string-maximum-length) + (vector-8b? string?) + ascii-string-copy + burst-string + bytevector->string + char->string + decorated-string-append + error:not-string + guarantee-string + guarantee-string-index + guarantee-substring + guarantee-substring-end-index + guarantee-substring-start-index + list->string + make-string + make-vector-8b + random-byte-vector + set-string-length! + string + string->bytevector + string->list + string->vector + string-append + string-capitalize + string-capitalize! + string-capitalized? + string-ci-hash + string-ci<=? + string-ci=? + string-ci>? + string-compare + string-compare-ci + string-copy + string-copy! + string-downcase + string-downcase! + string-fill! + string-find-next-char + string-find-next-char-ci + string-find-next-char-in-set + string-find-previous-char + string-find-previous-char-ci + string-find-previous-char-in-set + string-for-each + string-hash + string-head + string-head! + string-length + string-lower-case? + string-map + string-match-backward + string-match-backward-ci + string-match-forward + string-match-forward-ci + string-maximum-length + string-move! + string-null? + string-pad-left + string-pad-right + string-prefix-ci? + string-prefix? + string-ref + string-replace + string-replace! + string-search-all + string-search-backward + string-search-forward + string-set! + string-suffix-ci? + string-suffix? + string-tail + string-trim + string-trim-left + string-trim-right + string-upcase + string-upcase! + string-upper-case? + string<=? + string=? + string>? + string? + substring + substring->list + substring-capitalize! + substring-capitalized? + substring-ci + define-class + define-method + usual==> + with-instance-variables) + (import (runtime syntax) + classifier->runtime + classify-form + expr-item + hist-car + hist-cddr)) + +(define-package (edwin class-macros transform-instance-variables) + (files "xform") + (parent (edwin class-macros)) + (export (edwin class-macros) + transform-instance-variables)) + +(define-package (edwin class-constructor) + (files "clscon") + (parent (edwin)) + (export (edwin) + class? + make-class + name->class) + (export (edwin class-macros) + make-class + name->class)) + +(define-package (edwin macros) + (files "macros") + (parent (edwin)) + (export (edwin) + command-defined? + command-name->scheme-name + define-command + define-editor-alias + define-major-mode + define-minor-mode + define-variable + define-variable-per-buffer + edwin-syntax-table + local-set-variable! + mode-name->scheme-name + ref-command + ref-command-object + ref-mode-object + ref-variable + ref-variable-object + set-variable! + variable-name->scheme-name)) + +(define-package (edwin group-operations) + (files "grpops") + (parent (edwin)) + (export (edwin) + finish-group-insert! + group-copy-substring! + group-delete! + group-delete-left-char! + group-delete-right-char! + group-extract-and-delete-string! + group-extract-string + group-insert-char! + group-insert-chars! + group-insert-string! + group-insert-substring! + group-left-char + group-replace-char! + group-replace-string! + group-replace-substring! + group-right-char + prepare-gap-for-insert!)) + +(define-package (edwin comtab) + (files "comtab") + (parent (edwin)) + (export (edwin) + comtab->alist + comtab-entry + comtab-key-bindings + comtab-key? + comtab? + define-key + define-prefix-key + local-comtab-entry + make-comtab + prefix-key-list?)) + +(define-package (edwin undo) + (files "undo") + (parent (edwin)) + (export (edwin) + disable-group-undo! + edwin-command$undo + edwin-variable$undo-limit + edwin-variable$undo-strong-limit + enable-group-undo! + undo-boundary! + undo-done! + undo-leave-window! + undo-more + undo-record-deletion! + undo-record-insertion! + undo-record-property-changes! + undo-record-replacement! + undo-start + with-group-undo-disabled)) + +(define-package (edwin display-type) + (files "display") + (parent (edwin)) + (export () + editor-display-types) + (export (edwin) + display-type? + display-type/available? + display-type/get-input-operations + display-type/make-screen + display-type/multiple-screens? + display-type/name + display-type/with-display-grabbed + display-type/with-interrupts-disabled + display-type/with-interrupts-enabled + make-display-type + name->display-type)) + +(define-package (edwin screen) + (files "screen") + (parent (edwin)) + (export (edwin) + default-face + default-face? + guarantee-screen + highlight-face + initialize-screen-root-window! + screen-beep + screen-clear-rectangle + screen-deleted? + screen-direct-output-char + screen-direct-output-move-cursor + screen-direct-output-substring + screen-discard! + screen-enter! + screen-exit! + screen-force-update + screen-get-output-line + screen-in-update? + screen-line-draw-cost + screen-modeline-event! + screen-move-cursor + screen-needs-update? + screen-output-char + screen-output-substring + screen-root-window + screen-scroll-lines-down + screen-scroll-lines-up + screen-select-cursor! + screen-select-window! + screen-selected-window + screen-state + screen-typein-window + screen-visibility + screen-visible? + screen-window-list + screen-window0 + screen-x-size + screen-y-size + screen? + set-screen-debug-trace! + set-screen-root-window! + update-screen! + window-screen + with-screen-in-update)) + +(define-package (edwin window) + (files "window" + "utlwin" + "bufwin" + "bufwfs" + "bufwiu" + "bufwmc" + "modwin" + "buffrm" + "edtfrm") + (parent (edwin)) + (export (edwin) + display-style/discard-screen-contents? + display-style/ignore-input? + display-style/ignore-redisplay-flags? + display-style/no-screen-output? + dont-restore-saved-configuration + edwin-variable$cursor-centering-point + edwin-variable$mode-line-inverse-video + edwin-variable$scroll-step + edwin-variable$char-image-strings + edwin-variable$tab-width + edwin-variable$truncate-lines + edwin-variable$truncate-partial-width-windows + screen-window-configuration + set-screen-window-configuration! + set-window-buffer! + set-window-debug-trace! + set-window-point! + set-window-start-mark! + window-buffer + window-char->image + window-clear-override-message! + window-configuration? + window-coordinates->mark + window-direct-output-backward-char! + window-direct-output-forward-char! + window-direct-output-insert-char! + window-direct-output-insert-newline! + window-direct-output-insert-substring! + window-direct-output-cursor! + window-direct-update! + window-home-cursor! + window-mark->coordinates + window-mark->x + window-mark->y + window-mark-visible? + window-modeline-event! + (window-needs-redisplay? buffer-frame-needs-redisplay?) + window-override-message + window-point + window-point-coordinates + window-point-x + window-point-y + window-root-window + window-redraw! + window-scroll-y-absolute! + window-scroll-y-relative! + window-select-time + window-set-override-message! + window-start-mark + (window-x-size buffer-frame-x-size) + window-y-center + (window-y-size buffer-frame-y-size) + (window? buffer-frame?) + with-saved-configuration) + (export (edwin screen) + editor-frame-screen + editor-frame-select-cursor! + editor-frame-cursor-window + editor-frame-select-window! + editor-frame-selected-window + editor-frame-typein-window + editor-frame-update-display! + editor-frame-window0 + editor-frame-windows + make-editor-frame)) + +(define-package (edwin window combination) + (files "comwin") + (parent (edwin window)) + (export (edwin) + window+ + window- + window-1+ + window-delete! + window-grow-horizontally! + window-grow-vertically! + window-has-down-neighbor? + window-has-horizontal-neighbor? + window-has-left-neighbor? + window-has-no-neighbors? + window-has-right-neighbor? + window-has-up-neighbor? + window-has-vertical-neighbor? + window-split-horizontally! + window-split-vertically! + window1+) + (export (edwin window) + combination-child + combination-leaf-window + combination-vertical? + combination? + window-next + window0)) + +(define-package (edwin modeline-string) + (files "modlin") + (parent (edwin)) + (export (edwin) + add-minor-mode-line-entry! + edwin-variable$global-mode-string + edwin-variable$minor-mode-alist + edwin-variable$mode-line-buffer-identification + edwin-variable$mode-line-format + edwin-variable$mode-line-modified + edwin-variable$mode-line-procedure + edwin-variable$mode-line-process + edwin-variable$mode-name + format-modeline-string + modeline-string! + remove-minor-mode-line-entry!)) + +(define-package (edwin command-reader) + (files "comred") + (parent (edwin)) + (export (edwin) + abort-current-command + add-command-suffix! + auto-argument-mode? + command-argument + command-history-list + command-message-receive + command-reader + current-command + current-command-key + dispatch-on-key + dispatch-on-command + execute-button-command + execute-key + execute-command + execute-command-history-entry + keyboard-keys-read + last-command + last-command-key + maybe-add-command-suffix! + override-next-command! + read-and-dispatch-on-key + return-to-command-loop + set-command-argument! + set-command-message! + set-current-command! + top-level-command-reader)) + +(define-package (edwin keyboard) + (files "input") + (parent (edwin)) + (export (edwin) + append-command-prompt! + append-message + clear-message + command-prompt + keyboard-read + keyboard-peek + keyboard-peek-no-hang + keyboard-read-char + message + message-args->string + message-wrapper + reset-command-prompt! + set-command-prompt! + temporary-message)) + +(define-package (edwin prompt) + (files "prompt") + (parent (edwin)) + (export (edwin) + call-with-confirmed-pass-phrase + call-with-stored-pass-phrase + call-with-pass-phrase + completion-message + delete-stored-pass-phrase + edwin-command$exit-minibuffer + edwin-command$exit-minibuffer-yes-or-no + edwin-command$minibuffer-complete + edwin-command$minibuffer-complete-and-exit + edwin-command$minibuffer-complete-word + edwin-command$minibuffer-completion-help + edwin-command$minibuffer-yank-default + edwin-command$repeat-complex-command + edwin-mode$minibuffer-local + edwin-mode$minibuffer-local-completion + edwin-mode$minibuffer-local-must-match + edwin-mode$minibuffer-local-yes-or-no + edwin-variable$enable-recursive-minibuffers + edwin-variable$completion-auto-help + lookup-prompt-option + pop-up-completions-list + pop-up-generated-completions + prompt-for-alist-value + prompt-for-char + prompt-for-command + prompt-for-completed-string + prompt-for-confirmation? + prompt-for-key + prompt-for-number + prompt-for-string + prompt-for-string-table-name + prompt-for-string-table-value + prompt-for-string/prompt + prompt-for-typein + prompt-for-variable + prompt-for-yes-or-no? + prompt-history-strings + prompt-options-default-string + set-prompt-history-strings! + standard-completion + temporary-typein-message + typein-edit-other-window + within-typein-edit + within-typein-edit? + write-completions-list) + (export (edwin screen) + make-typein-buffer-name)) + +(define-package (edwin buffer-input-port) + (files "bufinp") + (parent (edwin)) + (export (edwin) + call-with-input-mark + call-with-input-region + make-buffer-input-port + with-input-from-mark + with-input-from-region)) + +(define-package (edwin buffer-output-port) + (files "bufout") + (parent (edwin)) + (export (edwin) + call-with-output-mark + mark->output-port + output-port->mark + with-output-to-mark)) + +(define-package (edwin window-output-port) + (files "winout") + (parent (edwin)) + (export (edwin) + window-output-port + with-output-to-current-point + with-output-to-window-point)) + +(define-package (edwin regular-expression) + (files "regexp") + (parent (edwin)) + (export (edwin) + delete-match + preserving-match-data + re-match-buffer-forward + re-match-data + re-match-end + re-match-extract-string + re-match-forward + re-match-start + re-search-backward + re-search-buffer-backward + re-search-buffer-forward + re-search-forward + re-substitute-registers + replace-match + search-backward + search-forward + set-re-match-data!) + (import (runtime regular-expression) + registers)) + +(define-package (edwin lisp-indentation) + (files "linden") + (parent (edwin)) + (export (edwin) + edwin-variable$lisp-body-indent + edwin-variable$lisp-indent-hook + edwin-variable$lisp-indent-methods + edwin-variable$lisp-indent-offset + edwin-variable$lisp-indent-regexps + indent-code-rigidly + lisp-comment-indentation + lisp-comment-locate + lisp-indent-definition + lisp-indent-line + lisp-indent-sexp + lisp-indent-special-form + standard-lisp-indent-hook)) + +(define-package (edwin command-argument) + (files "argred") + (parent (edwin)) + (export (edwin) + command-argument-multiplier-only? + command-argument-negative-only? + command-argument-numeric-value + command-argument-prompt + command-argument-self-insert? + command-argument-value + edwin-command$auto-argument + edwin-command$auto-digit-argument + edwin-command$auto-negative-argument + edwin-command$digit-argument + edwin-command$negative-argument + edwin-command$universal-argument)) + +(define-package (edwin buffer-menu) + (files "bufmnu") + (parent (edwin)) + (export (edwin) + edwin-variable$buffer-menu-kill-on-quit)) + +(define-package (edwin register-command) + (files "regcom") + (parent (edwin))) + +(define-package (edwin c-indentation) + (files "cinden") + (parent (edwin)) + (export (edwin) + c-compute-indentation + c-indent-expression + c-indent-line + edwin-variable$c-argdecl-indent + edwin-variable$c-brace-imaginary-offset + edwin-variable$c-brace-offset + edwin-variable$c-continued-brace-offset + edwin-variable$c-continued-statement-offset + edwin-variable$c-indent-level + edwin-variable$c-label-offset)) + +(define-package (edwin incremental-search) + (files "iserch") + (parent (edwin)) + (export (edwin) + isearch)) + +(define-package (edwin command-summary) + (files "keymap") + (parent (edwin)) + (export (edwin) + describe-bindings + edwin-command$describe-bindings + edwin-command$make-command-summary + make-command-summary)) + +(define-package (edwin inferior-repl) + (files "intmod") + (parent (edwin)) + (export (edwin) + buffer/inferior-cmdl + current-repl-buffer + current-repl-buffer* + edwin-command$inferior-cmdl-abort-nearest + edwin-command$inferior-cmdl-abort-previous + edwin-command$inferior-cmdl-abort-top-level + edwin-command$inferior-cmdl-breakpoint + edwin-command$inferior-cmdl-self-insert + edwin-command$inferior-repl-eval-defun + edwin-command$inferior-repl-eval-last-sexp + edwin-command$inferior-repl-eval-region + edwin-command$repl + edwin-command$set-inferior-repl-buffer + edwin-mode$inferior-cmdl + edwin-mode$inferior-repl + edwin-variable$inferior-repl-write-results + edwin-variable$repl-enable-transcript-buffer + edwin-variable$repl-error-decision + global-repl-buffer + inferior-repl-eval-expression + inferior-repl-eval-region + local-repl-buffer + repl-buffer-list + repl-buffer? + set-local-repl-buffer! + start-inferior-repl!) + (import (runtime user-interface) + default/write-values)) + +(define-package (edwin dired) + (files "dired") + (parent (edwin)) + (export (edwin) + dired-filename-start + dired-mark-files! + dired-marked-files + dired-next-files + dired-pathname + dired-this-file + edwin-command$dired + edwin-command$dired-abort + edwin-command$dired-backup-unmark + edwin-command$dired-clean-directory + edwin-command$dired-do-copy + edwin-command$dired-do-deletions + edwin-command$dired-do-rename + edwin-command$dired-encrypt/decrypt-file + edwin-command$dired-find-file + edwin-command$dired-find-file-other-window + edwin-command$dired-flag-auto-save-files + edwin-command$dired-flag-backup-files + edwin-command$dired-flag-file-deletion + edwin-command$dired-mark + edwin-command$dired-next-line + edwin-command$dired-other-window + edwin-command$dired-previous-line + edwin-command$dired-quit + edwin-command$dired-revert + edwin-command$dired-summary + edwin-command$dired-unmark + edwin-command$dired-unmark-all-files + edwin-command$list-directory + edwin-mode$dired + edwin-variable$dired-backup-overwrite + edwin-variable$dired-kept-versions + edwin-variable$dired-mode-hook + edwin-variable$dired-trivial-filenames + for-each-dired-mark + insert-dired-entry! + make-dired-buffer)) + +(define-package (edwin info) + (files "info") + (parent (edwin)) + (export (edwin) + edwin-command$info + edwin-command$info-cease-edit + edwin-command$info-current-menu-item + edwin-command$info-directory + edwin-command$info-edit + edwin-command$info-exit + edwin-command$info-fifth-menu-item + edwin-command$info-first-menu-item + edwin-command$info-follow-reference + edwin-command$info-fourth-menu-item + edwin-command$info-goto-node + edwin-command$info-help + edwin-command$info-last + edwin-command$info-menu + edwin-command$info-next + edwin-command$info-previous + edwin-command$info-search + edwin-command$info-second-menu-item + edwin-command$info-summary + edwin-command$info-tagify + edwin-command$info-third-menu-item + edwin-command$info-up + edwin-command$info-validate + edwin-variable$info-current-file + edwin-variable$info-current-node + edwin-variable$info-current-subfile + edwin-variable$info-default-directory-list + edwin-variable$info-directory + edwin-variable$info-directory-list + edwin-variable$info-enable-active-nodes + edwin-variable$info-enable-edit + edwin-variable$info-history + edwin-variable$info-previous-search + edwin-variable$info-selection-key + edwin-variable$info-suffix-list + edwin-variable$info-tag-table-end + edwin-variable$info-tag-table-start)) + +(define-package (edwin rectangle) + (files "reccom") + (parent (edwin))) + +(define-package (edwin tags) + (files "tagutl") + (parent (edwin)) + (export (edwin) + edwin-command$find-tag + edwin-command$find-tag-other-window + edwin-command$tags-loop-continue + edwin-command$tags-query-replace + edwin-command$tags-search + edwin-command$visit-additional-tags-table + edwin-command$visit-tags-table + edwin-variable$new-tags-behavior? + edwin-variable$tags-table-pathnames)) + +(define-package (edwin occurrence) + (files "occur") + (parent (edwin)) + (export (edwin) + edwin-command$count-matches + edwin-command$delete-matching-lines + edwin-command$delete-non-matching-lines + edwin-command$flush-lines + edwin-command$how-many + edwin-command$keep-lines + edwin-command$list-matching-lines + edwin-command$occur + edwin-command$occur-mode-goto-occurrence + edwin-mode$occur + edwin-variable$list-matching-lines-default-context-lines + pop-up-occur-buffer)) + +(define-package (edwin debugger) + (files "debug") + (parent (edwin)) + (export (edwin) + debug-scheme-error + edwin-command$browse-continuation + edwin-command$browse-environment + edwin-command$browser-next-line + edwin-command$browser-previous-line + edwin-command$browser-quit + edwin-command$browser-select-line + edwin-command$browser-where + edwin-mode$continuation-browser + edwin-mode$environment-browser + edwin-variable$debugger-confirm-return? + edwin-variable$debugger-expand-reductions? + edwin-variable$debugger-hide-system-code? + edwin-variable$debugger-max-subproblems + edwin-variable$debugger-one-at-a-time? + edwin-variable$debugger-open-markers? + edwin-variable$debugger-quit-on-restart? + edwin-variable$debugger-quit-on-return? + edwin-variable$debugger-show-help-message? + edwin-variable$debugger-split-window? + edwin-variable$debugger-start-new-frame? + edwin-variable$debugger-start-new-screen? + edwin-variable$debugger-verbose-mode? + edwin-variable$environment-package-limit) + (import (runtime debugger) + command/condition-restart + command/frame + command/print-environment-procedure + command/print-expression + command/show-all-frames + command/show-current-frame + debugger-pp + dstate/condition + dstate/environment-list + dstate/expression + dstate/number-of-reductions + dstate/previous-subproblems + dstate/reduction + dstate/reduction-number + dstate/subexpression + dstate/subproblem + dstate/subproblem-number + dstate/using-history? + expression-indentation + improper-list-length + make-initial-dstate + print-reduction-expression + print-subproblem-environment + print-subproblem-expression + reduction-environment + reduction-expression + set-current-subproblem! + set-dstate/environment-list! + set-dstate/reduction-number!) + (import (runtime debugger-utilities) + print-binding + output-to-string + write-dbg-name + print-user-friendly-name) + (import (runtime error-handler) + hook/invoke-restart) + (import (edwin buffer-output-port) + port/mark) + (import (runtime rep) + default/repl-eval + write-restarts)) + +(define-package (edwin text-properties) + (files "txtprp") + (parent (edwin)) + (export (edwin) + add-text-property + get-text-properties + get-text-property + highlight-region + highlight-region-excluding-indentation + highlight-subgroup + local-comtabs + next-property-change + next-specific-property-change + previous-property-change + previous-specific-property-change + region-read-only + region-writeable + remove-text-property + set-region-local-comtabs! + set-subgroup-local-comtabs! + subgroup-read-only + subgroup-writeable) + (export (edwin group-operations) + text-not-deleteable? + text-not-insertable? + text-not-replaceable? + update-intervals-for-deletion! + update-intervals-for-insertion! + update-intervals-for-replacement!) + (export (edwin undo) + group-extract-properties + group-reinsert-properties! + reinsert-properties-size)) + +(define-package (edwin process) + (parent (edwin)) + (import (runtime primitive-io) + channel-descriptor-for-select) + (export (edwin) + accept-process-output + add-process-filter + buffer-processes ; always present + continue-process + delete-process ; always present + edwin-command$list-processes + edwin-command$shell-command + edwin-command$shell-command-on-region + edwin-variable$delete-exited-processes + edwin-variable$exec-path + edwin-variable$process-connection-type + edwin-variable$shell-file-name + get-buffer-process ; always present + get-process-by-name + handle-process-status-changes + hangup-process + interrupt-process + kill-process + process-arguments + process-arguments->string + process-buffer + process-exit-reason + process-filter + process-kill-without-query + process-list ; always present + process-mark + process-name + process-output-available? ; always present + process-runnable? + process-send-char + process-send-eof + process-send-string + process-send-substring + process-sentinel + process-status + process-status-changes? ; always present + process-status-message + quit-process + remove-process-filter + run-synchronous-process + run-synchronous-process-1 + set-process-buffer! + set-process-filter! + set-process-kill-without-query! + set-process-sentinel! + shell-command + standard-process-filter + start-process + stop-process + subprocesses-available? ; always present + )) + +(os-type-case + ((dos) + (define-package (edwin dosjob) + (files "doscom" "dosshell") + (parent (edwin))))) + +(os-type-case + ((unix dos nt) + (define-package (edwin screen console-screen) + (files "ansi" "termcap" "tterm") + (parent (edwin screen)) + (export (edwin) + resize-screen) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) + (import (edwin process) + register-process-output-events) + (import (runtime primitive-io) + channel-descriptor-for-select + %channel-read + channel-type=terminal? + have-select? + terminal-get-state + terminal-output-baud-rate + terminal-raw-input + terminal-raw-output + terminal-set-state) + (initialization (initialize-package!))))) + +(os-type-case + ((unix) + (extend-package (edwin) + (files "unix" + "comint" ; command interpreter process stuff + "compile" ; compilation subprocess + "shell" ; shell subprocess commands + "techinfo" ; techinfo commands + "telnet" ; telnet subprocess commands + "manual" ; man page display + "print" ; printer output + )) + + (extend-package (edwin dired) + (files "dirunx") + (export (edwin) + edwin-command$dired-chgrp + edwin-command$dired-chmod + edwin-command$dired-chown + edwin-command$dired-do-compress)) + + (extend-package (edwin process) + (files "process")) + + (define-package (edwin screen x-screen) + (files "xterm") + (parent (edwin screen)) + (import (runtime ffi) + load-option-quietly))) + ((nt) + (global-definitions "../win32/win32") + + (extend-package (edwin) + (files "dos" + "dosfile" + "comint" ; command interpreter process stuff + "compile" ; compilation subprocess + "shell" ; shell subprocess commands + ) + (import (win32) + get-module-file-name + get-module-handle)) + + (extend-package (edwin dired) + (files "dirw32") + (export (edwin) + edwin-command$dired-chmod + edwin-command$dired-hidden-toggle)) + + (extend-package (edwin screen console-screen) + (files "bios")) + + (extend-package (edwin process) + (files "process")) + + (define-package (edwin screen win32) + (files "win32") + (parent (edwin screen)) + (import (win32) + adjust-window-rect + destroy-window + get-client-rect + get-handle + get-menu + get-system-metrics + get-window-rect + load-icon + make-rect + mb_ok + message-beep + rect/bottom + rect/left + rect/right + rect/top + send-message + set-active-window + set-focus + set-window-pos + set-window-text + show-window + sleep + sm_cxframe + sm_cycaption + sm_cyframe + sm_cymenu + sw_showminnoactive + swp_nomove + swp_nosize + swp_nozorder + update-window + ws_overlappedwindow) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) + (export (edwin win-commands) + win32-screen/get-client-size + win32-screen/get-position + win32-screen/set-background-color! + win32-screen/set-font! + win32-screen/set-foreground-color! + win32-screen/set-icon! + win32-screen/set-name! + win32-screen/set-position! + win32-screen/set-size!) + (initialization (initialize-package!))) + + (define-package (edwin win32-keys) + (files "key-w32") + (parent (edwin)) + (export (edwin screen win32) + win32-make-special-key) + (export (edwin) + ;; the END key + end) + (initialization (initialize-package!))) + + (define-package (edwin win-commands) + (files "win32com") + (parent (edwin)) + (import (win32) + load-icon + get-handle) + (export (edwin) + edwin-command$set-background-color + edwin-command$set-default-font + edwin-command$set-font + edwin-command$set-foreground-color + edwin-command$set-frame-position + edwin-command$set-frame-size + edwin-command$set-icon + edwin-command$show-frame-position + edwin-command$show-frame-size) + (export (edwin screen win32) + update-win32-screen-name!)))) + +(define-package (edwin diff) + (files "diff") + (parent (edwin)) + (export (edwin) + diff-to-buffer + edwin-command$diff + edwin-command$diff-auto-save + edwin-command$diff-backup + edwin-command$diff-buffer-with-file + edwin-variable$diff-program + edwin-variable$diff-switches)) + +(define-package (edwin vc) + (files "vc" + "vc-rcs" + "vc-cvs" + "vc-svn" + "vc-bzr" + "vc-git") + (parent (edwin)) + (export (edwin) + edwin-command$vc-diff + edwin-command$vc-directory + edwin-command$vc-dired + edwin-command$vc-finish-logentry + edwin-command$vc-insert-headers + edwin-command$vc-next-action + edwin-command$vc-print-log + edwin-command$vc-register + edwin-command$vc-revert-buffer + edwin-command$vc-toggle-read-only + edwin-command$vc-version-diff + edwin-command$vc-version-other-window + edwin-mode$vc-log + edwin-variable$git-diff-switches + edwin-variable$vc-checkin-hooks + edwin-variable$vc-checkout-carefully + edwin-variable$vc-command-messages + edwin-variable$vc-cvs-stay-local + edwin-variable$vc-default-init-version + edwin-variable$vc-delete-logbuf-window + edwin-variable$vc-display-status + edwin-variable$vc-follow-symlinks + edwin-variable$vc-initial-comment + edwin-variable$vc-keep-workfiles + edwin-variable$vc-log-mode-hook + edwin-variable$vc-make-backup-files + edwin-variable$vc-mode-line-status + edwin-variable$vc-rcs-preserve-mod-times + edwin-variable$vc-suppress-confirm)) + +(define-package (edwin rcs-parse) + (files "rcsparse") + (parent (edwin)) + (export (edwin) + parse-rcs-admin + rcs-admin/access-list + rcs-admin/branch + rcs-admin/comment + rcs-admin/description + rcs-admin/expand + rcs-admin/head + rcs-admin/locks + rcs-admin/strict? + rcs-admin/symbols + rcs-admin? + rcs-delta/author + rcs-delta/branches + rcs-delta/date + rcs-delta/next + rcs-delta/number + rcs-delta/state + rcs-delta? + rcs-find-delta + rcs-number-head + rcs-number-length)) + +(define-package (edwin sendmail) + (files "sendmail") + (parent (edwin)) + (export (edwin) + add-buffer-mime-attachment! + buffer-mime-attachments + buffer-mime-processing-enabled? + disable-buffer-mime-processing! + edwin-command$add-mime-file-attachment + edwin-command$kill-mime-attachment + edwin-command$mail + edwin-command$mail-bcc + edwin-command$mail-browse-attachments + edwin-command$mail-cc + edwin-command$mail-fill-yanked-message + edwin-command$mail-other-window + edwin-command$mail-send + edwin-command$mail-send-and-exit + edwin-command$mail-signature + edwin-command$mail-subject + edwin-command$mail-to + edwin-command$mail-yank-original + edwin-command$mime-attachments-quit + edwin-mode$mail + edwin-mode$mime-attachments + edwin-variable$file-type-to-mime-type + edwin-variable$mail-abbreviate-mime + edwin-variable$mail-archive-file-name + edwin-variable$mail-authentication + edwin-variable$mail-default-reply-to + edwin-variable$mail-from-style + edwin-variable$mail-full-name + edwin-variable$mail-header-function + edwin-variable$mail-header-separator + edwin-variable$mail-host-address + edwin-variable$mail-identify-reader + edwin-variable$mail-interactive + edwin-variable$mail-mode-hook + edwin-variable$mail-organization + edwin-variable$mail-relay-host + edwin-variable$mail-relay-service + edwin-variable$mail-reply-buffer + edwin-variable$mail-self-blind + edwin-variable$mail-setup-hook + edwin-variable$mail-yank-ignored-headers + edwin-variable$mail-yank-prefix + edwin-variable$mime-attachments-mode-hook + edwin-variable$send-mail-procedure + edwin-variable$sendmail-program + edwin-variable$smtp-greeting-hostname + edwin-variable$smtp-require-valid-recipients + edwin-variable$smtp-trace + edwin-variable$smtp-user-name + edwin-variable$user-mail-address + enable-buffer-mime-processing! + finish-preparing-mail-buffer + global-mailer-version-string + mail-field-end + mail-field-end! + mail-field-region + mail-field-start + mail-from-string + mail-full-name + mail-header-end + mail-insert-field + mail-insert-field-value + mail-insert-field-value! + mail-match-header-separator + mail-new-field! + mail-organization-string + mail-position-on-field + mail-position-on-cc-field + mail-setup + mailer-version-string + make-initialized-mail-buffer + make-mail-buffer + prepare-mail-buffer-for-sending + random-mime-boundary-string + set-buffer-mime-attachments! + user-mail-address)) + +(define-package (edwin mail-alias) + (files "malias") + (parent (edwin)) + (export (edwin) + define-mail-alias + expand-mail-aliases + guarantee-mail-aliases)) + +(define-package (edwin rmail) + (files "rmail" + "rmailsrt" + "rmailsum") + (parent (edwin)) + (export (edwin) + edwin-command$rmail + edwin-command$rmail-delete-backward + edwin-command$rmail-delete-forward + edwin-command$rmail-delete-message + edwin-command$rmail-expunge + edwin-command$rmail-get-new-mail + edwin-command$rmail-input + edwin-command$rmail-last-message + edwin-command$rmail-next-message + edwin-command$rmail-next-undeleted-message + edwin-command$rmail-output + edwin-command$rmail-output-to-rmail-file + edwin-command$rmail-previous-message + edwin-command$rmail-previous-undeleted-message + edwin-command$rmail-reply + edwin-command$rmail-show-message + edwin-command$rmail-sort-by-author + edwin-command$rmail-sort-by-date + edwin-command$rmail-sort-by-recipient + edwin-command$rmail-sort-by-size-lines + edwin-command$rmail-sort-by-subject + edwin-command$rmail-summary + edwin-command$rmail-summary-beginning-of-buffer + edwin-command$rmail-summary-by-recipients + edwin-command$rmail-summary-delete-message + edwin-command$rmail-summary-delete-message-backward + edwin-command$rmail-summary-delete-message-forward + edwin-command$rmail-summary-exit + edwin-command$rmail-summary-expunge + edwin-command$rmail-summary-expunge-and-save + edwin-command$rmail-summary-get-new-mail + edwin-command$rmail-summary-input + edwin-command$rmail-summary-mail + edwin-command$rmail-summary-next-message + edwin-command$rmail-summary-next-undeleted-message + edwin-command$rmail-summary-output + edwin-command$rmail-summary-output-to-rmail-file + edwin-command$rmail-summary-previous-message + edwin-command$rmail-summary-previous-undeleted-message + edwin-command$rmail-summary-quit + edwin-command$rmail-summary-reply + edwin-command$rmail-summary-scroll-message-down + edwin-command$rmail-summary-scroll-message-up + edwin-command$rmail-summary-show-message + edwin-command$rmail-summary-toggle-header + edwin-command$rmail-summary-undelete-message + edwin-command$rmail-summary-undelete-message-backward + edwin-command$rmail-summary-undelete-message-forward + edwin-command$rmail-toggle-header + edwin-command$rmail-undelete-previous-message + edwin-mode$rmail + edwin-mode$rmail-summary + edwin-variable$rmail-buffer + edwin-variable$rmail-default-dont-reply-to-names + edwin-variable$rmail-delete-after-output + edwin-variable$rmail-dont-reply-to-names + edwin-variable$rmail-file-name + edwin-variable$rmail-ignored-headers + edwin-variable$rmail-inbox-list + edwin-variable$rmail-last-file + edwin-variable$rmail-last-rmail-file + edwin-variable$rmail-message-filter + edwin-variable$rmail-mode-hook + edwin-variable$rmail-new-mail-hook + edwin-variable$rmail-pop-accounts + edwin-variable$rmail-pop-procedure + edwin-variable$rmail-primary-inbox-list + edwin-variable$rmail-primary-pop-server + edwin-variable$rmail-reply-with-re + edwin-variable$rmail-summary-buffer + edwin-variable$rmail-summary-mode-hook + edwin-variable$rmail-summary-vector + fetch-all-fields + fetch-first-field + fetch-last-field + guarantee-rmail-variables-initialized + make-in-reply-to-field + prompt-for-rmail-output-filename + rfc822-region->babyl + rfc822-region-reply-headers + rmail-output-to-rmail-file + rmail-output-to-unix-mail-file + rmail-spool-directory + with-buffer-open)) + +(define-package (edwin rfc822) + (files "rfc822") + (parent (edwin)) + (export (edwin) + rfc822:addresses->string + rfc822:canonicalize-address-string + rfc822:canonicalize-named-address-string + rfc822:first-address + rfc822:header-field-name? + rfc822:parse-addr-spec + rfc822:parse-domain + rfc822:parse-list + rfc822:parse-msg-id + rfc822:parse-word + rfc822:quote-string + rfc822:unquote-string + rfc822:received-header-components + rfc822:string->addresses + rfc822:string->named-addresses + rfc822:string->tokens + rfc822:string-tokenizer + rfc822:strip-comments + rfc822:strip-quoted-names + rfc822:tokens->string)) + +(define-package (edwin stepper) + (files "eystep") + (parent (edwin)) + (export (edwin) + edwin-command$step-defun + edwin-command$step-expression + edwin-command$step-last-sexp + edwin-command$stepper-contract + edwin-command$stepper-expand + edwin-command$stepper-run + edwin-command$stepper-step + edwin-command$stepper-step-over + edwin-command$stepper-step-until + edwin-command$stepper-step-until-visibly + edwin-command$stepper-summary + edwin-mode$stepper) + (import (runtime debugger) + debugger-pp) + (import (runtime stepper) + step-output + step-output-final-result + step-output-initialize + stepper-last-event + stepper-root-node + ynode-children + ynode-contract! + ynode-doesnt-need-redisplay! + ynode-exp + ynode-exp-special + ynode-expand! + ynode-hidden-children? + ynode-needs-redisplay? + ynode-result + ynode-result-special + ynode-type + ynode-value-node) + (initialization (initialize-package!))) + +(define-package (edwin paredit) + (files "paredit") + (parent (edwin)) + (export (edwin) + edwin-command$paredit-backslash + edwin-command$paredit-backward + edwin-command$paredit-backward-delete + edwin-command$paredit-close-list + edwin-command$paredit-close-list-and-newline + edwin-command$paredit-close-string-and-newline + edwin-command$paredit-doublequote + edwin-command$paredit-forward + edwin-command$paredit-forward-delete + edwin-command$paredit-kill + edwin-command$paredit-mode + edwin-command$paredit-newline + edwin-command$paredit-open-list + edwin-command$paredit-raise-sexp + edwin-command$paredit-recentre-on-sexp + edwin-command$paredit-splice-sexp + edwin-command$paredit-wrap-sexp + edwin-mode$paredit)) + +(define-package (edwin news-reader) + (files "snr") + (parent (edwin)) + (export (edwin) + edwin-command$news-all-groups + edwin-command$news-catch-up-group + edwin-command$news-clear-read-messages + edwin-command$news-collapse-threads + edwin-command$news-compose-article + edwin-command$news-compose-article-other-window + edwin-command$news-compose-followup-article + edwin-command$news-delete-article + edwin-command$news-delete-thread + edwin-command$news-expand-threads + edwin-command$news-expunge-group + edwin-command$news-forward-article + edwin-command$news-group-next-thread + edwin-command$news-group-next-thread-article + edwin-command$news-group-next-unread-article + edwin-command$news-group-next-unread-header + edwin-command$news-group-previous-thread + edwin-command$news-group-previous-thread-article + edwin-command$news-group-previous-unread-article + edwin-command$news-group-previous-unread-header + edwin-command$news-group-quit + edwin-command$news-group-show-header + edwin-command$news-group-show-subject + edwin-command$news-ignore-article-thread + edwin-command$news-ignore-thread + edwin-command$news-kill-current-buffer + edwin-command$news-mark-article + edwin-command$news-mark-thread + edwin-command$news-move-to-distribution + edwin-command$news-move-to-followup-to + edwin-command$news-move-to-keywords + edwin-command$news-move-to-newsgroups + edwin-command$news-move-to-summary + edwin-command$news-new-groups + edwin-command$news-next-article + edwin-command$news-next-article-in-thread + edwin-command$news-next-thread-article + edwin-command$news-next-unread-article + edwin-command$news-next-unread-article-in-thread + edwin-command$news-output-article + edwin-command$news-output-article-to-rmail-file + edwin-command$news-previous-article + edwin-command$news-previous-article-in-thread + edwin-command$news-previous-thread-article + edwin-command$news-previous-unread-article + edwin-command$news-previous-unread-article-in-thread + edwin-command$news-read-group-headers + edwin-command$news-read-marked-bodies + edwin-command$news-read-subscribed-group-headers + edwin-command$news-refresh-group + edwin-command$news-refresh-groups + edwin-command$news-reply-to-article + edwin-command$news-revert-group + edwin-command$news-save-server-data + edwin-command$news-select-article + edwin-command$news-select-group + edwin-command$news-subscribe-group + edwin-command$news-subscribe-group-by-name + edwin-command$news-toggle-article-context + edwin-command$news-toggle-article-header + edwin-command$news-toggle-online + edwin-command$news-toggle-thread + edwin-command$news-unmark-article + edwin-command$news-unmark-article-backwards + edwin-command$news-unmark-thread + edwin-command$news-unsubscribe-group + edwin-command$news-unsubscribe-group-backwards + edwin-command$read-newsrc-file + edwin-command$rnews + edwin-command$write-newsrc-file + edwin-mode$compose-news + edwin-mode$news-article + edwin-mode$news-common + edwin-mode$news-group + edwin-mode$news-server + edwin-variable$compose-news-mode-hook + edwin-variable$news-article-context-lines + edwin-variable$news-article-highlight-selected + edwin-variable$news-article-mode-hook + edwin-variable$news-automatically-collapse-threads + edwin-variable$news-common-mode-hook + edwin-variable$news-group-author-columns + edwin-variable$news-group-cache-policy + edwin-variable$news-group-ignore-hidden-subjects + edwin-variable$news-group-ignored-subject-retention + edwin-variable$news-group-keep-ignored-headers + edwin-variable$news-group-keep-seen-headers + edwin-variable$news-group-mode-hook + edwin-variable$news-group-show-author-name + edwin-variable$news-group-show-context-headers + edwin-variable$news-group-show-seen-headers + edwin-variable$news-header-filter + edwin-variable$news-hide-groups + edwin-variable$news-initially-collapse-threads + edwin-variable$news-join-threads-with-same-subject + edwin-variable$news-kept-headers + edwin-variable$news-refresh-group-when-selected + edwin-variable$news-server + edwin-variable$news-server-initial-refresh + edwin-variable$news-server-mode-hook + edwin-variable$news-server-name-appearance + edwin-variable$news-server-offline-timeout + edwin-variable$news-server-proxy-alist + edwin-variable$news-show-nonexistent-groups + edwin-variable$news-show-unsubscribed-groups + edwin-variable$news-sort-groups + edwin-variable$news-split-threads-on-subject-changes + news-header-splitting-filter + news-header-regexp-filter)) + +(define-package (edwin nntp) + (files "nntp") + (parent (edwin)) +#| + ;; This program doesn't need to be part of Edwin except for these + ;; two bindings. MESSAGE could be easily implemented in any + ;; interface. OS/FIND-PROGRAM has nothing to do with Edwin in the + ;; first place, and should be in the runtime system. + (parent ()) + (import (edwin) + message + os/find-program) +|# + (export (edwin news-reader) + canonicalize-subject + compare-subjects + find-active-news-group + find-news-group + make-news-group + make-nntp-connection + news-group:< + news-group:active? + news-group:cached-header + news-group:cached-headers + news-group:close-database + news-group:connection + news-group:discard-cached-header! + news-group:estimated-n-articles + news-group:first-article + news-group:header + news-group:headers + news-group:id->header + news-group:last-article + news-group:name + news-group:pre-read-headers + news-group:purge-header-cache + news-group:purge-pre-read-headers + news-group:reader-hook + news-group:server + news-group:server-info + news-group:update-server-info! + news-group:use-gdbm? + news-group? + news-header:< + news-header:field-value + news-header:followup-to + news-header:followups + news-header:from + news-header:group + news-header:guarantee-full-text! + news-header:message-id + news-header:n-lines + news-header:number + news-header:pre-read-body + news-header:pre-read-body? + news-header:read-body + news-header:reader-hook + news-header:real? + news-header:references + news-header:subject + news-header:text + news-header:thread + news-header:xref + news-header? + news-thread:< + news-thread:for-each-header + news-thread:reader-hook + news-thread:root + news-thread? + nntp-connection:active-groups + nntp-connection:close + nntp-connection:closed? + nntp-connection:new-groups + nntp-connection:post-article + nntp-connection:purge-group-cache + nntp-connection:reader-hook + nntp-connection:reopen + nntp-connection:server + nntp-connection? + organize-headers-into-threads + set-news-group:reader-hook! + set-news-group:server-info! + set-news-group:use-gdbm! + set-news-header:reader-hook! + set-news-thread:reader-hook! + set-nntp-connection:reader-hook! + token->number)) + +(define-package (edwin keyparser) + (files "keyparse") + (parent (edwin)) + (export (edwin) + define-keyparser-pattern + define-keyparser-statement-leader + delete-keyparser-pattern + delete-keyparser-statement-leader + edwin-command$complete-keyword + edwin-command$keyparser-indent-line + edwin-command$keyparser-indent-region + edwin-variable$keyparser-description + edwin-variable$keyword-table + keyparse-forward + keyparse-initial + keyparse-partial + keyparser-compute-indentation + keyparser-compute-indentation-1 + keyparser-fragment/indent-body + keyparser-fragment/indent-header + keyparser-fragment/keyword + keyparser-fragment/match-header + keyparser-fragment/parse-body + keyparser-fragment/parse-header + keyparser-fragment/pop-container + keyparser-fragment? + keyparser-patterns + keyparser-stack-entry/end? + keyparser-stack-entry/fragment + keyparser-stack-entry/index + keyparser-stack-entry/keyword + keyparser-stack-entry/pattern + keyparser-stack-entry/start + keyparser-stack-entry? + keyparser-statement-leaders + make-keyparser-description + make-keyparser-fragment)) + +(define-package (edwin verilog) + (files "verilog") + (parent (edwin)) + (export (edwin) + edwin-command$verilog-mode + edwin-mode$verilog)) + +(define-package (edwin vhdl) + (files "vhdl") + (parent (edwin)) + (export (edwin) + edwin-command$vhdl-mode + edwin-mode$vhdl)) + +(define-package (edwin password-edit) + (files "pwedit" "pwparse") + (parent (edwin)) + (export (edwin) + edwin-command$mouse-toggle-pw-form + edwin-command$toggle-pw-form + edwin-command$view-password-file + edwin-mode$password-view)) + +(define-package (edwin debian-changelog) + (files "debian-changelog") + (parent (edwin)) + (export (edwin) + edwin-command$debian-changelog-add-entry + edwin-command$debian-changelog-add-version + edwin-command$debian-changelog-distribution + edwin-command$debian-changelog-finalize-and-save + edwin-command$debian-changelog-finalize-last-version + edwin-command$debian-changelog-unfinalize-last-version + edwin-command$debian-changelog-urgency + edwin-mode$debian-changelog + edwin-variable$add-log-full-name + edwin-variable$add-log-mailing-address + edwin-variable$debian-changelog-mode-hook)) diff --git a/edwin.sf b/edwin.sf new file mode 100644 index 0000000..7b8fe9d --- /dev/null +++ b/edwin.sf @@ -0,0 +1,93 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +(load-option 'cref) + +(if (not (name->package '(edwin))) + (let ((package-set (package-set-pathname "edwin"))) + (if (not (file-modification-timeenvironment '(edwin string)) + 'string?) + (begin + (fluid-let ((sf/default-syntax-table (->environment '(edwin)))) + (sf-conditionally "string")) + (receive (scm bin spec) (sf/pathname-defaulting "string" #f #f) + scm spec + (load bin '(edwin string))))) + +(if (lexical-unreferenceable? (->environment '(edwin class-constructor)) + 'class-descriptors) + (begin + (let ((sf-and-load + (lambda (files package) + (fluid-let ((sf/default-syntax-table (->environment '()))) + (sf-conditionally files)) + (for-each (lambda (file) + (receive (scm bin spec) + (sf/pathname-defaulting file #f #f) + scm spec + (load bin package))) + files)))) + (sf-and-load '("macros") '(edwin macros)) + (sf-and-load '("clsmac") '(edwin class-macros)) + (sf-and-load '("xform") + '(edwin class-macros transform-instance-variables)) + (sf-and-load '("class") '(edwin)) + (sf-and-load '("clscon") '(edwin class-constructor))))) + +(let ((read-class-definitions + (lambda (filename) + (if (environment-bound? system-global-environment 'with-notification) + (with-notification + (lambda (port) + (write-string "Pre-loading class definitions from " port) + (write filename port)) + (lambda () + (syntax* (read-file (string-append filename ".scm")) + (->environment '(edwin window))))) + (begin + (fresh-line) + (write-string "Pre-loading class definitions from ") + (write filename) + (syntax* (read-file (string-append filename ".scm")) + (->environment '(edwin window))) + (write-string " -- done") + (newline)))))) + (read-class-definitions "window") + (read-class-definitions "utlwin") + (read-class-definitions "modwin") + (read-class-definitions "bufwin") + (read-class-definitions "comwin") + (read-class-definitions "buffrm") + (read-class-definitions "edtfrm")) + +(load "decls") + +(cref/generate-constructors "edwin") +(sf-conditionally "edwin.ldr") \ No newline at end of file diff --git a/edwin/abbrev.scm b/edwin/abbrev.scm new file mode 100644 index 0000000..c4d6fc2 --- /dev/null +++ b/edwin/abbrev.scm @@ -0,0 +1,634 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Abbrev Mode + +(declare (usual-integrations)) + +;;;; Low-level data structures + +(define make-abbrev-table make-string-hash-table) +(define abbrev-table? hash-table?) + +(define-structure (abbrev-entry (type-descriptor )) + (expansion #f read-only #t) + (hook #f read-only #t) + (count 0)) + +(define (guarantee-abbrev-table object caller) + (if (not (abbrev-table? object)) + (error:wrong-type-argument object "abbrev table" caller))) + +(define (clear-abbrev-table table) + (set! abbrevs-changed? #t) + (hash-table-clear! table)) + +(define (define-abbrev table abbrev expansion #!optional hook count) + (let ((hook (if (default-object? hook) #f hook)) + (count (if (default-object? count) 0 count))) + (guarantee-abbrev-table table 'DEFINE-ABBREV) + (guarantee-string abbrev 'DEFINE-ABBREV) + (guarantee-string expansion 'DEFINE-ABBREV) + (if hook (guarantee symbol? hook 'DEFINE-ABBREV)) + (guarantee exact-nonnegative-integer? count 'DEFINE-ABBREV) + (set! abbrevs-changed? #t) + (hash-table-set! table + (string-downcase abbrev) + (make-abbrev-entry expansion hook count)))) + +(define (define-global-abbrev abbrev expansion) + (define-abbrev (ref-variable global-abbrev-table #f) abbrev expansion)) + +(define (define-mode-abbrev abbrev expansion) + (let ((table (ref-variable local-abbrev-table))) + (if (not table) + (error "Major mode has no abbrev table.")) + (define-abbrev table abbrev expansion))) + +(define (undefine-abbrev table abbrev) + (guarantee-abbrev-table table 'UNDEFINE-ABBREV) + (guarantee-string abbrev 'UNDEFINE-ABBREV) + (set! abbrevs-changed? #t) + (hash-table-delete! table (string-downcase abbrev))) + +(define (abbrev-entry abbrev where) + (let ((abbrev + (string-downcase + (cond ((string? abbrev) abbrev) + ((symbol? abbrev) (symbol->string abbrev)) + (else + (error:wrong-type-argument abbrev "string" + 'ABBREV-EXPANSION)))))) + (if (abbrev-table? where) + (hash-table-ref/default where abbrev #f) + (let ((buffer (if (not where) (selected-buffer) where))) + (or (let ((table (ref-variable local-abbrev-table buffer))) + (and table + (hash-table-ref/default table abbrev #f))) + (hash-table-ref/default (ref-variable global-abbrev-table #f) + abbrev + #f)))))) + +(define (abbrev-expansion abbrev where) + (let ((entry (abbrev-entry abbrev where))) + (and entry + (abbrev-entry-expansion entry)))) + +(define (define-abbrev-table name definitions) + (let ((table (make-abbrev-table))) + (for-each + (lambda (definition) + (if (not (and (list? definition) + (= 4 (length definition)) + (string? (car definition)) + (string? (cadr definition)) + (symbol? (caddr definition)) + (exact-nonnegative-integer? (cadddr definition)))) + (error "Malformed abbrev definition:" definition)) + (define-abbrev table + (car definition) + (cadr definition) + (if (eq? 'NIL (caddr definition)) #f (caddr definition)) + (cadddr definition))) + definitions) + (set-variable-default-value! (name->variable name 'INTERN) table) + (let ((names (ref-variable abbrev-table-name-list #f))) + (if (not (memq name names)) + (set-variable! abbrev-table-name-list (cons name names) #f))))) + +(define (get-named-abbrev-table name) + (let ((table (variable-default-value (name->variable name 'ERROR)))) + (if (not (abbrev-table? table)) + (error:bad-range-argument name 'GET-NAMED-ABBREV-TABLE)) + table)) + +;;;; Variables + +(define-variable abbrev-table-name-list + "List of symbols whose values are abbrev tables." + (list 'FUNDAMENTAL-MODE-ABBREV-TABLE 'GLOBAL-ABBREV-TABLE) + (lambda (object) (list-of-type? object symbol?))) + +(define-variable global-abbrev-table + "The abbrev table whose abbrevs affect all buffers. +Each buffer may also have a local abbrev table. +If it does, the local table overrides the global one +for any particular abbrev defined in both." + (make-abbrev-table) + abbrev-table?) + +(define-variable fundamental-mode-abbrev-table + "The abbrev table of mode-specific abbrevs for Fundamental Mode." + (make-abbrev-table) + abbrev-table?) + +(define-variable-per-buffer local-abbrev-table + "Local (mode-specific) abbrev table of current buffer." + #f + (lambda (object) + (or (not object) + (abbrev-table? object)))) + +(define-variable abbrev-all-caps + "Set true means expand multi-word abbrevs all caps if abbrev was so." + #f + boolean?) + +(define-variable save-abbrevs + "True means save word abbrevs too when files are saved. +Loading an abbrev file sets this to #t." + #f + boolean?) + +(define-variable only-global-abbrevs + "True means user plans to use global abbrevs only. +This makes the commands that normally define mode-specific abbrevs +define global abbrevs instead." + #f + boolean?) + +(define-variable abbrev-file-name + "Default name of file to read abbrevs from." + (os/abbrev-file-name) + string?) + +(define-variable pre-abbrev-expand-hook + "An event distributor that is invoked prior to expanding an abbrev. +The events are called with a single argument: the current point marker." + (make-event-distributor)) + +(define abbrevs-changed? #f) + +;;;; Abbrev definition + +(define-command add-mode-abbrev + "Define mode-specific abbrev for last word(s) before point. +Argument is how many words before point form the expansion; +or zero means the region is the expansion. +A negative argument means to undefine the specified abbrev. +Reads the abbreviation in the minibuffer. + +Don't use this procedure in a Scheme program; use `define-abbrev' instead." + "p" + (lambda (n) + (add-abbrev (if (ref-variable only-global-abbrevs) + (ref-variable global-abbrev-table #f) + (or (ref-variable local-abbrev-table) + (editor-error "No per-mode abbrev table."))) + "Mode" + n))) + +(define-command add-global-abbrev + "Define global (all modes) abbrev for last word(s) before point. +The prefix argument specifies the number of words before point that form the +expansion; or zero means the region is the expansion. +A negative argument means to undefine the specified abbrev. +This command uses the minibuffer to read the abbreviation. + +Don't use this procedure in a Scheme program; use `define-abbrev' instead." + "p" + (lambda (n) + (add-abbrev (ref-variable global-abbrev-table #f) "Global" n))) + +(define-command inverse-add-mode-abbrev + "Define last word before point as a mode-specific abbrev. +With prefix argument N, defines the Nth word before point. +This command uses the minibuffer to read the expansion. +Expands the abbreviation after defining it." + "p" + (lambda (n) + (inverse-add-abbrev (if (ref-variable only-global-abbrevs) + (ref-variable global-abbrev-table #f) + (or (ref-variable local-abbrev-table) + (editor-error "No per-mode abbrev table."))) + "Mode" + n))) + +(define-command inverse-add-global-abbrev + "Define last word before point as a global (mode-independent) abbrev. +With prefix argument N, defines the Nth word before point. +This command uses the minibuffer to read the expansion. +Expands the abbreviation after defining it." + "p" + (lambda (n) + (inverse-add-abbrev (ref-variable global-abbrev-table #f) + "Global" + n))) + +(define (add-abbrev table type n) + (let ((expansion + (and (>= n 0) + (extract-string + (if (= n 0) + (current-mark) + (backward-word (current-point) n 'LIMIT)))))) + (let ((name + (prompt-for-string + (if expansion + (string-append type " abbrev for \"" expansion "\"") + (string-append "Undefine " type " abbrev")) + #f))) + (if expansion + (conditionally-define-abbrev table name expansion) + (undefine-abbrev table name))))) + +(define (inverse-add-abbrev table type n) + (let* ((m (backward-word (current-point) n 'LIMIT)) + (location (forward-word m 1 'LIMIT)) + (name (extract-string m location)) + (expansion + (prompt-for-string + (string-append type " expansion for \"" name "\"") + #f))) + (if (conditionally-define-abbrev table name expansion) + ((ref-command expand-abbrev) location)))) + +(define (conditionally-define-abbrev table name expansion) + (let ((do-it? + (let ((expansion (abbrev-expansion name table))) + (or (not expansion) + (prompt-for-confirmation? + (string-append name + " expands to \"" + expansion + "\"; redefine")))))) + (if do-it? + (define-abbrev table name expansion)) + do-it?)) + +;;;; Abbrev expansion + +(define-command expand-abbrev + "Expand the abbrev before point, if there is an abbrev there. +Effective when explicitly called even when `abbrev-mode' is nil. +Returns the abbrev symbol, if expansion took place." + "d" + (lambda (mark) + (event-distributor/invoke! (ref-variable pre-abbrev-expand-hook) mark) + (let* ((start + (let ((buffer (selected-buffer))) + (let ((start (buffer-get buffer 'ABBREV-START-LOCATION #f))) + (if start + (begin + (buffer-remove! buffer 'ABBREV-START-LOCATION) + (if (eqv? #\- (extract-right-char start)) + (delete-right-char start)) + (mark-temporary! start) + start) + (backward-word mark 1 #f))))) + (end + (and start + (let ((end (forward-word start 1 'LIMIT))) + (if (mark> end mark) + mark + end))))) + (and start + (mark< start end) + (let* ((abbrev (extract-string start end)) + (entry (abbrev-entry abbrev #f))) + (and entry + (begin + ;; Add an undo boundary, in case we are doing + ;; this for a self-inserting command which has + ;; avoided making one so far. + (undo-boundary! end) + (buffer-put! (selected-buffer) + 'LAST-ABBREV + (let ((expansion + (abbrev-entry-expansion entry))) + (and expansion + (vector abbrev expansion start)))) + (set-abbrev-entry-count! + entry + (+ (abbrev-entry-count entry) 1)) + (let ((expansion (abbrev-entry-expansion entry))) + (if (string? expansion) + (let ((start (mark-right-inserting-copy start)) + (end (mark-left-inserting-copy end))) + (let ((r (make-region start end))) + (region-delete! r) + (insert-string expansion start) + (cond ((string-upper-case? abbrev) + (if (or (ref-variable abbrev-all-caps) + (= (count-words-region r) 1)) + (upcase-region r) + (capitalize-region r))) + ((and (not (string-lower-case? abbrev)) + (let ((m (forward-to-word start #f))) + (and m + (mark< m end) + m))) + => (lambda (m) + (upcase-region + (make-region m (mark1+ m))))))) + (mark-temporary! end) + (mark-temporary! start)))) + (let ((hook (abbrev-entry-hook entry))) + (cond ((symbol? hook) + ((eval hook (->environment '(EDWIN))))) + (hook + (error "Abbrev hook must be symbol:" hook)))) + abbrev))))))) + +(define-command unexpand-abbrev + "Undo the expansion of the last abbrev that expanded. +This differs from ordinary undo in that other editing done since then +is not undone." + () + (lambda () + (let ((last (buffer-get (selected-buffer) 'LAST-ABBREV #f))) + (if last + (let ((abbrev (vector-ref last 0)) + (expansion (vector-ref last 1)) + (start (vector-ref last 2))) + (let ((end (mark+ start (string-length expansion)))) + (if (not (string-ci=? (extract-string start end) expansion)) + (editor-error "Can't expand abbrev; contents changed.")) + (delete-string start end) + (insert-string abbrev start)) + (buffer-remove! (selected-buffer) 'LAST-ABBREV)))))) + +(define-command abbrev-prefix-mark + "Mark current point as the beginning of an abbrev. +Abbrev to be expanded starts here rather than at beginning of word. +This way, you can expand an abbrev with a prefix: insert the prefix, +use this command, then insert the abbrev." + "P" + (lambda (argument) + (if (not argument) + ((ref-command expand-abbrev) (current-point))) + (buffer-put! (selected-buffer) + 'ABBREV-START-LOCATION + (mark-right-inserting-copy (current-point))) + (insert-string "-"))) + +(define-command expand-region-abbrevs + "For abbrev occurrence in the region, offer to expand it. +The user is asked to type y or n for each occurrence. +A prefix argument means don't query; expand all abbrevs." + "r\nP" + (lambda (region no-query?) + (let ((end (region-end region))) + (let loop ((start (region-start region))) + (let ((ws (forward-to-word start #f))) + (if (and ws (mark< ws end)) + (let ((we (forward-word ws 1 'LIMIT))) + (if (and (mark<= we end) + (let ((word (extract-string ws we))) + (and (abbrev-expansion word #f) + (or no-query? + (prompt-for-confirmation? + (string-append "Expand \"" word "\"")))))) + (let ((we (mark-left-inserting-copy we))) + ((ref-command expand-abbrev) we) + (mark-temporary! we) + (loop we)) + (loop we))))))))) + +(define-minor-mode abbrev "Abbrev" + "Minor mode in which abbrevs are expanded.") + +(define-command abbrev-mode + "Toggle abbrev mode. +With argument ARG, turn abbrev mode on iff ARG is positive. +In abbrev mode, inserting an abbreviation causes it to expand +and be replaced by its expansion." + "P" + (lambda (argument) + (let ((mode (ref-mode-object abbrev))) + (if (if argument + (> (command-argument-numeric-value argument) 0) + (not (current-minor-mode? mode))) + (enable-current-minor-mode! mode) + (disable-current-minor-mode! mode))))) + +;;;; Editing abbrevs + +(define-command edit-abbrevs + "Alter abbrev definitions by editing a list of them. +Selects a buffer containing a list of abbrev definitions. +You can edit them and type \\\\[edit-abbrevs-redefine] to redefine abbrevs +according to your editing. +Buffer contains a header line for each abbrev table, + which is the abbrev table name in parentheses. +This is followed by one line per abbrev in that table: +NAME USECOUNT EXPANSION HOOK +where NAME and EXPANSION are strings with quotes, +USECOUNT is an integer, and HOOK is any valid function +or may be omitted (it is usually omitted)." + () + (lambda () (select-buffer (prepare-abbrev-list-buffer)))) + +(define-command list-abbrevs + "Display a list of all defined abbrevs." + () + (lambda () (pop-up-buffer (prepare-abbrev-list-buffer) #f))) + +(define (prepare-abbrev-list-buffer) + (let ((buffer (find-or-create-buffer "*Abbrevs*"))) + (buffer-reset! buffer) + (insert-abbrev-table-descriptions (buffer-start buffer)) + (buffer-not-modified! buffer) + (set-buffer-point! buffer (buffer-start buffer)) + (set-buffer-major-mode! buffer (ref-mode-object edit-abbrevs)) + buffer)) + +(define-command insert-abbrevs + "Insert after point a description of all defined abbrevs. +Mark is set after the inserted text." + () + (lambda () + (let ((point (mark-right-inserting-copy (current-point)))) + (insert-abbrev-table-descriptions (current-point)) + (set-current-mark! (current-point)) + (set-current-point! point)))) + +(define (insert-abbrev-table-descriptions mark) + (let ((mark (mark-left-inserting-copy mark))) + (for-each + (lambda (name) + (let ((table (get-named-abbrev-table name))) + (insert-string "(" mark) + (insert-string (symbol->string name) mark) + (insert-string ")\n\n" mark) + (hash-table-walk table + (lambda (abbrev entry) + (if (abbrev-entry-expansion entry) + (begin + (insert abbrev mark) + (indent-to 15 1 mark) + (insert (abbrev-entry-count entry) mark) + (indent-to 20 1 mark) + (insert (abbrev-entry-expansion entry) mark) + (if (abbrev-entry-hook entry) + (begin + (indent-to 45 1 mark) + (insert (abbrev-entry-hook entry) mark))) + (insert-newline mark))))) + (insert-string "\n\n" mark))) + (ref-variable abbrev-table-name-list #f)) + (mark-temporary! mark))) + +(define-major-mode edit-abbrevs fundamental "Edit-Abbrevs" + "Major mode for editing the list of abbrev definitions. + +\\{edit-abbrevs}" + (lambda (buffer) + buffer + unspecific)) + +(define-key 'edit-abbrevs '(#\C-x #\C-s) 'edit-abbrevs-redefine) +(define-key 'edit-abbrevs '(#\C-c #\C-c) 'edit-abbrevs-redefine) + +(define-command edit-abbrevs-redefine + "Redefine abbrevs according to current buffer contents." + () + (lambda () + ((ref-command define-abbrevs) #t) + (buffer-not-modified! (selected-buffer)))) + +(define-command define-abbrevs + "Define abbrevs according to current visible buffer contents. +See documentation of \\[edit-abbrevs] for info on the format of the +text you must have in the buffer. +With argument, eliminate all abbrev definitions except +the ones defined from the buffer now." + "P" + (lambda (argument) + (if argument ((ref-command kill-all-abbrevs))) + (let ((buffer (selected-buffer))) + (let read-tables ((start (buffer-start buffer))) + (let ((m (re-search-forward "^(" start))) + (define (read-expr) + (with-input-from-mark m read + (lambda (expr m*) + (set! m m*) + expr))) + (if m + (let ((name (read-expr))) + (set! m (forward-line m 1 'LIMIT)) + (define-abbrev-table name + (let loop () + (set! m (forward-line m 1 'LIMIT)) + (if (line-end? m) + '() + (let* ((abbrev (read-expr)) + (count (read-expr)) + (expansion (read-expr))) + (set! m (skip-chars-backward " \t\n\f" m)) + (let ((hook + (if (line-end? m) + 'NIL + (read-expr)))) + (set! m (skip-chars-backward " \t\n\f" m)) + (cons (list abbrev expansion hook count) + (loop))))))) + (read-tables m)))))))) + +(define-command kill-all-abbrevs + "Undefine all defined abbrevs." + () + (lambda () + (for-each (lambda (name) + (clear-abbrev-table (get-named-abbrev-table name))) + (ref-variable abbrev-table-name-list #f)) + (set-variable! abbrev-table-name-list '() #f))) + +;;;; Abbrev-file I/O + +(define-command read-abbrev-file + "Read abbrev definitions from file written with `write-abbrev-file'. +Argument FILENAME is the name of the file to read; +it defaults to the value of `abbrev-file-name'." + (lambda () + (list + (prompt-for-existing-file "Read abbrev file" + (list (ref-variable abbrev-file-name #f))))) + (lambda (filename) + (let ((filename (abbrev-file/filename filename))) + ((message-wrapper #f "Loading " filename) + (lambda () + (quietly-read-abbrev-file filename)))))) + +(define (quietly-read-abbrev-file #!optional filename) + (let ((filename + (abbrev-file/filename + (if (default-object? filename) #f filename)))) + (load-edwin-file filename '(EDWIN) #f) + (set-variable! save-abbrevs #t #f) + (set! abbrevs-changed? #f) + unspecific)) + +(define-command write-abbrev-file + "Write all abbrev definitions to a file of Lisp code. +The file written can be loaded in another session to define the same abbrevs. +The argument FILENAME is the file name to write." + (lambda () + (list + (prompt-for-file "Write abbrev file" + (merge-pathnames (ref-variable abbrev-file-name #f))))) + (lambda (filename) + (let ((filename (abbrev-file/filename filename))) + (call-with-output-file filename + (lambda (port) + (for-each + (lambda (name) + (let ((table (get-named-abbrev-table name))) + (write-string "(define-abbrev-table '" port) + (write name port) + (write-string " '(" port) + (newline port) + (hash-table-walk table + (lambda (abbrev entry) + (if (abbrev-entry-expansion entry) + (begin + (write-string " " port) + (write (list abbrev + (abbrev-entry-expansion entry) + (or (abbrev-entry-hook entry) 'NIL) + (abbrev-entry-count entry)) + port) + (newline port))))) + (write-string " ))" port) + (newline port) + (newline port))) + (ref-variable abbrev-table-name-list #f))))))) + +(define (abbrev-file/filename filename) + (or filename (ref-variable abbrev-file-name #f))) + +(define (maybe-save-abbrevs no-confirmation?) + (and (ref-variable save-abbrevs #f) + abbrevs-changed? + (begin + (if (or no-confirmation? + (prompt-for-confirmation? + (string-append "Save abbrevs in " + (ref-variable abbrev-file-name #f)))) + ((ref-command write-abbrev-file) #f)) + ;; Don't keep bothering user if he says no. + (set! abbrevs-changed? #f) + #t))) \ No newline at end of file diff --git a/edwin/adapters.scm b/edwin/adapters.scm new file mode 100644 index 0000000..9be2acd --- /dev/null +++ b/edwin/adapters.scm @@ -0,0 +1,64 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Runtime-system adapters +;;; package: (edwin adapters) + +;;; This file contains adapters that bridge between Edwin and the runtime +;;; system. These are necessary because Edwin has assumptions about the +;;; behavior of the runtime system that are no longer valid. Since some of +;;; these assumptions are deeply rooted, it's easier to adapt around them rather +;;; than rewrite Edwin. + +;;; The most critical assumption is that Edwin relies on an older model of +;;; strings, in which each character is a byte, and the default coding is ISO +;;; 8859-1, while the runtime system now supports full Unicode and uses a +;;; default coding of UTF 8. Most of that is taken care of by the (edwin +;;; string) package, which contains a copy of the runtime's old string +;;; implementation. Other things, like file I/O, are handled here. + +(declare (usual-integrations)) + +(define (call-with-file-adapter procedure) + (lambda (pathname receiver) + (procedure pathname + (lambda (port) + (port/set-coding port 'iso-8859-1) + (receiver port))))) + + +(define edwin:call-with-append-file + (call-with-file-adapter call-with-append-file)) + +(define edwin:call-with-input-file + (call-with-file-adapter call-with-input-file)) + +(define edwin:call-with-output-file + (call-with-file-adapter call-with-output-file)) + +(define char-set:graphic + (char-set-union (ucs-range->char-set #x20 #x7F) + (ucs-range->char-set #xA0 #x100))) \ No newline at end of file diff --git a/edwin/ansi.scm b/edwin/ansi.scm new file mode 100644 index 0000000..6351b66 --- /dev/null +++ b/edwin/ansi.scm @@ -0,0 +1,153 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Hard-coded ANSI terminal type for lack of termcap on DOS/NT + +(declare (usual-integrations)) + +(define (make-ansi-terminal-description columns lines) + (define (get-numstring base-name) + (or (get-environment-variable (string-append "EDWIN_" base-name)) + (get-environment-variable base-name))) + + (define (valid-mode? color-string) + (and (string? color-string) + (= (string-length color-string) 2) + (member (string-ref color-string 0) + '(#\3 #\4)) + (member (string-ref color-string 1) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)))) + + (define (invert-mode color-string) + (make-mode (string (if (eqv? (string-ref color-string 0) #\3) + #\4 + #\3) + (string-ref color-string 1)))) + + (define (make-mode color-string) + (or (and (valid-mode? color-string) + (string-append ";" color-string)) + "")) + + (let ((foregnd (get-numstring "FOREGROUND")) + (backgnd (get-numstring "BACKGROUND"))) + (let ((full? (not (eq? 'DOS microcode-id/operating-system))) + (normal + (string-append "\033[0" + (make-mode foregnd) + (make-mode backgnd) + "m")) + (standout + (if (or (not (valid-mode? foregnd)) (not (valid-mode? backgnd))) + (string-append "\033[7" + (make-mode foregnd) + (make-mode backgnd) + "m") + (string-append "\033[0" + (invert-mode backgnd) + (invert-mode foregnd) + "m")))) + + (%make-termcap-description + "ansi.sys" ; terminal-type-name + false ; delete-is-insert-mode? + false ; enter/exit-standout-mode-same? + (and full? "\033[P") ; insert/delete-char-ok? + (and full? "\033[M") ; insert/delete-line-ok? + false ; scroll-region-ok? + #t ; tf-automatic-wrap + false ; tf-cursor-backwards-wrap + false ; tf-generic + false ; tf-hardcopy + false ; tf-hazeltine + false ; tf-insert-mode-motion + false ; tf-lose-wrap + false ; tf-magic-wrap + false ; tf-memory-above-screen + false ; tf-memory-below-screen + false ; tf-meta-key + false ; tf-must-write-spaces + false ; tf-newline-doesnt-scroll + false ; tf-overstrike + false ; tf-overstrike-space-erase + false ; tf-overwrite-preserves-standout + false ; tf-standout-mode-motion + false ; tf-teleray + false ; tf-underscore + false ; tn-memory-lines + false ; tn-minimum-padding-speed + false ; tn-standout-marker-width + columns ; tn-x-size + lines ; tn-y-size + "\a" ; ts-audible-bell + "\033[K" ; ts-clear-line + false ; ts-clear-multi-char + "\033[H\033[J" ; ts-clear-screen + "\033[J" ; ts-clear-to-bottom + "\n" ; ts-cursor-down + false ; ts-cursor-down-multi + "\b" ; ts-cursor-left + false ; ts-cursor-left-multi + "\r" ; ts-cursor-line-start + false ; ts-cursor-lower-left + "\033[%i%d;%dH" ; ts-cursor-move + false ; ts-cursor-move-x + "\033[C" ; ts-cursor-right + (and full? "\033[%dC") ; ts-cursor-right-multi + "\033[A" ; ts-cursor-up + (and full? "\033[%dA") ; ts-cursor-up-multi + "\033[H" ; ts-cursor-upper-left + (and full? "\033[P") ; ts-delete-char + (and full? "\033[M") ; ts-delete-line + (and full? "\033[%dP") ; ts-delete-multi-char + (and full? "\033[%dM") ; ts-delete-multi-line + false ; ts-enhance-cursor + false ; ts-enter-delete-mode + false ;"\033[4h" ; ts-enter-insert-mode + standout;"\033[7m" ; ts-enter-standout-mode + (and full? "\033[1p") ; ts-enter-termcap-mode + false ; ts-exit-delete-mode + false ;"\033[4l" ; ts-exit-insert-mode + normal;"\033[0m" ; ts-exit-standout-mode + (and full? "\033[0p") ; ts-exit-termcap-mode + "\n" ; ts-forward-scroll + false ; ts-forward-scroll-multi + (and full? "\033[@") ; ts-insert-char + (and full? "\033[L") ; ts-insert-line + (and full? "\033[%d@") ; ts-insert-multi-char + (and full? "\033[%dL") ; ts-insert-multi-line + false ; ts-invisible-cursor + false ; ts-normal-cursor + false ; ts-pad-char + false ; ts-pad-inserted-char + false ; ts-reverse-scroll + false ; ts-reverse-scroll-multi + false ; ts-set-scroll-region + false ; ts-set-scroll-region-1 + false ; ts-set-window + false ; ts-visible-bell + '() ; termcap-description-keys + )))) \ No newline at end of file diff --git a/edwin/argred.scm b/edwin/argred.scm new file mode 100644 index 0000000..350f8af --- /dev/null +++ b/edwin/argred.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Command Argument Reader + +(declare (usual-integrations)) + +(define-command universal-argument + "Begin a numeric argument for the following command. +Digits or minus sign following this command make up the numeric argument. +If no digits or minus sign follow, this command by itself provides 4 as argument. +Used more than once, this command multiplies the argument by 4 each time." + "P" + (lambda (argument) + (set-command-argument! (list (* (if (pair? argument) (car argument) 1) 4)) + (key-name (last-command-key))))) + +(define-command digit-argument + "Part of the numeric argument for the next command." + "P" + (lambda (argument) + (digit-argument argument (auto-argument-mode?)))) + +(define (digit-argument argument mode) + (let ((key (last-command-key))) + (if (char? key) + (let ((digit (char->digit (char-base key)))) + (if digit + (set-command-argument! + (cond ((eq? '- argument) (- digit)) + ((not (number? argument)) digit) + ((negative? argument) (- (* 10 argument) digit)) + (else (+ (* 10 argument) digit))) + mode)))))) + +(define-command negative-argument + "Begin a negative numeric argument for the next command." + "P" + (lambda (argument) + (negative-argument argument (auto-argument-mode?)))) + +(define (negative-argument argument mode) + (set-command-argument! (cond ((eq? '- argument) false) + ((number? argument) (- argument)) + (else '-)) + mode)) + +(define-command auto-argument + "Start a command argument. +Digits following this command become part of the argument." + "P" + (lambda (argument) + (let ((mode (if argument (auto-argument-mode?) true))) + (if (let ((key (last-command-key))) + (and (char? key) + (char=? #\- (char-base key)))) + (if (not (number? argument)) + (negative-argument argument mode)) + (digit-argument argument mode))))) + +(define-command auto-digit-argument + "When reading a command argument, part of the numeric argument. +Otherwise, the digit inserts itself." + "P" + (lambda (argument) + (if (auto-argument-mode?) + ((ref-command digit-argument) argument) + ((ref-command self-insert-command) argument)))) + +(define-command auto-negative-argument + "When reading a command argument, begin a negative argument. +Otherwise, the character inserts itself." + "P" + (lambda (argument) + (if (and (auto-argument-mode?) + (not (number? argument))) + ((ref-command negative-argument) argument) + ((ref-command self-insert-command) argument)))) + +(define (command-argument-self-insert? command) + (and (or (eq? command (ref-command-object auto-digit-argument)) + (and (eq? command (ref-command-object auto-negative-argument)) + (not (number? (command-argument))))) + (not (auto-argument-mode?)))) + +(define (command-argument-prompt) + (let ((arg (command-argument))) + (if (not arg) + "" + (let ((mode (auto-argument-mode?))) + (string-append + (if (and (pair? arg) (string? mode)) + (let loop ((n (car arg))) + (if (= n 4) + mode + (string-append mode " " (loop (quotient n 4))))) + (string-append + (cond ((string? mode) mode) + (mode "Autoarg") + (else "Arg")) + " " + (if (eq? '- arg) + "-" + (number->string (if (pair? arg) (car arg) arg))))) + " -"))))) + +(define (command-argument-multiplier-only? argument) + (pair? argument)) + +(define (command-argument-negative-only? argument) + (eq? '- argument)) + +(define (command-argument-value argument) + (cond ((not argument) false) + ((eq? '- argument) -1) + ((pair? argument) (car argument)) + (else argument))) + +(define (command-argument-numeric-value argument) + (or (command-argument-value argument) 1)) \ No newline at end of file diff --git a/edwin/artdebug.scm b/edwin/artdebug.scm new file mode 100644 index 0000000..633f725 --- /dev/null +++ b/edwin/artdebug.scm @@ -0,0 +1,1356 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Continuation Browser + +(declare (usual-integrations)) + +#| TO DO + +Make environment browsing mode; the debugger mode can be a superset +of that mode: Add optional marker lines for environments. If you do +the C-c C-a command to describe the environment frames in the current +subproblem or reduction, the debugger should use the correct +environment when you do evaluations in those environment frames. +Make commands for moving by environment level. Later, change this to +execute Where in another buffer depending on the state of a flag. + +Make a variable that specifies whether to prompt the user if more +than a certain number of variables are about to be printed during an +environment-browsing command. + +By default, when the debugger starts, don't show history levels +inside the system. To detect system code, see +~arthur/new6001/detect.scm. Predicate SYSTEM-FRAME? is already +in place. + +MarkF has code to use the correct syntax tables for evaluation. + +Add limits to the depth and breadth of objects printed by the +debugger, to avoid problems caused by displaying circular objects. +Note $se/evlcom.scm: TRANSCRIPT-LIST-DEPTH-LIMIT and +TRANSCRIPT-LIST-BREADTH-LIMIT. + +Make C-c C-k evaluate in the environment in which the error occurred. +Otherwise, the "Define x to a given value" restart for unbound +variable errors won't work. This seems to be a bug in the regular +debugger, too. + +Make C-c C-z work in the case where an error happens during +evaluation of the return expression, the debugger starts on the new +error, and return is done from the second debugger straight through +the first back into the original computation. The restart itself +works, but the message "Scheme error" is printed upon starting the +second debugger. + +Jinx: Depending on the state of a flag, never invoke debugger on +unbound variable errors from the expression you eval in the +interaction buffer (or debugger buffer). Actually, how about a +general filter on conditions that will start the debugger? Provide a +default filter for ignoring unbound variables. + +Jinx: Display the offending expression evaluated by the user. Display +it just above the error message line. + +Make a way to restrict the possible restarts to not include restarts +that could stop Edwin. + +Make a narrow interface between Edwin and the debugger so it will be +easy to write this debugger for Emacs. + +Number input lines so that it is possible to tell the order in which +you evaluated your expressions. This could be particularly useful +for TAs looking over students' shoulders. + +Once outline mode has been written for Edwin, add commands to expand +and contract subproblems and reductions. + +|# + +(define-variable debugger-confirm-return? + "True means to prompt for confirmation in RETURN-FROM and RETURN-TO +commands before returning the value." + #t + boolean?) + +(define-variable debugger-split-window? + "True means use another window for the debugger buffer; false means +use the current window." + #t + boolean?) + +(define-variable debugger-one-at-a-time? + "True means delete an existing debugger buffer before before +starting a new debugger, ASK means ask the user, and false means +always create a new debugger buffer. If there is more than one +debugger buffer at the time a new debugger is started, the debugger +will always create a new buffer." + 'ASK + (lambda (value) (or (boolean? value) (eq? value 'ASK)))) + +(define-variable debugger-quit-on-return? + "True means quit debugger when executing a \"return\" command." + #t + boolean?) + +(define-variable debugger-quit-on-restart? + "True means quit debugger when executing a \"restart\" command." + #t + boolean?) + +(define-variable debugger-open-markers? + "True means newlines are inserted between marker lines." + #t + boolean?) + +(define-variable debugger-verbose-mode? + "True means display extra information without the user requesting it." + #f + boolean?) + +(define-variable debugger-expand-reductions? + "True says to insert reductions when reduction motion commands are used +in a subproblem whose reductions aren't already inserted." + #t + boolean?) + +(define-variable debugger-max-subproblems + "Maximum number of subproblems displayed when debugger starts, +or #F meaning no limit." + 3 + (lambda (number) + (or (not number) + (and (exact-integer? number) + (> number 0))))) + +(define-variable debugger-hide-system-code? + "True means don't show subproblems created by the runtime system." + #t + boolean?) + +(define-variable debugger-show-help-message? + "True means show a help message in the debugger buffer." + #t + boolean?) + +(define-variable debugger-debug-evaluations? + "True means evaluation errors in a debugger buffer start new debuggers." + #f + boolean?) + +(define starting-debugger? #f) +(define in-debugger-evaluation? #f) + +(define (debug-scheme-error error-type condition ask?) + (cond (starting-debugger? + (quit-editor-and-signal-error condition)) + ((and in-debugger-evaluation? + (not (ref-variable debugger-debug-evaluations? #f))) + unspecific) + (else + (let ((start-debugger + (lambda () + (fluid-let ((starting-debugger? #t)) + ((if (ref-variable debugger-split-window? #f) + select-buffer-other-window + select-buffer) + (continuation-browser-buffer condition)))))) + (if ask? + (if (cleanup-pop-up-buffers + (lambda () + (standard-error-report error-type condition #t) + (editor-beep) + (prompt-for-confirmation? "Start debugger"))) + (start-debugger)) + (begin + (start-debugger) + (message (string-capitalize (symbol->string error-type)) + " error") + (editor-beep)))) + (return-to-command-loop condition)))) + +(define-command browse-continuation + "Invoke the continuation-browser on CONTINUATION." + "XBrowse Continuation" + (lambda (continuation) + (let ((buffer (continuation-browser-buffer continuation))) + ((if (ref-variable debugger-split-window?) + select-buffer-other-window + select-buffer) + buffer)))) + +(define-integrable (buffer-dstate buffer) + (buffer-get buffer 'DEBUG-STATE)) + +;;;; Main Entry + +(define (continuation-browser-buffer object) + (let ((buffers (find-debugger-buffers))) + (if (and (not (null? buffers)) + (null? (cdr buffers)) + (ref-variable debugger-one-at-a-time?) + (or (eq? #t (ref-variable debugger-one-at-a-time?)) + (prompt-for-confirmation? + "Another debugger buffer exists. Delete it"))) + (kill-buffer (car buffers)))) + (let ((buffer (new-buffer "*debug*")) + (dstate (make-initial-dstate object))) + (set-buffer-major-mode! buffer (ref-mode-object continuation-browser)) + (buffer-put! buffer 'DEBUG-STATE dstate) + (let ((top-subproblem + (let ((previous-subproblems (dstate/previous-subproblems dstate))) + (if (null? previous-subproblems) + (dstate/subproblem dstate) + (car (last-pair previous-subproblems))))) + (max-subproblems (ref-variable debugger-max-subproblems buffer)) + (hide-system-code? (ref-variable debugger-hide-system-code? buffer))) + (with-group-undo-disabled (buffer-group buffer) + (lambda () + (let ((port (mark->output-port (buffer-start buffer)))) + (if (ref-variable debugger-show-help-message? buffer) + (print-help-message buffer port)) + (if (condition? object) + (begin + (write-string "The error that started the debugger is:" port) + (newline port) + (write-string " " port) + (write-condition-report object port) + (newline port) + (newline port) + (print-restarts object buffer port))) + (if (let loop ((frame top-subproblem) (level 0)) + (and frame + (or (and max-subproblems (= level max-subproblems)) + (and hide-system-code? (system-frame? frame)) + (begin + (newline port) + (print-subproblem level frame port) + (loop (stack-frame/next-subproblem frame) + (+ level 1)))))) + (display-more-subproblems-message buffer))))) + (let ((point (forward-subproblem (buffer-start buffer) 1))) + (set-buffer-point! buffer point) + (if (ref-variable debugger-verbose-mode? buffer) + (invoke-debugger-command mark + command/print-subproblem-or-reduction)) + (push-buffer-mark! buffer point) + (buffer-not-modified! buffer) + buffer)))) + +(define (find-debugger-buffers) + (let ((debugger-mode (ref-mode-object continuation-browser))) + (let loop ((buffers (buffer-list))) + (cond ((null? buffers) + buffers) + ((eq? (buffer-major-mode (car buffers)) debugger-mode) + (cons (car buffers) (loop (cdr buffers)))) + (else + (loop (cdr buffers))))))) + +(define (print-help-message buffer port) + (write-string (substitute-command-keys debugger-help-message buffer) port) + (newline port) + (newline port)) + +(define debugger-help-message + "This is a debugger buffer: + + Marker lines identify stack frames, most recent first. + Expressions are evaluated in the environment of the line above the point. + + In the marker lines, + + -C- means frame was generated by Compiled code + -I- means frame was generated by Interpreted code + + S=x means frame is in subproblem number x + R=y means frame is reduction number y + #R=z means there are z reductions in the subproblem; + use \\[continuation-browser-forward-reduction] to see them + + \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction. + \\[describe-mode] shows information about debugger commands. + Use \\[kill-buffer] to quit the debugger.") + +(define (print-restarts condition buffer port) + (let ((restarts (condition/restarts condition))) + (if (not (null? restarts)) + (begin + (write-string "Restart options:" port) + (write-restarts restarts port + (lambda (index port) + (write-string (string-pad-left (number->string index) 3) port) + (write-string ":" port))) + (write-string + (substitute-command-keys + "Use \\[continuation-browser-condition-restart] to invoke any of these restarts." + buffer) + port) + (newline port))))) + +(define (system-frame? frame) + frame ;ignore + #f) + +(define-major-mode continuation-browser scheme "Debug" + "Major mode for debugging Scheme programs and browsing Scheme continuations. +Evaluation commands are similar to those of Scheme Interaction mode. + + Marker lines identify stack frames, most recent first. + Expressions are evaluated in the environment of the line above the point. + + In the marker lines, + + -C- means frame was generated by Compiled code + -I- means frame was generated by Interpreted code + + S=x means frame is in subproblem number x + R=y means frame is reduction number y + #R=z means there are z reductions in the subproblem; + use \\[continuation-browser-forward-reduction] to see them + +Evaluate expressions + + \\[continuation-browser-eval-last-sexp] evaluates the expression preceding point in the + environment of the current frame. + \\[continuation-browser-eval-last-sexp/dynamic] evaluates the expression preceding point in the + environment AND DYNAMIC STATE of the current frame. + +Move between subproblems and reductions + + \\[continuation-browser-forward-reduction] moves forward one reduction (earlier in time). + \\[continuation-browser-backward-reduction] moves backward one reduction (later in time). + + \\[continuation-browser-forward-subproblem] moves forward one subproblem (earlier in time). + \\[continuation-browser-backward-subproblem] moves backward one subproblem (later in time). + + \\[continuation-browser-go-to] moves directly to a subproblem (given its number). + +Display debugging information + + \\[continuation-browser-show-all-frames] shows All bindings of the current environment and its ancestors. + \\[continuation-browser-show-current-frame] shows bindings of identifiers in the Current environment. + \\[continuation-browser-print-environment] describes the current Environment. + \\[continuation-browser-print-expression] pretty prints the current expression. + \\[continuation-browser-print-environment-procedure] pretty prints the procedure that created the current environment. + \\[continuation-browser-expand-reductions] shows the Reductions of the current subproblem level. + \\[continuation-browser-print-subproblem-or-reduction] describes the current subproblem or reduction. + \\[continuation-browser-expand-subproblems] shows subproblems not already displayed. + \\[continuation-browser-frame] displays the current stack frame in internal format. + +Miscellany + + \\[continuation-browser-condition-restart] continues the program using a standard restart option. + \\[continuation-browser-return-from] returns from the current subproblem with the value of the expression + preceding the point. + \\[continuation-browser-return-to] returns to the current subproblem with the value of the expression + preceding the point. + \\[continuation-browser-retry] retries the offending expression, returning from the current + subproblem with its value. + +Use \\[kill-buffer] to quit the debugger." + (lambda (buffer) + (define-variable-local-value! buffer + (ref-variable-object comint-input-ring) + (make-ring (ref-variable comint-input-ring-size))) + (define-variable-local-value! buffer + (ref-variable-object evaluation-input-recorder) + continuation-browser-input-recorder) + (define-variable-local-value! buffer + (ref-variable-object evaluation-output-receiver) + continuation-browser-output-receiver))) + +(define (continuation-browser-input-recorder region) + (ring-push! (ref-variable comint-input-ring) (region->string region))) + +(define (continuation-browser-output-receiver value output) + (let ((point (mark-left-inserting-copy (current-point)))) + (insert-string output point) + (guarantee-newlines 1 point) + (insert-string (transcript-value-prefix-string value #t) point) + (insert-string (transcript-value-string value) point) + (insert-newlines 2 point) + (mark-temporary! point))) + +;;; Disable EVAL-CURRENT-BUFFER in Debugger Mode. It is inherited +;;; from Scheme mode but does not make sense here: + +(define-key 'continuation-browser #\M-o + 'undefined) + +;;; Comint History +(define-key 'continuation-browser #\M-p + 'comint-previous-input) +(define-key 'continuation-browser #\M-n + 'comint-next-input) +(define-key 'continuation-browser '(#\C-c #\C-r) + 'comint-history-search-backward) +(define-key 'continuation-browser '(#\C-c #\C-s) + 'comint-history-search-forward) + +;;; Evaluation Commands +(define-key 'continuation-browser '(#\C-x #\C-e) + 'continuation-browser-eval-last-sexp) +(define-key 'continuation-browser '(#\C-x #\C-r) + 'continuation-browser-eval-last-sexp/dynamic) +(define-key 'continuation-browser #\M-z + 'continuation-browser-eval-defun) +(define-key 'continuation-browser '(#\M-C-z) + 'continuation-browser-eval-region) + +;;; Motion Commands +(define-key 'continuation-browser '(#\C-c #\C-f) + 'continuation-browser-forward-reduction) +(define-key 'continuation-browser '(#\C-c #\C-n) + 'continuation-browser-forward-subproblem) +(define-key 'continuation-browser '(#\C-c #\C-b) + 'continuation-browser-backward-reduction) +(define-key 'continuation-browser '(#\C-c #\C-p) + 'continuation-browser-backward-subproblem) +(define-key 'continuation-browser '(#\C-c #\C-w) + 'continuation-browser-go-to) + +;;; Information-display Commands +(define-key 'continuation-browser '(#\C-c #\C-a) + 'continuation-browser-show-all-frames) +(define-key 'continuation-browser '(#\C-c #\C-c) + 'continuation-browser-show-current-frame) +(define-key 'continuation-browser '(#\C-c #\C-e) + 'continuation-browser-print-environment) +(define-key 'continuation-browser '(#\C-c #\C-l) + 'continuation-browser-print-expression) +(define-key 'continuation-browser '(#\C-c #\C-o) + 'continuation-browser-print-environment-procedure) +(define-key 'continuation-browser '(#\C-c #\C-m) + 'continuation-browser-expand-reductions) +(define-key 'continuation-browser '(#\C-c #\C-t) + 'continuation-browser-print-subproblem-or-reduction) +(define-key 'continuation-browser '(#\C-c #\C-x) + 'continuation-browser-expand-subproblems) +(define-key 'continuation-browser '(#\C-c #\C-y) + 'continuation-browser-frame) + +;;; Miscellaneous Commands +(define-key 'continuation-browser '(#\C-c #\C-k) + 'continuation-browser-condition-restart) +(define-key 'continuation-browser '(#\C-c #\C-j) + 'continuation-browser-return-to) +(define-key 'continuation-browser '(#\C-c #\C-z) + 'continuation-browser-return-from) +(define-key 'continuation-browser '(#\C-c #\C-d) + 'continuation-browser-retry) +(define-key 'continuation-browser '(#\C-c #\C-g) + 'continuation-browser-abort-all) +(define-key 'continuation-browser '(#\C-c #\C-u) + 'continuation-browser-abort-previous) +(define-key 'continuation-browser '(#\C-c #\C-M-y) + 'continuation-browser-display-stack-elements) + +(define (debugger-command-invocation command) + (lambda () + (invoke-debugger-command (current-point) command))) + +;;;; Evaluation Commands + +(define-command continuation-browser-eval-region + "Evaluate the region." + "r" + (lambda (region) + (let ((environment + (dstate-evaluation-environment (start-evaluation region)))) + (fluid-let ((in-debugger-evaluation? #t)) + (evaluate-region region environment))))) + +(define (start-evaluation region) + (if (region-contains-marker? region) + (editor-error "Can't evaluate region containing markers.")) + (set-current-point! (region-end region)) + (debug-dstate (region-start region))) + +(define-command continuation-browser-eval-defun + "Evaluate definition that point is in or before." + () + (lambda () + ((ref-command continuation-browser-eval-region) + (let ((input-mark (current-definition-start))) + (make-region input-mark (forward-sexp input-mark 1 'ERROR)))))) + +(define-command continuation-browser-eval-last-sexp + "Evaluate the expression preceding point." + () + (lambda () + ((ref-command continuation-browser-eval-region) + (let ((input-mark (backward-sexp (current-point) 1 'ERROR))) + (make-region input-mark (forward-sexp input-mark 1 'ERROR)))))) + +(define-command continuation-browser-eval-region/dynamic + "Evaluate the region. +The evaluation occurs in the dynamic state of the current frame." + "r" + (lambda (region) + (let ((dstate (start-evaluation region))) + (let ((environment (dstate-evaluation-environment dstate)) + (continuation + (stack-frame->continuation (dstate/subproblem dstate))) + (old-hook hook/repl-eval)) + (fluid-let + ((in-debugger-evaluation? #t) + (hook/repl-eval + (lambda (expression environment repl) + (let ((unique (cons 'unique 'id))) + (let ((result + (call-with-current-continuation + (lambda (continuation*) + (within-continuation continuation + (lambda () + (bind-condition-handler + '() + (lambda (condition) + (continuation* (cons unique condition))) + (lambda () + (continuation* + (old-hook expression + environment + repl)))))))))) + (if (and (pair? result) + (eq? unique (car result))) + (error (cdr result)) + result)))))) + (evaluate-region region environment)))))) + +(define-command continuation-browser-eval-last-sexp/dynamic + "Evaluate the expression preceding point. +The evaluation occurs in the dynamic state of the current frame." + () + (lambda () + ((ref-command continuation-browser-eval-region/dynamic) + (let ((input-mark (backward-sexp (current-point) 1 'ERROR))) + (make-region input-mark (forward-sexp input-mark 1 'ERROR)))))) + +;;;; Motion Commands + +;;; The subproblem and reduction motion commands rely, in many +;;; places, on the assumption that subproblem and reduction numbers +;;; increase downward in the buffer, and that no subproblem/reduction +;;; marker line is repeated. Of course, the user can violate this +;;; assumption by constructing or copying a marker, but the program +;;; is robust with respect to such conniving, as long as the +;;; reduction and subproblem specified by the numbers in the marker +;;; exist. The only time it should be possible to notice an effect +;;; of this assumption is when a reduction or subproblem that is +;;; already displayed is automatically redisplayed because the +;;; existing one appeared out of order. + +(define-command continuation-browser-forward-subproblem + "Move one or more subproblems forward." + "p" + (lambda (argument) (move-thing forward-subproblem argument 'ERROR))) + +(define-command continuation-browser-backward-subproblem + "Move one or more subproblems backward." + "p" + (lambda (argument) (move-thing backward-subproblem argument 'ERROR))) + +(define-command continuation-browser-forward-reduction + "Move one or more reductions forward. +Display reductions that exist but are not yet displayed. +If there are no more reductions for the current subproblem, +move to the first reduction shown in the next subproblem." + "p" + (lambda (argument) (move-thing forward-reduction argument 'ERROR))) + +(define-command continuation-browser-backward-reduction + "Move one or more reductions backward. +Display reductions that exist but are not yet displayed. +If there are no more reductions for the current subproblem, +move to the last reduction shown in the previous subproblem." + "p" + (lambda (argument) (move-thing backward-reduction argument 'ERROR))) + +(define-command continuation-browser-go-to + "Move to an arbitrary subproblem. +Prompt for the subproblem number if not given as an argument. +Move to the last subproblem if the subproblem number is too high." + "NSubproblem number" + (lambda (destination-subproblem-number) + (set-current-point! + (let ((end (group-end (current-point))) + (not-found + (lambda () + (editor-error "Cannot find subproblem" + destination-subproblem-number)))) + (let ((last-subproblem-number (current-subproblem-number end))) + (if (not last-subproblem-number) + (not-found)) + (cond ((< destination-subproblem-number last-subproblem-number) + (let loop ((point (backward-subproblem end 1))) + (if (not point) + (not-found)) + (let ((subproblem (current-subproblem-number point))) + (if (not subproblem) + (not-found)) + (if (= subproblem destination-subproblem-number) + point + (loop (backward-subproblem point 1)))))) + ((> destination-subproblem-number last-subproblem-number) + (forward-subproblem + end + (- destination-subproblem-number last-subproblem-number) + 'LIMIT)) + (else end))))))) + +;;;; Information-display Commands + +(define-command continuation-browser-show-all-frames + "Print the bindings of all frames of the current environment." + () + (debugger-command-invocation command/show-all-frames)) + +(define-command continuation-browser-show-current-frame + "Print the bindings of the current frame of the current environment." + () + (debugger-command-invocation command/show-current-frame)) + +(define-command continuation-browser-print-environment + "Identify the environment of the current frame." + () + (debugger-command-invocation + (lambda (dstate port) + (debugger-presentation port + (lambda () + (print-subproblem-environment dstate port)))))) + + +(define-command continuation-browser-print-expression + "Pretty print the current expression." + "P" + (lambda (argument) + (let ((point (current-point))) + (call-with-interface-port + point + (lambda (port) + (push-current-mark! point) + (let ((dstate (debug-dstate point)) + (message + (lambda (string) + (fresh-line port) + (write-string "; " port) + (write-string string port))) + (pp (lambda (obj) + (fresh-line port) + (pp obj port #t)))) + + (if (dstate/reduction-number dstate) + (pp (reduction-expression (dstate/reduction dstate))) + (let ((exp (dstate/expression dstate)) + (sub (dstate/subexpression dstate))) + (define (do-hairy) + (pp (unsyntax-with-substitutions + exp + (list + (cons sub + (make-pretty-printer-highlight + (unsyntax sub) + (ref-variable subexpression-start-marker) + (ref-variable subexpression-end-marker))))))) + + (cond ((not (invalid-expression? exp)) + (if (or argument + (invalid-subexpression? sub)) + (pp exp) + (parameterize ((param:pp-no-highlights? #f)) + (do-hairy)))) + ((debugging-info/noise? exp) + (message ((debugging-info/noise exp) #t))) + (else + (message "Unknown expression"))))))))))) + +(define-command continuation-browser-print-environment-procedure + "Pretty print the procedure that created the current environment." + () + (debugger-command-invocation command/print-environment-procedure)) + +(define-command continuation-browser-expand-reductions + "Expand all the reductions of the current subproblem. +If already expanded, move the point to one of the reductions." + () + (lambda () + (let ((point (current-point))) + (if (reductions-expanded? point) + (temporary-message + "Reductions for this subproblem already expanded.") + (expand-reductions point))))) + +(define (command/print-subproblem-or-reduction dstate port) + (debugger-presentation port + (lambda () + (if (dstate/reduction-number dstate) + (print-reduction-expression (dstate/reduction dstate) port) + (print-subproblem-expression dstate port))))) + +(define-command continuation-browser-print-subproblem-or-reduction + "Print the current subproblem or reduction in the standard format." + () + (debugger-command-invocation command/print-subproblem-or-reduction)) + +(define-command continuation-browser-expand-subproblems + "Expand all subproblems, or ARG more subproblems if argument is given." + "P" + (lambda (argument) + (let ((subproblem-number + (if argument + (+ (or (current-subproblem-number (group-end (current-point))) + (editor-error "Can't find subproblem marker")) + (command-argument-numeric-value argument)) + (- (count-subproblems (current-buffer)) 1)))) + (let ((point (mark-right-inserting-copy (current-point)))) + ((ref-command continuation-browser-go-to) subproblem-number) + (mark-temporary! point) + (set-current-point! point))))) + +(define-command continuation-browser-frame + "Show the current subproblem's stack frame in internal format." + () + (debugger-command-invocation command/frame)) + +;;;; Miscellaneous Commands + +(define-command continuation-browser-condition-restart + "Continue the program using a standard restart option. +Prefix argument means do not kill the debugger buffer." + "P" + (lambda (avoid-deletion?) + (fluid-let ((hook/invoke-restart + (lambda (continuation arguments) + (invoke-continuation continuation + arguments + avoid-deletion?)))) + (invoke-debugger-command (current-point) command/condition-restart)))) + +(define-command continuation-browser-return-to + "Return TO the current subproblem with a value. +Invoke the continuation corresponding to this subproblem on the value +of the expression before the point. +Prefix argument means do not kill the debugger buffer." + "P" + (lambda (avoid-deletion?) + (let ((subproblem (dstate/subproblem (debug-dstate (current-point))))) + (subproblem-enter subproblem + ((ref-command continuation-browser-eval-last-sexp)) + avoid-deletion?)))) + +(define-command continuation-browser-return-from + "Return FROM the current subproblem with a value. +Invoke the continuation that is waiting for the value of the current +subproblem on the value of the expression before the point. +Prefix argument means do not kill the debugger buffer." + "P" + (lambda (avoid-deletion?) + (let ((next (guarantee-next-subproblem (debug-dstate (current-point))))) + (subproblem-enter next + ((ref-command continuation-browser-eval-last-sexp)) + avoid-deletion?)))) + +(define-command continuation-browser-retry + "Retry the expression of the current subproblem. +Prefix argument means do not kill the debugger buffer." + "P" + (lambda (avoid-deletion?) + (let* ((dstate (debug-dstate (current-point))) + (next (guarantee-next-subproblem dstate))) + (subproblem-enter + next + (let ((expression (dstate/expression dstate))) + (if (invalid-expression? expression) + (editor-error "Can't retry; invalid expression" expression)) + (extended-scode-eval expression + (dstate-evaluation-environment dstate))) + avoid-deletion?)))) + +(define-command continuation-browser-abort-all + "Insert restarts" + () + (lambda () + (continuation-browser-abort (reverse (current-restarts))))) + +(define-command continuation-browser-abort-previous + "Insert restarts" + () + (lambda () + (continuation-browser-abort (current-restarts)))) + + +(define-command continuation-browser-display-stack-elements + "Show the elements on the current stack frame" + "P" + (lambda (argument) + (let* ((point (current-point)) + (dstate (debug-dstate point)) + (sub (dstate/subproblem dstate))) + (if (and (dstate/reduction-number dstate) + (not argument)) + (editor-error "Reductions have no stack frames") + (call-with-interface-port + point + (lambda (port) + (push-current-mark! point) + (fresh-line port) + (let* ((vec (stack-frame/elements sub)) + (depth (-1+ (vector-length vec))) + (mlen (string-length (number->string depth))) + (pad-len (max 5 mlen)) + (padded + (lambda (s) + (string-pad-left s pad-len #\Space))) + (blanks (make-string pad-len #\Space))) + + (write-string ";; " port) + (write-string (padded "Depth") port) + (write-string " Bottom of stack frame" port) + (newline port) + (write-string ";;" port) + (let ((pad (if (= pad-len mlen) + padded + (let* ((right (quotient (- pad-len mlen) 2)) + (rest (- pad-len right)) + (blanks (make-string right #\Space))) + (lambda (s) + (string-append + (string-pad-left s rest #\Space) + blanks)))))) + + (do ((elements (reverse! (vector->list vec)) + (cdr elements)) + (depth depth (-1+ depth))) + ((null? elements)) + (newline port) + (write-string ";; " port) + (write-string (pad (number->string depth)) port) + (write-string " " port) + (write (car elements) port))) + (newline port) + (write-string ";;" port) + (newline port) + (write-string ";; " port) + (write-string blanks port) + (write-string " Top of stack frame" port)) + (newline port) + (newline port))))))) + +(define (subproblem-enter subproblem value avoid-deletion?) + (if (or (not (ref-variable debugger-confirm-return?)) + (prompt-for-confirmation? "Continue with this value")) + (invoke-continuation (stack-frame->continuation subproblem) + (list value) + avoid-deletion?))) + +(define (invoke-continuation continuation arguments avoid-deletion?) + (let ((buffer (current-buffer))) + (if (and (not avoid-deletion?) + (ref-variable debugger-quit-on-return?)) + (kill-buffer-interactive buffer)) + ((or (buffer-get buffer 'INVOKE-CONTINUATION) apply) + continuation arguments))) + +(define (guarantee-next-subproblem dstate) + (or (stack-frame/next-subproblem (dstate/subproblem dstate)) + (editor-error "Can't continue; no earlier subproblem"))) + +(define (current-restarts) + (let* ((dstate (debug-dstate (current-point))) + (condition (dstate/condition dstate))) + (if condition + (condition/restarts condition) + (bound-restarts)))) + +(define (continuation-browser-abort restarts) + (let ((restart + (find (lambda (restart) + (eq? (restart/name restart) 'abort)) + restarts))) + (if (not restart) + (editor-error "Can't find an abort restart") + (fluid-let ((hook/invoke-restart + (lambda (continuation arguments) + (invoke-continuation continuation + arguments + #f)))) + (invoke-restart restart))))) + +;;;; Marker Generation + +(define (expand-subproblem mark) + (let ((buffer (mark-buffer mark)) + (number (current-subproblem-number mark))) + (if (not number) + (editor-error "No subproblem or reduction marks")) + (let ((number (+ number 1)) + (count (count-subproblems buffer))) + (if (>= number count) + (editor-error "No more subproblems or reductions")) + (remove-more-subproblems-message buffer) + (let ((port (mark->output-port mark))) + (newline port) + (print-subproblem number (nth-subproblem buffer number) port)) + (if (< number (- count 1)) + (display-more-subproblems-message buffer))))) + +(define (display-more-subproblems-message buffer) + (define-variable-local-value! buffer (ref-variable-object mode-line-process) + '(RUN-LIGHT (": more-subproblems " RUN-LIGHT) ": more-subproblems")) + (buffer-modeline-event! buffer 'PROCESS-STATUS)) + +(define (remove-more-subproblems-message buffer) + (let ((variable (ref-variable-object mode-line-process))) + (define-variable-local-value! buffer variable + (variable-default-value variable))) + (buffer-modeline-event! buffer 'PROCESS-STATUS)) + +(define (perhaps-expand-reductions mark) + (if (and (ref-variable debugger-expand-reductions?) + (not (reductions-expanded? mark))) + (begin + (message "Expanding reductions...") + (expand-reductions (end-of-subproblem mark)) + (temporary-message "Expanding reductions...done")))) + +(define (expand-reductions mark) + (let ((port (mark->output-port mark)) + (subproblem-number (current-subproblem-number mark))) + (do ((reductions (stack-frame/reductions + (dstate/subproblem (debug-dstate mark))) + (cdr reductions)) + (reduction-number 0 (+ reduction-number 1))) + ((not (pair? reductions))) + (newline port) + (print-reduction subproblem-number + reduction-number + (car reductions) + port)))) + +(define (reductions-expanded? mark) + ;; Return true whenever expansion is impossible at MARK, even if + ;; because MARK is outside any subproblem or because there are no + ;; reductions for the subproblem. If only some of the reductions + ;; appear already (e.g. if the others have been deleted by the + ;; user), still return true. + (let ((subproblem-above (find-previous-subproblem-marker mark))) + (or (not subproblem-above) + (let ((subproblem-number-above (re-match-extract-subproblem)) + (reduction-count (re-match-extract-reduction-count))) + (and reduction-count + (let ((reduction-below + (find-next-marker + (line-end subproblem-above 0)))) + (and reduction-below + (= (re-match-extract-subproblem) + subproblem-number-above)))))))) + + +(define-structure (unparser-literal + (conc-name unparser-literal/) + (print-procedure + (lambda (instance port) + (write-string (unparser-literal/string instance) + port))) + (constructor unparser-literal/make)) + string) + +(define-variable subexpression-start-marker + "Subexpressions are preceeded by this value." + "#" + string?) + +(define-variable subexpression-end-marker + "Subexpressions are followed by this value." + "#" + string?) + +(define (print-subproblem number frame port) + (call-with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (print-history-level + (stack-frame/compiled-code? frame) + number + (let ((reductions + (improper-list-length (stack-frame/reductions frame)))) + (if (zero? reductions) + " -------- " + (string-append " #R=" (number->string reductions) " --- "))) + (lambda () + (cond ((debugging-info/compiled-code? expression) + (write-string ";compiled code")) + ((not (debugging-info/undefined-expression? expression)) + (print-with-subexpression expression subexpression)) + ((debugging-info/noise? expression) + (write-string ((debugging-info/noise expression) #f))) + (else + (write-string ";undefined expression")))) + environment + port)))) + +(define (print-with-subexpression expression subexpression) + (parameterize ((param:print-primitives-by-name? #t)) + (if (invalid-subexpression? subexpression) + (write (unsyntax expression)) + (let ((sub (write-to-string (unsyntax subexpression)))) + (write (unsyntax-with-substitutions + expression + (list + (cons subexpression + (unparser-literal/make + (string-append + (ref-variable subexpression-start-marker) + sub + (ref-variable subexpression-end-marker))))))))))) + +(define (invalid-subexpression? subexpression) + (or (debugging-info/undefined-expression? subexpression) + (debugging-info/unknown-expression? subexpression))) + +(define (print-reduction subproblem-number reduction-number reduction port) + (print-history-level + #f + subproblem-number + (string-append ", R=" (number->string reduction-number) " --- ") + (lambda () + (print-reduction-as-subexpression (reduction-expression reduction))) + (reduction-environment reduction) + port)) + +(define (print-reduction-as-subexpression expression) + (parameterize ((param:print-primitives-by-name? #t)) + (write-string (ref-variable subexpression-start-marker)) + (write (unsyntax expression)) + (write-string (ref-variable subexpression-end-marker)))) + +(define (print-history-level compiled? subproblem-number reduction-id + expression-thunk environment port) + (fresh-line port) + (let ((level-identification + (string-append (if compiled? "-C- S=" "-I- S=") + (number->string subproblem-number) + reduction-id))) + (write-string level-identification port) + (let ((pad-width (max 0 (- 78 (string-length level-identification))))) + (write-string + (string-pad-right + (string-append + (cdr + (call-with-truncated-output-string pad-width + (lambda (port) + (parameterize ((current-output-port port)) + (expression-thunk))))) + " ") + pad-width + #\-) + port))) + (if (ref-variable debugger-verbose-mode?) + (begin + (newline port) + (if (environment? environment) + (show-environment-name environment port) + (write-string "There is no environment stored for this frame." + port)))) + (if (ref-variable debugger-open-markers?) + (newline port))) + +;;;; Marker Location + +(define forward-subproblem) +(define backward-subproblem) +(make-motion-pair (lambda (start) + (forward-one-level start find-next-subproblem-marker)) + (lambda (start) + (backward-one-level start find-previous-subproblem-marker)) + (lambda (f b) + (set! forward-subproblem f) + (set! backward-subproblem b) + unspecific)) + +(define forward-reduction) +(define backward-reduction) +(make-motion-pair (lambda (start) + (let ((mark (mark-right-inserting-copy start))) + (perhaps-expand-reductions mark) + (let ((result (forward-one-level mark find-next-marker))) + (mark-temporary! mark) + result))) + (lambda (start) + (let ((mark (mark-left-inserting-copy start))) + (if (below-subproblem-marker? mark) + (perhaps-expand-reductions + (backward-subproblem mark 1))) + (let ((result + (backward-one-level mark find-previous-marker))) + (mark-temporary! mark) + result))) + (lambda (f b) + (set! forward-reduction f) + (set! backward-reduction b) + unspecific)) + +(define (forward-one-level start finder) + (let ((next-level (finder start))) + (if next-level + (let ((second-next-level + (find-next-marker + (line-end next-level 0)))) + (if second-next-level + (line-end second-next-level -1) + (group-end next-level))) + (begin + (message "Expanding subproblem...") + (expand-subproblem (group-end start)) + (temporary-message "Expanding subproblem...done") + (group-end start))))) + +(define (backward-one-level start finder) + (let ((level-top (finder start))) + (if (or (not level-top) (not (finder level-top))) + (editor-error "Can't move beyond top level")) + (line-end level-top -1))) + +(define (end-of-subproblem mark) + (let ((subproblem-below (find-next-subproblem-marker mark))) + (if subproblem-below + (line-end subproblem-below -1) + (group-end mark)))) + +(define (below-subproblem-marker? mark) + (let ((mark (find-previous-marker mark))) + (and mark + (re-match-forward subproblem-regexp mark)))) + +(define (region-contains-marker? region) + (re-search-forward marker-regexp + (line-start (region-start region) 0) + (line-end (region-end region) 0))) + +(define (current-subproblem-number mark) + (and (find-previous-marker mark) + (re-match-extract-subproblem))) + +(define (current-reduction-number mark) + (and (not (below-subproblem-marker? mark)) + (find-previous-reduction-marker mark) + (re-match-extract-reduction))) + +(define (find-next-subproblem-marker mark) + (and (re-search-forward subproblem-regexp mark (group-end mark)) + (re-match-start 0))) + +(define (find-next-reduction-marker mark) + (and (re-search-forward reduction-regexp mark (group-end mark)) + (re-match-start 0))) + +(define (find-next-marker mark) + (and (re-search-forward marker-regexp mark (group-end mark)) + (re-match-start 0))) + +(define (find-previous-subproblem-marker mark) + (re-search-backward subproblem-regexp mark (group-start mark))) + +(define (find-previous-reduction-marker mark) + (re-search-backward reduction-regexp mark (group-start mark))) + +(define (find-previous-marker mark) + (re-search-backward marker-regexp mark (group-start mark))) + +(define (re-match-extract-subproblem) + (or (re-match-extract-number 1) + (editor-error "Ill-formed subproblem marker"))) + +(define (re-match-extract-reduction) + (or (re-match-extract-number 2) + (editor-error "Ill-formed reduction marker"))) + +(define (re-match-extract-reduction-count) + (re-match-extract-number 3)) + +(define (re-match-extract-number register-number) + (let ((start (re-match-start register-number)) + (end (re-match-end register-number))) + (and start + end + (string->number (extract-string end start))))) + +;;; Regular expressions for finding subproblem and reduction marker +;;; lines. After a match on REDUCTION-REGEXP, register 1 must match +;;; the subproblem number and register 2 must match the reduction +;;; number. After a match on SUBPROBLEM-REGEXP, register 1 must +;;; match the subproblem number and register 3 must match the maximum +;;; reduction number in that subproblem. + +(define subproblem-regexp + "^-[CI]- S=\\([0-9]+\\) \\(#R=\\([0-9]+\\)\\|\\)") + +(define reduction-regexp + "^-I- S=\\([0-9]+\\), R=\\([0-9]+\\)") + +(define marker-regexp + "^-[CI]- S=\\([0-9]+\\)\\(, R=[0-9]+\\| #R=[0-9]+\\|\\)") + +;;;; Debugger State + +;;; UGLY BECAUSE IT MUTATES THE DSTATE. + +(define (debug-dstate mark) + (let ((dstate (buffer-dstate (mark-buffer mark)))) + (let ((subproblem-number (current-subproblem-number mark)) + (reduction-number (current-reduction-number mark))) + (if subproblem-number + (begin (change-subproblem! dstate subproblem-number) + (if (and reduction-number + (positive? (dstate/number-of-reductions dstate))) + (change-reduction! dstate reduction-number) + (set-dstate/reduction-number! dstate #f)) + dstate) + (editor-error "Cannot find environment for evaluation."))))) + +(define (change-subproblem! dstate subproblem-number) + (let ((finish-move-to-subproblem! + (lambda (dstate) + (if (and (dstate/using-history? dstate) + (positive? (dstate/number-of-reductions dstate))) + (change-reduction! dstate 0) + (set-dstate/reduction-number! dstate #f)))) + (delta (- subproblem-number (dstate/subproblem-number dstate)))) + (if (negative? delta) + (let ((subproblems + (drop (dstate/previous-subproblems dstate) + (-1+ (- delta))))) + (set-current-subproblem! dstate (car subproblems) (cdr subproblems)) + (finish-move-to-subproblem! dstate)) + (let loop + ((subproblem (dstate/subproblem dstate)) + (subproblems (dstate/previous-subproblems dstate)) + (delta delta)) + (if (zero? delta) + (begin + (set-current-subproblem! dstate subproblem subproblems) + (finish-move-to-subproblem! dstate)) + (loop (stack-frame/next-subproblem subproblem) + (cons subproblem subproblems) + (-1+ delta))))))) + +(define (change-reduction! dstate reduction-number) + (set-dstate/reduction-number! dstate reduction-number) + (set-dstate/environment-list! + dstate + (list (reduction-environment (dstate/reduction dstate))))) + +(define (count-subproblems buffer) + (do ((i 0 (1+ i)) + (subproblem (dstate/subproblem (buffer-dstate buffer)) + (stack-frame/next-subproblem subproblem))) + ((not subproblem) i))) + +(define (nth-subproblem buffer n) + (let ((dstate (buffer-dstate buffer))) + (do ((frame + (let ((previous-subproblems (dstate/previous-subproblems dstate))) + (if (null? previous-subproblems) + (dstate/subproblem dstate) + (car (last-pair previous-subproblems)))) + (or (stack-frame/next-subproblem frame) + (editor-error "No such subproblem" n))) + (level 0 (+ level 1))) + ((= level n) frame)))) + +(define (dstate-evaluation-environment dstate) + (let ((environment-list (dstate/environment-list dstate))) + (if (and (pair? environment-list) + (environment? (car environment-list))) + (car environment-list) + (evaluation-environment-no-repl)))) + +;;;; Interface Port + +(define (invoke-debugger-command mark command) + (call-with-interface-port mark + (lambda (port) + (command (debug-dstate mark) port)))) + +(define (call-with-interface-port mark receiver) + (let ((mark (mark-left-inserting-copy mark))) + (let ((value (receiver (make-port interface-port-type mark)))) + (mark-temporary! mark) + value))) + +(define (operation/write-char port char) + (guarantee 8-bit-char? char) + (region-insert-char! (port/state port) char)) + +(define (operation/write-substring port string start end) + (if (string? string) + (region-insert-substring! (port/state port) string start end) + (generic-port-operation:write-substring port string start end))) + +(define (operation/x-size port) + (let ((buffer (mark-buffer (port/state port)))) + (and buffer + (let ((windows (buffer-windows buffer))) + (and (not (null? windows)) + (apply min (map window-x-size windows))))))) + +(define (operation/debugger-failure port string) + port + (message string) + (editor-beep)) + +(define (operation/debugger-message port string) + port + (message string)) + +(define (debugger-presentation port thunk) + (fresh-line port) + (fluid-let ((debugger-pp + (lambda (expression indentation port) + (pretty-print expression port #t indentation)))) + (thunk)) + (newline port) + (newline port)) + +(define (operation/prompt-for-expression port prompt) + port + (prompt-for-expression prompt)) + +(define (operation/prompt-for-confirmation port prompt) + port + (prompt-for-confirmation? prompt)) + +(define interface-port-type + (make-port-type + `((WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring) + (X-SIZE ,operation/x-size) + (DEBUGGER-FAILURE ,operation/debugger-failure) + (DEBUGGER-MESSAGE ,operation/debugger-message) + (DEBUGGER-PRESENTATION ,debugger-presentation) + (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression) + (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)) + #f)) \ No newline at end of file diff --git a/edwin/autold.scm b/edwin/autold.scm new file mode 100644 index 0000000..db58545 --- /dev/null +++ b/edwin/autold.scm @@ -0,0 +1,239 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Autoloads for Edwin + +(declare (usual-integrations)) + +;;;; Definitions + +(define (make-autoloading-procedure library-name get-procedure) + (letrec ((apply-hook + (make-apply-hook + (lambda arguments + ((ref-command load-library) library-name 'NO-WARN) + (let ((procedure (get-procedure))) + (set-apply-hook-procedure! apply-hook procedure) + (apply procedure arguments))) + (cons autoloading-procedure-tag library-name)))) + apply-hook)) + +(define autoloading-procedure-tag "autoloading-procedure-tag") + +(define (autoloading-procedure? object) + (and (apply-hook? object) + (eq? autoloading-procedure-tag (car (apply-hook-extra object))))) + +(define-integrable (autoloading-procedure/library-name procedure) + (cdr (apply-hook-extra procedure))) + +(define (define-autoload-procedure name package library-name) + (let ((environment (->environment package))) + (environment-define environment + name + (make-autoloading-procedure + library-name + (lambda () (environment-lookup environment name)))))) + +(define (define-autoload-major-mode name super-mode-name display-name + library-name description) + (define mode + (make-mode name #t display-name + (and super-mode-name (->mode super-mode-name)) + description + (make-autoloading-procedure library-name + (lambda () + (mode-initialization mode))))) + (environment-define (->environment '(EDWIN)) + (mode-name->scheme-name name) + mode) + name) + +(define (define-autoload-minor-mode name display-name library-name description) + (define mode + (make-mode name #f display-name #f description + (make-autoloading-procedure library-name + (lambda () + (mode-initialization mode))))) + (environment-define (->environment '(EDWIN)) + (mode-name->scheme-name name) + mode) + name) + +(define (autoloading-mode? mode) + (autoloading-procedure? (mode-initialization mode))) + +(define (define-autoload-command name library-name description) + (define command + (make-command name description '() + (make-autoloading-procedure library-name + (lambda () + (command-procedure command))))) + (environment-define (->environment '(EDWIN)) + (command-name->scheme-name name) + command) + name) + +(define (autoloading-command? command) + (autoloading-procedure? (command-procedure command))) + +(define (guarantee-command-loaded command) + (let ((procedure (command-procedure command))) + (if (autoloading-procedure? procedure) + ((ref-command load-library) + (autoloading-procedure/library-name procedure) + 'NO-WARN)))) + +;;;; Libraries + +(define known-libraries + '()) + +(define (define-library name . entries) + (let ((entry (assq name known-libraries))) + (if entry + (set-cdr! entry entries) + (set! known-libraries + (cons (cons name entries) + known-libraries)))) + name) + +(define loaded-libraries + '()) + +(define (library-loaded? name) + (memq name loaded-libraries)) + +(define library-load-hooks + '()) + +(define (add-library-load-hook! name hook) + (if (library-loaded? name) + (hook) + (let ((entry (assq name library-load-hooks))) + (if entry + (append! entry (list hook)) + (set! library-load-hooks + (cons (list name hook) + library-load-hooks)))))) + +(define (run-library-load-hooks! name) + (let ((entry (assq name library-load-hooks))) + (define (loop) + (if (null? (cdr entry)) + (set! library-load-hooks (delq! entry library-load-hooks)) + (let ((hook (cadr entry))) + (set-cdr! entry (cddr entry)) + (hook) + (loop)))) + (if entry (loop)))) + +(define (load-library library) + (for-each (lambda (entry) + (let ((file (car entry)) + (environment (->environment (cadr entry))) + (purify? (if (pair? (cddr entry)) (caddr entry) #t))) + (cond ((built-in-object-file + (merge-pathnames file (pathname-as-directory "edwin"))) + => (lambda (obj) + (if purify? (purify obj)) + (scode-eval obj environment))) + (else + (load (merge-pathnames file (edwin-binary-directory)) + environment + 'DEFAULT + purify?))))) + (cdr library)) + (if (not (memq (car library) loaded-libraries)) + (set! loaded-libraries + (cons (car library) loaded-libraries))) + (run-library-load-hooks! (car library))) + +;;;; Loading + +(define-command load-library + "Load the Edwin library NAME. +Second arg FORCE? controls what happens if the library is already loaded: + 'NO-WARN means do nothing, + #f means display a warning message in the minibuffer, + anything else means load it anyway. +Second arg is prefix arg when called interactively." + (lambda () + (list + (prompt-for-alist-value "Load library" + (map (lambda (library) + (cons (symbol->string (car library)) + (car library))) + known-libraries)) + (command-argument))) + (lambda (name force?) + (load-edwin-library name force? #t))) + +(define (load-edwin-library name #!optional force? interactive?) + (let ((force? (if (default-object? force?) #f force?)) + (interactive? (if (default-object? interactive?) #f interactive?))) + (let ((do-it + (lambda () + (let ((library (assq name known-libraries))) + (if (not library) + (error "Unknown library name:" name)) + (if interactive? + (with-output-to-transcript-buffer + (lambda () + (bind-condition-handler (list condition-type:error) + evaluation-error-handler + (lambda () + (parameterize + ((param:suppress-loading-message? #t)) + ((message-wrapper #f "Loading " (car library)) + (lambda () + (load-library library)))))))) + (load-library library)))))) + (cond ((not (library-loaded? name)) + (do-it)) + ((not force?) + (if interactive? (message "Library already loaded: " name))) + ((not (eq? force? 'NO-WARN)) + (do-it)))))) + +(define-command load-file + "Load the Edwin binary file FILENAME. +Second arg PURIFY? means purify the file's contents after loading; + this is the prefix arg when called interactively." + "fLoad file\nP" + (lambda (filename purify?) + ((message-wrapper #f "Loading " filename) + (lambda () + (load-edwin-file filename '(EDWIN) purify?))))) + +(define (load-edwin-file filename environment purify?) + (with-output-to-transcript-buffer + (lambda () + (bind-condition-handler (list condition-type:error) + evaluation-error-handler + (lambda () + (parameterize ((param:suppress-loading-message? #t)) + (load filename environment 'DEFAULT purify?))))))) \ No newline at end of file diff --git a/edwin/autosv.scm b/edwin/autosv.scm new file mode 100644 index 0000000..a641ab3 --- /dev/null +++ b/edwin/autosv.scm @@ -0,0 +1,180 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Auto Save + +(declare (usual-integrations)) + +(define-variable auto-save-visited-file-name + "True says auto-save a buffer in the file it is visiting, when practical. +Normally auto-save files are written under other names." + false + boolean?) + +(define-variable auto-save-default + "True says by default do auto-saving of every file-visiting buffer." + true + boolean?) +(variable-permanent-local! (ref-variable-object auto-save-default)) + +(define-variable auto-save-interval + "Number of keyboard input characters between auto-saves. +Zero means disable autosaving." + 300 + exact-nonnegative-integer?) + +(define-variable delete-auto-save-files + "True means delete a buffer's auto-save file +when the buffer is saved for real." + true + boolean?) + +(define-command auto-save-mode + "Toggle auto-saving of contents of current buffer. +With arg, turn auto-saving on if arg is positive, else off." + "P" + (lambda (argument) + (let ((argument (command-argument-value argument)) + (buffer (current-buffer))) + (if (if argument + (positive? argument) + (not (buffer-auto-save-pathname buffer))) + (begin + (enable-buffer-auto-save! buffer) + (message "Auto Save enabled")) + (begin + (disable-buffer-auto-save! buffer) + (message "Auto Save disabled")))))) + +(define-command do-auto-save + "Auto-save all buffers that need it. +This is all buffers that have auto-saving enabled +and are changed since last auto-saved. +Auto-saving writes the buffer into a file +so that your editing is not lost if the system crashes. +This file is not the file you visited; that changes only when you save." + () + (lambda () (do-auto-save))) + +(define (setup-buffer-auto-save! buffer) + (if (ref-variable auto-save-default buffer) + (enable-buffer-auto-save! buffer) + (disable-buffer-auto-save! buffer))) + +(define (enable-buffer-auto-save! buffer) + (let ((pathname + (let ((pathname (buffer-pathname buffer))) + (if (and pathname (ref-variable auto-save-visited-file-name)) + pathname + (os/auto-save-pathname pathname buffer))))) + (without-interrupts + (lambda () + (set-buffer-auto-save-pathname! buffer pathname) + (add-group-microcode-entry (buffer-group buffer) + (->namestring pathname)) + (add-kill-buffer-hook buffer auto-save-kill-buffer-hook))))) + +(define (disable-buffer-auto-save! buffer) + (without-interrupts + (lambda () + (set-buffer-auto-save-pathname! buffer false) + (remove-group-microcode-entry (buffer-group buffer)) + (remove-kill-buffer-hook buffer auto-save-kill-buffer-hook)))) + +(define (auto-save-kill-buffer-hook buffer) + (without-interrupts + (lambda () + (remove-group-microcode-entry (buffer-group buffer))))) + +(define (add-group-microcode-entry group namestring) + (let ((entry (assq group (fixed-objects-item 'edwin-auto-save)))) + (if entry + (set-cdr! entry namestring) + (update-fixed-objects-item! 'edwin-auto-save + (lambda (alist) + (cons (cons group namestring) alist)))))) + +(define (remove-group-microcode-entry group) + (update-fixed-objects-item! 'edwin-auto-save + (lambda (alist) + (del-assq! group alist)))) + +(define (delete-auto-save-file! buffer) + (and (ref-variable delete-auto-save-files) + (let ((auto-save-pathname (buffer-auto-save-pathname buffer))) + (and auto-save-pathname + (not (let ((pathname (buffer-pathname buffer))) + (and pathname + (pathname=? auto-save-pathname pathname)))) + (delete-file-no-errors auto-save-pathname))))) + +(define (rename-auto-save-file! buffer) + (let ((old-pathname (buffer-auto-save-pathname buffer))) + (enable-buffer-auto-save! buffer) + (let ((new-pathname (buffer-auto-save-pathname buffer))) + (if (and old-pathname + new-pathname + (not (pathname=? new-pathname old-pathname)) + (not (let ((pathname (buffer-pathname buffer))) + (and pathname + (or (pathname=? new-pathname pathname) + (pathname=? old-pathname pathname))))) + (file-exists? old-pathname)) + (rename-file old-pathname new-pathname))))) + +(define (do-auto-save) + (let ((buffers + (filter (lambda (buffer) + (and (buffer-auto-save-pathname buffer) + (buffer-auto-save-modified? buffer) + (<= (* 10 (buffer-save-length buffer)) + (* 13 (buffer-length buffer))))) + (buffer-list)))) + (if (not (null? buffers)) + (begin + (temporary-message "Auto saving...") + (for-each auto-save-buffer buffers) + (temporary-message "Auto saving...done"))))) + +(define (auto-save-buffer buffer) + (catch-file-errors + (lambda (condition) + condition + (editor-beep) + (let ((name (buffer-name buffer))) + (message "Autosaving...error for " name) + (sleep-for 500) + (message "Autosaving...error!for " name) + (sleep-for 500) + (message "Autosaving...error for " name) + (sleep-for 500))) + (lambda () + (write-region (buffer-unclipped-region buffer) + (buffer-auto-save-pathname buffer) + #f + 'DEFAULT) + (set-buffer-save-length! buffer) + (set-buffer-auto-saved! buffer)))) \ No newline at end of file diff --git a/edwin/basic.scm b/edwin/basic.scm new file mode 100644 index 0000000..d160aaf --- /dev/null +++ b/edwin/basic.scm @@ -0,0 +1,573 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Basic Commands + +(declare (usual-integrations)) + +(define-command self-insert-command + "Insert the character you type. +Whichever character you type to run this command is inserted." + "P" + (lambda (argument) + (let ((char (last-command-key))) + (if (not (char? char)) + (editor-error "self-insert-command only works on character keys.")) + (self-insert char (command-argument-numeric-value argument) #t)))) + +(define (self-insert char n allow-auto-fill?) + (and (> n 0) + (let ((point (current-point)) + (hairy? #f)) + (if (and (not (group-start? point)) + (buffer-minor-mode? (mark-buffer point) + (ref-mode-object abbrev)) + (not (char=? #\w (char-syntax char))) + (char=? #\w (char-syntax (extract-left-char point)))) + (let ((t (group-modified-tick (mark-group point)))) + ((ref-command expand-abbrev) point) + (if (not (fix:= t (group-modified-tick (mark-group point)))) + (set! hairy? #t)))) + (if (and allow-auto-fill? + (or (char=? #\space char) + (char=? #\newline char)) + (current-minor-mode? (ref-mode-object auto-fill))) + (let ((t (group-modified-tick (mark-group point)))) + (auto-fill-break (current-point)) + (if (not (fix:= t (group-modified-tick (mark-group point)))) + (set! hairy? #t)))) + (insert-chars char n) + hairy?))) + +(define (read-quoted-char prompt-string) + (let ((read-ascii-char + (lambda () + (let ((input (with-editor-interrupts-disabled keyboard-read))) + (if (input-event? input) + (abort-current-command input) + (begin + (if (not (ascii-char? input)) + (editor-error "Can't quote non-ASCII char:" input)) + (set-command-prompt! + (string-append (command-prompt) (key-name input))) + input)))))) + (let ((read-digit + (lambda () + (or (char->digit (read-ascii-char) 8) + (editor-error "Not an octal digit"))))) + (set-command-prompt! prompt-string) + (let ((char (read-ascii-char))) + (let ((digit (char->digit char 4))) + (if digit + (integer->char + (let ((digit2 (read-digit))) + (let ((digit3 (read-digit))) + (+ (* (+ (* digit 8) digit2) 8) digit3)))) + char)))))) + +(define-command quoted-insert + "Reads a character and inserts it." + "p" + (lambda (argument) + (insert-chars (read-quoted-char "Quote Character: ") + argument))) + +(define-command open-line + "Insert a newline after point. +Differs from ordinary insertion in that point remains +before the inserted characters. +With an argument, inserts several newlines." + "P" + (lambda (argument) + (let ((m* (mark-right-inserting (current-point)))) + (insert-newlines (command-argument-numeric-value argument)) + (set-current-point! m*)))) + +(define-command narrow-to-region + "Restrict editing in current buffer to text between point and mark. +Use \\[widen] to undo the effects of this command." + "r" + region-clip!) + +(define-command widen + "Remove restrictions from current buffer. +Allows full text to be seen and edited." + () + (lambda () + (buffer-widen! (current-buffer)))) + +(define-command set-key + "Define a key binding from the keyboard. +Prompts for a command and a key, and sets the key's binding. +The key is bound in fundamental mode." + (lambda () + (let ((command (prompt-for-command "Command" 'HISTORY 'SET-KEY))) + (list command + (prompt-for-key (string-append "Put \"" + (command-name-string command) + "\" on key") + (mode-comtabs (ref-mode-object fundamental)))))) + (lambda (command key) + (if (prompt-for-confirmation? "Go ahead") + (define-key 'fundamental key (command-name command))))) + +(define-variable buffer-reallocation-factor + "Determines how much a buffer grows by when it needs to expand. +This is a real number greater than one. When a buffer is expanded, +its size is multiplied by this factor until it is big enough. +Similarly, when a buffer shrinks, its size is divided by this factor. + +Increasing this factor reduces the average time for insertion and +deletion, but increases the average space used by the buffer. + +The minimum ratio between the number of characters in a buffer and the +amount of space allocated to hold them is + (/ 1 (expt buffer-reallocation-factor 2))" + 5/4 + (lambda (object) (and (real? object) (> object 1)))) + +;;;; Prefixes + +(define-command control-prefix + "Sets Control-bit of following character. +This command followed by an = is equivalent to a Control-=." + () + (lambda () + (read-extension-key + (lambda (char) + (merge-bucky-bits char char-bit:control))))) + +(define-command meta-prefix + "Sets Meta-bit of following character. +Turns a following A into a Meta-A. +If the Metizer character is Altmode, it turns ^A +into Control-Meta-A. Otherwise, it turns ^A into plain Meta-A." + () + (lambda () + (read-extension-key + (lambda (char) + (merge-bucky-bits (if (eqv? (current-command-key) #\altmode) + char + (char-base char)) + char-bit:meta))))) + +(define-command control-meta-prefix + "Sets Control- and Meta-bits of following character. +Turns a following A (or C-A) into a Control-Meta-A." + () + (lambda () + (read-extension-key + (lambda (char) + (merge-bucky-bits char (fix:or char-bit:control char-bit:meta)))))) + +(define execute-extended-keys? + #t) + +(define extension-commands + (list (name->command 'control-prefix) + (name->command 'meta-prefix) + (name->command 'control-meta-prefix))) + +(define (read-extension-key modifier) + (if execute-extended-keys? + (set-command-prompt-prefix!)) + (let ((key + (modifier + (let ((input (with-editor-interrupts-disabled keyboard-read))) + (if (char? input) + input + (abort-current-command input)))))) + (if execute-extended-keys? + (dispatch-on-key (current-comtabs) key) + key))) + +(define-command prefix-key + "This is a prefix for more commands. +It reads another character (a subcommand) and dispatches on it." + () + (lambda () + (set-command-prompt-prefix!) + (let loop () + (let ((input (with-editor-interrupts-disabled keyboard-read))) + (if (input-event? input) + (begin + (apply-input-event input) + (loop)) + (dispatch-on-key (current-comtabs) + (let ((prefix-key (current-command-key))) + ((if (pair? prefix-key) append cons) + prefix-key + (list input))))))))) + +(define (set-command-prompt-prefix!) + (set-command-prompt! + (string-append-separated + (command-argument-prompt) + (string-append (xkey->name (current-command-key)) " -")))) + +(define-command execute-extended-command + "Read an extended command from the terminal with completion. +This command reads the name of a command, with completion. Then the +command is invoked. Completion is done as the command name is typed +For more information type the HELP key while entering the name." + () + (lambda () + (dispatch-on-command + (prompt-for-command + ;; Prompt with the name of the command char. + (list (string-append (xkey->name (current-command-key)) " ")) + 'HISTORY 'EXECUTE-EXTENDED-COMMAND) + #t))) + +;;;; Errors + +(define-command keyboard-quit + "Signals a quit condition." + () + (lambda () + (editor-beep) + (temporary-message "Quit") + (^G-signal))) + +(define-command undefined + "This command is used to capture undefined keys." + () + (lambda () + (editor-error "Undefined command: " (xkey->name (current-command-key))))) + +(define (barf-if-read-only) + (editor-error "Trying to modify read only text.")) + +(define (check-first-group-modification group) + (let ((buffer (group-buffer group))) + (if (and buffer + (buffer-truename buffer) + (buffer-modification-time buffer) + (not (verify-visited-file-modification-time? buffer))) + (ask-user-about-supersession-threat buffer)))) + +(define (ask-user-about-supersession-threat buffer) + (if (not + (with-selected-buffer buffer + (lambda () + (prompt-for-confirmation? + "File has changed on disk; really want to edit the buffer")))) + (editor-error "File changed on disk: " + (->namestring (buffer-pathname buffer)))) + (message + "File on disk now will become a backup file if you save these changes.") + (set-buffer-backed-up?! buffer #f)) + +(define (editor-failure . strings) + (cond ((not (null? strings)) (apply message strings)) + (*defining-keyboard-macro?* (clear-message))) + (editor-beep) + (keyboard-macro-disable) + (abort-keyboard-macro)) + +(define-variable beeping-allowed? + "False if Edwin must never beep." + #t) + +(define-integrable (editor-beep) + (if (ref-variable beeping-allowed?) + (screen-beep (selected-screen)))) + +;;;; Level Control + +(define-command exit-recursive-edit + "Exit normally from a subsystem of a level of editing." + () + (lambda () + (exit-recursive-edit 'EXIT))) + +(define-command abort-recursive-edit + "Abnormal exit from recursive editing command. +The recursive edit is exited and the command that invoked it is aborted. +For a normal exit, you should use \\[exit-recursive-edit], NOT this command." + () + (lambda () + (exit-recursive-edit 'ABORT))) + +;;;; Leaving Edwin + +;; Set this to #F to indicate that returning from the editor has the +;; same effect as calling EXIT, or to prevent the editor from +;; returning to scheme. +(define editor-can-exit? #t) + +;; Set this to #F to indicate that calling SUSPEND has the same effect +;; as calling EXIT, or to prevent the editor from suspending to the OS. +(define scheme-can-suspend? + #t) + +;; Set this to #T to force the exit commands to always prompt for +;; confirmation before killing Edwin. +(define paranoid-exit? #f) + +(define-command suspend-scheme + "Go back to Scheme's superior job. +With argument, saves visited file first." + "P" + (lambda (argument) + (if argument (save-buffer (current-buffer) #f)) + (if (and scheme-can-suspend? (os/scheme-can-suspend?)) + (quit-scheme) + (editor-error "Scheme cannot be suspended")))) + +(define-command suspend-edwin + "Stop Edwin and return to Scheme." + () + (lambda () + (if (not editor-can-exit?) + (editor-error "Edwin cannot be suspended")) + (quit-editor))) + +(define (save-buffers-and-exit no-confirmation? noun exit) + (save-some-buffers no-confirmation? #t) + (if (and (or (not (any (lambda (buffer) + (and (buffer-modified? buffer) + (buffer-pathname buffer))) + (buffer-list))) + (prompt-for-yes-or-no? "Modified buffers exist; exit anyway")) + (if (any (lambda (process) + (and (not (process-kill-without-query process)) + (process-runnable? process))) + (process-list)) + (and (prompt-for-yes-or-no? + "Active processes exist; kill them and exit anyway") + (begin + (for-each delete-process (process-list)) + #t)) + (or (not paranoid-exit?) + (prompt-for-yes-or-no? (string-append "Kill " noun))))) + (exit))) + +(define-command save-buffers-kill-scheme + "Offer to save each buffer, then kill Scheme. +With prefix arg, silently save all file-visiting buffers, then kill." + "P" + (lambda (no-confirmation?) + (save-buffers-and-exit no-confirmation? "Scheme" exit-scheme))) + +(define (save-buffers-kill-edwin #!optional no-confirmation?) + (let ((no-confirmation? + (and (not (default-object? no-confirmation?)) no-confirmation?))) + (if editor-can-exit? + (save-buffers-and-exit no-confirmation? "Edwin" exit-editor) + (save-buffers-and-exit no-confirmation? "Scheme" exit-scheme)))) + +(define-command save-buffers-kill-edwin + "Offer to save each buffer, then kill Edwin, returning to Scheme. +With prefix arg, silently save all file-visiting buffers, then kill." + "P" + save-buffers-kill-edwin) + +;;;; Comment Commands + +(define-variable-per-buffer comment-column + "Column to indent right-margin comments to. +Setting this variable automatically makes it local to the current buffer." + 32 + exact-nonnegative-integer?) + +(define-variable comment-locator-hook + "Procedure to find a comment, or false if no comment syntax defined. +The procedure is passed a mark, and should return false if it cannot +find a comment, or a pair of marks. The car should be the start of +the comment, and the cdr should be the end of the comment's starter." + #f) + +(define-variable comment-indent-hook + "Procedure to compute desired indentation for a comment. +The procedure is passed the start mark of the comment +and should return the column to indent the comment to." + #f) + +(define-variable comment-start + "String to insert to start a new comment, or #f if no comment syntax defined." + "" + string-or-false?) + +(define-variable comment-end + "String to insert to end a new comment. +Should be an empty string if comments are terminated by end-of-line." + "" + string?) + +(define-command set-comment-column + "Set the comment column based on point. +With no arg, set the comment column to the current column. +With just minus as arg, kill any comment on this line. +Otherwise, set the comment column to the argument." + "P" + (lambda (argument) + (if (command-argument-negative-only? argument) + ((ref-command kill-comment)) + (let ((column + (or (command-argument-value argument) + (current-column)))) + (set-variable! comment-column column) + (message "comment-column set to " column))))) + +(define-command indent-for-comment + "Indent this line's comment to comment column, or insert an empty comment." + () + (lambda () + (if (not (ref-variable comment-locator-hook)) + (editor-error "No comment syntax defined")) + (let ((start (line-start (current-point) 0)) + (end (line-end (current-point) 0))) + (let ((com ((ref-variable comment-locator-hook) start))) + (set-current-point! (if com (car com) end)) + (let ((comment-end (and com (mark-permanent! (cdr com))))) + (let ((indent + ((ref-variable comment-indent-hook) (current-point)))) + (maybe-change-column indent) + (if comment-end + (set-current-point! comment-end) + (begin + (insert-string (ref-variable comment-start)) + (insert-comment-end (current-point)))))))))) + +(define-variable comment-multi-line + "True means \\[indent-new-comment-line] should continue same comment +on new line, with no new terminator or starter." + #f + boolean?) + +(define-command indent-new-comment-line + "Break line at point and indent, continuing comment if presently within one." + () + (lambda () + (indent-new-comment-line (current-point) (ref-variable fill-prefix)))) + +(define (indent-new-comment-line mark fill-prefix) + (let ((mark (mark-left-inserting-copy mark))) + (delete-horizontal-space mark) + (insert-newlines 1 mark) + (let ((if-not-in-comment + (lambda () + (if fill-prefix + (insert-string fill-prefix mark) + (with-selected-buffer (mark-buffer mark) + (lambda () + (with-current-point mark + (ref-command indent-according-to-mode)))))))) + (if (ref-variable comment-locator-hook mark) + (let ((com ((ref-variable comment-locator-hook mark) + (line-start mark -1)))) + (if com + (let ((start-column (mark-column (car com))) + (end-column (mark-column (cdr com))) + (comment-start (extract-string (car com) (cdr com)))) + (if (ref-variable comment-multi-line mark) + (maybe-change-column end-column mark) + (begin + (insert-string (ref-variable comment-end mark) + (line-end mark -1)) + (maybe-change-column start-column mark) + (insert-string comment-start mark))) + (if (line-end? mark) + (insert-comment-end mark))) + (if-not-in-comment))) + (if-not-in-comment))) + (mark-temporary! mark))) + +(define (insert-comment-end mark) + (let ((mark (mark-right-inserting-copy mark))) + (insert-string (ref-variable comment-end mark) mark) + (set-buffer-point! (mark-buffer mark) mark) + (mark-temporary! mark))) + +(define-command kill-comment + "Kill the comment on this line, if any." + () + (lambda () + (if (not (ref-variable comment-locator-hook)) + (editor-error "No comment syntax defined") + (let ((start (line-start (current-point) 0)) + (end (line-end (current-point) 0))) + (let ((com ((ref-variable comment-locator-hook) start))) + (if com + (kill-string (horizontal-space-start (car com)) end))))))) + +;;;; Useful Documentation + +(define-command define-command + "Scheme special form used to define commands: + + (define-command NAME DOCUMENTATION INTERACTIVE-SPEC PROCEDURE) + +where: + NAME is a symbol; + DOCUMENTATION is a string; + INTERACTIVE-SPEC describes how to call PROCEDURE when the command is + invoked interactively (see below); and + PROCEDURE is a Scheme procedure that is called to perform the + command's actions. + +INTERACTIVE-SPEC and PROCEDURE are evaluated, the others aren't. + +INTERACTIVE-SPEC specifies a way of parsing arguments for interactive +use of a command. For example, write + (define-command foo \"Doc string\" \"p\" (lambda (arg) ...use arg...)) +to make arg be the prefix numeric argument when foo is invoked. + +INTERACTIVE-SPEC is usually a string containing a code letter + followed by a prompt. (Some code letters do not use I/O to get + the argument and do not need prompts.) To prompt for multiple arguments, + give a code letter, its prompt, a newline, and another code letter, etc. +If INTERACTIVE-SPEC is not a string, it is either a procedure or (). + If it's a procedure, then the procedure is invoked with no arguments, + and should return a list of arguments for the command. + Otherwise, if it's the empty list, the command gets no arguments. + +Code letters available are: +b -- Name of existing buffer (string). +B -- Name of buffer, possibly nonexistent (string). +c -- Character. +C -- Command name (symbol). +d -- Value of point (editor-mark object). Does not do I/O. +D -- Directory name (string). +f -- Existing file name (string). +F -- Possibly nonexistent file name (string). +k -- Key sequence (list of chars). +m -- Value of mark (editor-mark object). Does not do I/O. +n -- Number read using minibuffer. +N -- Prefix arg converted to number, or if none, do like code `n'. +p -- Prefix arg converted to number, or 1 if no prefix. Does not do I/O. +P -- Prefix arg converted to number, or #F if no prefix. Does not do I/O. +r -- Region: current region (editor-region object). Does no I/O. +s -- Any string. +v -- Variable name (symbol). +x -- Scheme expression read but not evaluated. +X -- Scheme expression read and evaluated. +In addition, if the first character of the string is '*' then an error is + signaled if the buffer is read-only. + This happens before reading any arguments." + () + (lambda () (editor-error "DEFINE-COMMAND shouldn't be invoked"))) \ No newline at end of file diff --git a/edwin/bios.scm b/edwin/bios.scm new file mode 100644 index 0000000..da89418 --- /dev/null +++ b/edwin/bios.scm @@ -0,0 +1,187 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; IBM-PC BIOS Screen Implementation +;;; package: (edwin screen console-screen) + +(declare (usual-integrations)) + +(define (make-bios-screen) + ;; What is the baud rate needed for? It's not even meaningful. + (let ((baud-rate (output-port/baud-rate (console-i/o-port))) + (x-size (output-port/x-size (console-i/o-port))) + (y-size (output-port/y-size (console-i/o-port)))) + (make-screen (cons (fix:-1+ y-size) (fix:-1+ x-size)) + bios-console-beep + bios-console-clear-line! + bios-console-clear-rectangle! + bios-console-clear-screen! + bios-console-discard! + bios-console-enter! + bios-console-exit! + bios-console-flush! + bios-console-modeline-event! + bios-console-discretionary-flush + bios-console-scroll-lines-down! + bios-console-scroll-lines-up! + bios-console-wrap-update! + bios-console-write-char! + bios-console-write-cursor! + bios-console-write-substring! + (fix:1+ (fix:quotient baud-rate 2400)) + x-size + y-size))) + +(define (bios-available?) + (and (implemented-primitive-procedure? + (ucode-primitive bios:can-use-bios? 0)) + (bios:can-use-bios?) + (let ((term (get-environment-variable "TERM"))) + (and term + (string-ci=? term "ibm_pc_bios"))))) + +(define bios-display-type) + +(define (bios-initialize-package!) + (set! bios-display-type + (make-display-type 'IBM-PC-BIOS + false + bios-available? + make-bios-screen + (lambda (screen) + screen + (get-console-input-operations #F)) + with-console-grabbed + with-console-interrupts-enabled + with-console-interrupts-disabled)) + unspecific) + +;;;; Customized IBM-PC BIOS console operations + +(define-primitives + (bios:beep 0) + (bios:can-use-bios? 0) + (bios:clear-line! 3) + (bios:clear-rectangle! 5) + (bios:clear-screen! 0) + (bios:exit! 0) + (bios:initialize! 2) + (bios:scroll-lines-up! 5) + (bios:scroll-lines-down! 5) + (bios:write-char! 2) + (bios:write-cursor! 2) + (bios:write-substring! 4)) + +(define (bios-console-discard! screen) + screen + unspecific) + +(define (bios-console-enter! screen) + (define (default-attribute variable default) + (let ((val (get-environment-variable variable))) + (cond ((not val) default) + ((string? val) (string->number val)) + (else val)))) + + (bios:initialize! + (default-attribute "EDWIN_FOREGROUND" 37) ; white foreground + (default-attribute "EDWIN_BACKGROUND" 40)) ; black background + (bios:clear-screen!) + (bios-move-cursor screen 0 0) + unspecific) + +(define (bios-console-exit! screen) + (bios-move-cursor screen 0 (fix:-1+ (screen-y-size screen))) + (bios:exit!)) + +(define (bios-console-modeline-event! screen window type) + screen window type + unspecific) + +(define (bios-console-wrap-update! screen thunk) + screen + (thunk)) + +(define (bios-console-discretionary-flush screen) + screen + unspecific) + +(define (bios-console-beep screen) + screen + (bios:beep)) + +(define (bios-console-flush! screen) + screen + unspecific) + +(define-integrable (bios-move-cursor screen x y) + screen + (bios:write-cursor! x y)) + +(define (bios-console-write-cursor! screen x y) + (bios-move-cursor screen x y)) + +(define (bios-console-write-char! screen x y char highlight) + (if (not (and (fix:= y (car (screen-state screen))) + (fix:= x (cdr (screen-state screen))))) + (begin + (bios-move-cursor screen x y) + (bios:write-char! char highlight)))) + +(define (bios-console-write-substring! screen x y string start end highlight) + (let ((end + (let ((delta (fix:- end start))) + (if (and (fix:= y (car (screen-state screen))) + (fix:= (fix:+ x delta) + (screen-x-size screen))) + (fix:-1+ end) + end)))) + (if (fix:< start end) + (begin + (bios-move-cursor screen x y) + (bios:write-substring! string start end highlight))))) + +(define (bios-console-clear-line! screen x y first-unused-x) + (bios:clear-line! x y (fix:-1+ first-unused-x)) + (bios-move-cursor screen x y)) + +(define (bios-console-clear-screen! screen) + (bios:clear-screen!) + (bios-move-cursor screen 0 0)) + +(define (bios-console-clear-rectangle! screen xl xu yl yu highlight) + screen + (bios:clear-rectangle! xl xu yl yu highlight)) + +(define (bios-console-scroll-lines-down! screen xl xu yl yu amount) + screen + (bios:scroll-lines-down! xl (fix:-1+ xu) yl (fix:-1+ yu) amount) + 'CLEARED) + +(define (bios-console-scroll-lines-up! screen xl xu yl yu amount) + screen + (bios:scroll-lines-up! xl (fix:-1+ xu) yl (fix:-1+ yu) amount) + 'CLEARED) \ No newline at end of file diff --git a/edwin/bufcom.scm b/edwin/bufcom.scm new file mode 100644 index 0000000..ba056de --- /dev/null +++ b/edwin/bufcom.scm @@ -0,0 +1,339 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Commands + +(declare (usual-integrations)) + +(define (prompt-for-select-buffer prompt) + (lambda () + (list + (buffer-name + (prompt-for-buffer prompt (previous-buffer)))))) + +(define-command switch-to-buffer + "Select buffer with specified name. +If the variable select-buffer-create is true, +specifying a non-existent buffer will cause it to be created." + (prompt-for-select-buffer "Switch to buffer") + (lambda (buffer) + (select-buffer (find-buffer buffer #t)))) + +(define-command switch-to-buffer-other-window + "Select buffer in another window." + (prompt-for-select-buffer "Switch to buffer in other window") + (lambda (buffer) + (select-buffer-other-window (find-buffer buffer #t)))) + +(define-command switch-to-buffer-other-frame + "Select buffer in another frame." + (prompt-for-select-buffer "Switch to buffer in other frame") + (lambda (buffer) + (select-buffer-other-screen (find-buffer buffer #t)))) +(define edwin-command$switch-to-buffer-other-screen + edwin-command$switch-to-buffer-other-frame) + +(define-command create-buffer + "Create a new buffer with a given name, and select it." + "sCreate buffer" + (lambda (name) + (select-buffer (new-buffer name)))) + +(define-command create-buffer-other-frame + "Create a new buffer with a given name, and select it in another frame." + "sCreate buffer in other frame" + (lambda (name) + (select-buffer-other-screen (new-buffer name)))) +(define edwin-command$create-buffer-other-screen + edwin-command$create-buffer-other-frame) + +(define-command insert-buffer + "Insert the contents of a specified buffer at point." + "bInsert buffer" + (lambda (buffer) + (let ((point (mark-right-inserting (current-point)))) + (region-insert-string! + point + (region->string (buffer-region (find-buffer buffer #t)))) + (push-current-mark! (current-point)) + (set-current-point! point)))) + +(define-command twiddle-buffers + "Select previous buffer." + () + (lambda () + (let ((buffer (previous-buffer))) + (if buffer + (select-buffer buffer) + (editor-error "No previous buffer to select"))))) + +(define-command bury-buffer + "Put current buffer at the end of the list of all buffers. +There it is the least likely candidate for other-buffer to return; +thus, the least likely buffer for \\[switch-to-buffer] to select by default." + () + (lambda () + (let ((buffer (current-buffer)) + (previous (previous-buffer))) + (if previous + (begin + (select-buffer previous) + (bury-buffer buffer)))))) + +(define-command rename-buffer + "Change the name of the current buffer. +Reads the new name in the echo area." + "sRename buffer (to new name)" + (lambda (name) + (if (find-buffer name) + (editor-error "Buffer named " name " already exists")) + (rename-buffer (current-buffer) name))) + +(define-command kill-buffer + "One arg, a string or a buffer. Get rid of the specified buffer." + "bKill buffer" + (lambda (buffer) + (kill-buffer-interactive (find-buffer buffer #t)))) + +(define (kill-buffer-interactive buffer) + (if (not (other-buffer buffer)) (editor-error "Only one buffer")) + (save-buffer-changes buffer) + (if (every (lambda (procedure) + (procedure buffer)) + (ref-variable kill-buffer-query-procedures buffer)) + (kill-buffer buffer) + (message "Buffer not killed."))) + +(define (kill-buffer-query-modified buffer) + (or (not (and (buffer-pathname buffer) + (buffer-modified? buffer) + (buffer-writeable? buffer))) + (prompt-for-yes-or-no? + (string-append "Buffer " + (buffer-name buffer) + " modified; kill anyway")))) + +(define (kill-buffer-query-process buffer) + (or (not (get-buffer-process buffer)) + (prompt-for-yes-or-no? + (string-append "Buffer " + (buffer-name buffer) + " has an active process; kill anyway")))) + +(define-variable kill-buffer-query-procedures + "List of procedures called to query before killing a buffer. +Each procedure is called with one argument, the buffer being killed. +If any procedure returns #f, the buffer is not killed." + (list kill-buffer-query-modified kill-buffer-query-process) + (lambda (object) (and (list? object) (every procedure? object)))) + +(define-command kill-some-buffers + "For each buffer, ask whether to kill it." + () + (lambda () + (kill-some-buffers true))) + +(define (kill-some-buffers prompt?) + (for-each (lambda (buffer) + (if (and (not (minibuffer? buffer)) + (or (not prompt?) + (prompt-for-confirmation? + (string-append "Kill buffer '" + (buffer-name buffer) + "'")))) + (if (other-buffer buffer) + (kill-buffer-interactive buffer) + (let ((dummy (new-buffer "*Dummy*"))) + (kill-buffer-interactive buffer) + (create-buffer initial-buffer-name) + (kill-buffer dummy))))) + (buffer-list))) + +(define-command normal-mode + "Choose the major mode for this buffer automatically. +Also sets up any specified local variables of the file. +Uses the visited file name, the -*- line, and the local variables spec." + () + (lambda () + (normal-mode (current-buffer) false))) + +(define-command toggle-mode-lock + "Change whether this buffer has its major mode locked. +When locked, the buffer's major mode may not be changed." + () + (lambda () + (let ((buffer (current-buffer))) + (if (buffer-get buffer 'MAJOR-MODE-LOCKED) + (begin + (buffer-remove! buffer 'MAJOR-MODE-LOCKED) + (message "Major mode unlocked")) + (begin + (buffer-put! buffer 'MAJOR-MODE-LOCKED true) + (message "Major mode locked")))))) + +(define-command not-modified + "Pretend that this buffer hasn't been altered." + () + (lambda () + (buffer-not-modified! (current-buffer)))) + +(define-command toggle-read-only + "Change whether this buffer is visiting its file read-only." + () + (lambda () + (let ((buffer (current-buffer))) + (if (buffer-writeable? buffer) + (set-buffer-read-only! buffer) + (set-buffer-writeable! buffer))))) + +(define-command no-toggle-read-only + "Display warning indicating that this buffer may not be modified." + () + (lambda () + (editor-failure "This buffer may not be modified."))) + +(define (save-buffer-changes buffer) + (if (and (buffer-pathname buffer) + (buffer-modified? buffer) + (buffer-writeable? buffer) + (prompt-for-yes-or-no? + (string-append "Buffer " + (buffer-name buffer) + " contains changes. Write them out"))) + (write-buffer-interactive buffer false))) + +(define (new-buffer name) + (create-buffer (new-buffer-name name))) + +(define (new-buffer-name name) + (if (find-buffer name) + (let search-loop ((n 2)) + (let ((new-name (string-append name "<" (write-to-string n) ">"))) + (if (find-buffer new-name) + (search-loop (1+ n)) + new-name))) + name)) + +(define (pop-up-temporary-buffer name properties initialization) + (let ((buffer (temporary-buffer name))) + (let ((window (pop-up-buffer buffer #f))) + (initialization buffer window) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (if (memq 'READ-ONLY properties) + (set-buffer-read-only! buffer)) + (if (and window (memq 'SHRINK-WINDOW properties)) + (shrink-window-if-larger-than-buffer window)) + (if (and (memq 'FLUSH-ON-SPACE properties) + (not (typein-window? (current-window)))) + (begin + (message "Hit space to flush.") + (reset-command-prompt!) + (let ((char (keyboard-peek))) + (if (eqv? #\space char) + (begin + (keyboard-read) + (kill-pop-up-buffer #f)))) + (clear-message)))))) + +(define (string->temporary-buffer string name properties) + (pop-up-temporary-buffer name properties + (lambda (buffer window) + window + (insert-string string (buffer-point buffer))))) + +(define (call-with-output-to-temporary-buffer name properties procedure) + (pop-up-temporary-buffer name properties + (lambda (buffer window) + window + (call-with-output-mark (buffer-point buffer) procedure)))) + +(define (with-output-to-temporary-buffer name properties thunk) + (call-with-output-to-temporary-buffer name properties + (lambda (port) + (parameterize ((current-output-port port)) + (thunk))))) + +(define (call-with-temporary-buffer name procedure) + (let ((buffer)) + (dynamic-wind (lambda () + (set! buffer (temporary-buffer name))) + (lambda () + (procedure buffer)) + (lambda () + (kill-buffer buffer) + (set! buffer) + unspecific)))) + +(define (temporary-buffer name) + (let ((buffer (find-or-create-buffer name))) + (buffer-reset! buffer) + buffer)) + +(define (prompt-for-buffer prompt default-buffer . options) + (let ((name + (apply prompt-for-buffer-name prompt default-buffer + 'REQUIRE-MATCH? (not (ref-variable select-buffer-create)) + options))) + (or (find-buffer name) + (let loop ((hooks (ref-variable select-buffer-not-found-hooks))) + (cond ((null? hooks) + (let ((buffer (create-buffer name))) + (temporary-message "(New Buffer)") + buffer)) + ((let ((result ((car hooks) name))) + (and (buffer? result) + result))) + (else + (loop (cdr hooks)))))))) + +(define-variable select-buffer-create + "If true, buffer selection commands may create new buffers." + true + boolean?) + +(define-variable select-buffer-not-found-hooks + "List of procedures to be called for select-buffer on nonexistent buffer. +These procedures are called as soon as the error is detected. +The procedures are called in the order given, +until one of them returns a buffer. +This variable has no effect if select-buffer-create is false." + '() + list?) + +(define (prompt-for-existing-buffer prompt default-buffer . options) + (find-buffer (apply prompt-for-buffer-name prompt default-buffer + 'REQUIRE-MATCH? #t + options) + #t)) + +(define (prompt-for-buffer-name prompt default-buffer . options) + (apply prompt-for-string-table-name + prompt + (and default-buffer (buffer-name default-buffer)) + (buffer-names) + 'DEFAULT-TYPE (if default-buffer 'VISIBLE-DEFAULT 'NO-DEFAULT) + options)) \ No newline at end of file diff --git a/edwin/buffer.scm b/edwin/buffer.scm new file mode 100644 index 0000000..184c99f --- /dev/null +++ b/edwin/buffer.scm @@ -0,0 +1,566 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Abstraction + +(declare (usual-integrations)) + +(define-structure (buffer + (constructor %make-buffer (%name %default-directory)) + (print-procedure + (standard-print-method 'BUFFER + (lambda (buffer) + (list (buffer-name buffer)))))) + %name + group + mark-ring + modes + comtabs + windows + display-start + %default-directory + %pathname + %truename + alist + local-bindings + local-bindings-installed? + auto-save-pathname + auto-saved? + %save-length + backed-up? + modification-time) + +(define-syntax rename-buffer-accessor + (sc-macro-transformer + (lambda (form environment) + (let ((slot-name (cadr form))) + `(define-integrable ,(symbol 'buffer- slot-name) + ,(close-syntax (symbol 'buffer-% slot-name) + environment)))))) + +(rename-buffer-accessor name) +(rename-buffer-accessor default-directory) +(rename-buffer-accessor pathname) +(rename-buffer-accessor truename) +(rename-buffer-accessor save-length) + +(define-variable buffer-creation-hook + "An event distributor that is invoked when a new buffer is created. +The new buffer is passed as its argument. +The buffer is guaranteed to be deselected at that time." + (make-event-distributor)) + +(define (make-buffer name mode directory) + (let ((buffer (%make-buffer name directory))) + (let ((group (make-group buffer))) + (set-buffer-group! buffer group) + (add-group-clip-daemon! group (buffer-clip-daemon buffer)) + (%buffer-reset! buffer) + (set-buffer-windows! buffer '()) + (set-buffer-display-start! buffer #f) + (set-buffer-default-directory! buffer directory) + (set-buffer-local-bindings! buffer '()) + (set-buffer-local-bindings-installed?! buffer #f) + (%set-buffer-major-mode! buffer mode) + (event-distributor/invoke! + (variable-default-value (ref-variable-object buffer-creation-hook)) + buffer) + buffer))) + +(define (%buffer-reset! buffer) + (let ((group (buffer-group buffer))) + (disable-group-undo! group) + (if (not (minibuffer? buffer)) + (enable-group-undo! group))) + (set-buffer-mark-ring! + buffer + (make-ring + (variable-default-value (ref-variable-object mark-ring-maximum)))) + (ring-push! (buffer-mark-ring buffer) (buffer-start buffer)) + (set-buffer-%pathname! buffer #f) + (set-buffer-%truename! buffer #f) + (set-buffer-auto-save-pathname! buffer #f) + (set-buffer-auto-saved?! buffer #f) + (set-buffer-%save-length! buffer 0) + (set-buffer-backed-up?! buffer #f) + (set-buffer-modification-time! buffer #f) + (set-buffer-alist! buffer '())) + +(define (buffer-modeline-event! buffer type) + (let loop ((windows (buffer-windows buffer))) + (if (not (null? windows)) + (begin + (window-modeline-event! (car windows) type) + (loop (cdr windows)))))) + +(define (without-editor-interrupts thunk) + ;; Control interrupts whether or not in the editor. + ;; WITH-EDITOR-INTERRUPTS-DISABLED is required in the running editor but + ;; buffers are created at editor initialization time and variables may + ;; be set as early as initial file load time (prior to dumping the band). + (if within-editor? + (with-editor-interrupts-disabled thunk) + (without-interrupts thunk))) + +(define (buffer-reset! buffer) + (set-buffer-writeable! buffer) + (buffer-widen! buffer) + (region-delete! (buffer-region buffer)) + (buffer-not-modified! buffer) + (without-editor-interrupts + (lambda () + (undo-local-bindings! buffer #t) + (%buffer-reset! buffer) + (%set-buffer-major-mode! + buffer + (variable-default-value (ref-variable-object editor-default-mode))) + (event-distributor/invoke! event:set-buffer-pathname buffer) + (buffer-modeline-event! buffer 'buffer-reset)))) + +(define (set-buffer-name! buffer name) + (set-buffer-%name! buffer name) + (buffer-modeline-event! buffer 'buffer-name)) + +(define (set-buffer-default-directory! buffer directory) + (set-buffer-%default-directory! buffer (pathname-simplify directory))) + +(define (set-buffer-pathname! buffer pathname) + (set-buffer-%pathname! buffer pathname) + (if pathname + (set-buffer-default-directory! buffer (directory-pathname pathname))) + (event-distributor/invoke! event:set-buffer-pathname buffer) + (buffer-modeline-event! buffer 'buffer-pathname)) + +(define event:set-buffer-pathname + (make-event-distributor)) + +(define (set-buffer-truename! buffer truename) + (set-buffer-%truename! buffer truename) + (buffer-modeline-event! buffer 'buffer-truename)) + +(define-integrable (set-buffer-save-length! buffer) + (set-buffer-%save-length! buffer (buffer-length buffer))) + +(define (buffer-point buffer) + (cond ((current-buffer? buffer) + (current-point)) + ((let ((windows (buffer-windows buffer))) + (and (pair? windows) + (null? (cdr windows)) + (car windows))) + => window-point) + (else + (group-point (buffer-group buffer))))) + +(define-integrable (%set-buffer-point! buffer mark) + (set-group-point! (buffer-group buffer) mark)) + +(define-integrable (%set-buffer-point-index! buffer index) + (set-group-point-index! (buffer-group buffer) index)) + +(define-integrable (minibuffer? buffer) + (char=? (string-ref (buffer-name buffer) 0) #\space)) + +(define-integrable (buffer-region buffer) + (group-region (buffer-group buffer))) + +(define-integrable (buffer-string buffer) + (region->string (buffer-region buffer))) + +(define-integrable (buffer-unclipped-region buffer) + (group-unclipped-region (buffer-group buffer))) + +(define-integrable (buffer-widen! buffer) + (group-widen! (buffer-group buffer))) + +(define-integrable (buffer-length buffer) + (group-length (buffer-group buffer))) + +(define-integrable (buffer-start buffer) + (group-start-mark (buffer-group buffer))) + +(define-integrable (buffer-end buffer) + (group-end-mark (buffer-group buffer))) + +(define-integrable (buffer-absolute-start buffer) + (group-absolute-start (buffer-group buffer))) + +(define-integrable (buffer-absolute-end buffer) + (group-absolute-end (buffer-group buffer))) + +(define (add-buffer-window! buffer window) + (set-buffer-windows! buffer (cons window (buffer-windows buffer)))) + +(define (remove-buffer-window! buffer window) + (set-buffer-windows! buffer (delq! window (buffer-windows buffer)))) + +(define (buffer-visible? buffer) + (any window-visible? (buffer-windows buffer))) + +(define (buffer-x-size buffer) + (let ((windows (buffer-windows buffer))) + (if (null? windows) + (screen-x-size (selected-screen)) + (apply min (map window-x-size windows))))) + +(define (mark-x-size mark) + (let ((buffer (mark-buffer mark))) + (if buffer + (buffer-x-size buffer) + (screen-x-size (selected-screen))))) + +(define (buffer-get buffer key #!optional default) + (let ((entry (assq key (buffer-alist buffer)))) + (if entry + (cdr entry) + (if (default-object? default) #f default)))) + +(define (buffer-put! buffer key value) + (let ((entry (assq key (buffer-alist buffer)))) + (if entry + (set-cdr! entry value) + (set-buffer-alist! buffer + (cons (cons key value) (buffer-alist buffer)))))) + +(define (buffer-remove! buffer key) + (set-buffer-alist! buffer (del-assq! key (buffer-alist buffer)))) + +(define (->buffer object) + (or (cond ((or (default-object? object) (not object)) (current-buffer)) + ((buffer? object) object) + ((mark? object) (mark-buffer object)) + ((group? object) (group-buffer object)) + ((region? object) (mark-buffer (region-start object))) + ((window? object) (window-buffer object)) + (else (error:wrong-type-argument object "buffer" '->buffer))) + (error:bad-range-argument object '->buffer))) + +;;;; Modification Flags + +(define-integrable (buffer-modified? buffer) + (group-modified? (buffer-group buffer))) + +(define (buffer-not-modified! buffer) + (without-editor-interrupts + (lambda () + (let ((group (buffer-group buffer))) + (if (group-modified? group) + (begin + (set-group-modified?! group #f) + (buffer-modeline-event! buffer 'buffer-modified) + (set-buffer-auto-saved?! buffer #f))))))) + +(define (buffer-modified! buffer) + (without-editor-interrupts + (lambda () + (let ((group (buffer-group buffer))) + (if (not (group-modified? group)) + (begin + (set-group-modified?! group #t) + (buffer-modeline-event! buffer 'buffer-modified))))))) + +(define (verify-visited-file-modification-time? buffer) + (let ((truename (buffer-truename buffer)) + (buffer-time (buffer-modification-time buffer))) + (or (not truename) + (not buffer-time) + (let ((file-time (file-modification-time truename))) + (and file-time (< (abs (- buffer-time file-time)) 2)))))) + +(define-integrable (clear-visited-file-modification-time! buffer) + (set-buffer-modification-time! buffer #f)) + +(define (set-buffer-auto-saved! buffer) + (set-buffer-auto-saved?! buffer #t) + (set-group-modified?! (buffer-group buffer) 'auto-saved)) + +(define-integrable (buffer-auto-save-modified? buffer) + (eq? #t (group-modified? (buffer-group buffer)))) + +(define (buffer-clip-daemon buffer) + (lambda (group start end) + group start end ;ignore + (buffer-modeline-event! buffer 'clipping-changed))) + +(define-integrable (buffer-read-only? buffer) + (group-read-only? (buffer-group buffer))) + +(define-integrable (buffer-writeable? buffer) + (not (buffer-read-only? buffer))) + +(define (set-buffer-writeable! buffer) + (set-group-writeable! (buffer-group buffer)) + (buffer-modeline-event! buffer 'buffer-modifiable)) + +(define (set-buffer-read-only! buffer) + (set-group-read-only! (buffer-group buffer)) + (buffer-modeline-event! buffer 'buffer-modifiable)) + +(define (with-read-only-defeated object thunk) + (let ((group (buffer-group (->buffer object))) + (outside) + (inside 'fully)) + (dynamic-wind (lambda () + (set! outside (group-writeable? group)) + (set-group-writeable?! group inside)) + thunk + (lambda () + (set! inside (group-writeable? group)) + (set-group-writeable?! group outside))))) + +;;;; Local Bindings + +(define (define-variable-local-value! buffer variable value) + (let ((buffer (->buffer buffer)) + (value (normalize-variable-value variable value))) + (without-editor-interrupts + (lambda () + (let ((binding (search-local-bindings buffer variable))) + (if binding + (set-cdr! binding value) + (set-buffer-local-bindings! + buffer + (cons (cons variable value) + (buffer-local-bindings buffer))))) + (if (buffer-local-bindings-installed? buffer) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! buffer variable))))) + +(define (undefine-variable-local-value! buffer variable) + (let ((buffer (->buffer buffer))) + (without-editor-interrupts + (lambda () + (let ((binding (search-local-bindings buffer variable))) + (if binding + (begin + (set-buffer-local-bindings! + buffer + (delq! binding (buffer-local-bindings buffer))) + (if (buffer-local-bindings-installed? buffer) + (set-variable-%value! variable + (variable-default-value variable))) + (invoke-variable-assignment-daemons! buffer variable)))))))) + +(define (variable-local-value buffer variable) + (let ((not-mark-local + (lambda () + (let ((binding + (and buffer + (search-local-bindings (->buffer buffer) variable)))) + (if binding + (cdr binding) + (variable-default-value variable)))))) + (if (mark? buffer) + (let ((no-datum (list 'NO-DATUM))) + (let ((value (region-get buffer variable no-datum))) + (if (eq? value no-datum) + (not-mark-local) + value))) + (not-mark-local)))) + +(define (variable-local-value? buffer variable) + (or (not buffer) + (search-local-bindings (->buffer buffer) variable))) + +(define (set-variable-local-value! buffer variable value) + (if buffer + (let ((buffer (->buffer buffer))) + (cond ((variable-buffer-local? variable) + (define-variable-local-value! buffer variable value)) + ((search-local-bindings buffer variable) + => + (lambda (binding) + (let ((value (normalize-variable-value variable value))) + (without-editor-interrupts + (lambda () + (set-cdr! binding value) + (if (buffer-local-bindings-installed? buffer) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! buffer + variable)))))) + (else + (set-variable-default-value! variable value)))) + (set-variable-default-value! variable value))) + +(define (set-variable-default-value! variable value) + (if within-editor? + (let ((value (normalize-variable-value variable value))) + (without-editor-interrupts + (lambda () + (set-variable-%default-value! variable value) + (if (not (search-local-bindings (current-buffer) variable)) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! #f variable)))) + (set-default-variable-value!/outside-editor variable value))) + +(define-integrable (search-local-bindings buffer variable) + (let loop ((bindings (buffer-local-bindings buffer))) + (and (not (null? bindings)) + (if (eq? (caar bindings) variable) + (car bindings) + (loop (cdr bindings)))))) + +(define (undo-local-bindings! buffer all?) + ;; Caller guarantees that interrupts are disabled. + (let ((bindings (buffer-local-bindings buffer))) + (if (buffer-local-bindings-installed? buffer) + (do ((bindings bindings (cdr bindings))) + ((null? bindings)) + (set-variable-%value! (caar bindings) + (variable-default-value (caar bindings))))) + (call-with-values + (lambda () + (split-list bindings + (lambda (binding) + (variable-permanent-local? (car binding))))) + (lambda (permanent impermanent) + (set-buffer-local-bindings! buffer (if all? '() permanent)) + (do ((bindings impermanent (cdr bindings))) + ((null? bindings)) + (invoke-variable-assignment-daemons! buffer (caar bindings))))))) + +(define (with-current-local-bindings! thunk) + (dynamic-wind (lambda () + (install-buffer-local-bindings! (current-buffer))) + thunk + (lambda () + (uninstall-buffer-local-bindings! (current-buffer))))) + +(define (change-local-bindings! old-buffer new-buffer select-buffer!) + ;; Assumes that interrupts are disabled and that OLD-BUFFER is selected. + (uninstall-buffer-local-bindings! old-buffer) + (select-buffer!) + (install-buffer-local-bindings! new-buffer)) + +(define (install-buffer-local-bindings! buffer) + (do ((bindings (buffer-local-bindings buffer) (cdr bindings))) + ((null? bindings)) + (set-variable-%value! (caar bindings) (cdar bindings))) + (set-buffer-local-bindings-installed?! buffer #t)) + +(define (uninstall-buffer-local-bindings! buffer) + (do ((bindings (buffer-local-bindings buffer) (cdr bindings))) + ((null? bindings)) + (set-variable-%value! (caar bindings) + (variable-default-value (caar bindings)))) + (set-buffer-local-bindings-installed?! buffer #f)) + +(define (set-variable-value! variable value) + (if within-editor? + (set-variable-local-value! (current-buffer) variable value) + (set-default-variable-value!/outside-editor variable value))) + +(define (set-default-variable-value!/outside-editor variable value) + (let ((value (normalize-variable-value variable value))) + (without-interrupts + ;; Not with-editor-interrupts-disabled as we are not within-editor? + (lambda () + (set-variable-%default-value! variable value) + (set-variable-%value! variable value) + (invoke-variable-assignment-daemons! #f variable))))) + +(define (with-variable-value! variable new-value thunk) + (let ((old-value)) + (dynamic-wind (lambda () + (set! old-value (variable-value variable)) + (set-variable-value! variable new-value) + (set! new-value) + unspecific) + thunk + (lambda () + (set! new-value (variable-value variable)) + (set-variable-value! variable old-value) + (set! old-value) + unspecific)))) + +;;;; Modes + +(define-integrable (buffer-major-mode buffer) + (car (buffer-modes buffer))) + +(define (set-buffer-major-mode! buffer mode) + (if (not (and (mode? mode) (mode-major? mode))) + (error:wrong-type-argument mode "major mode" 'set-buffer-major-mode!)) + (if (buffer-get buffer 'major-mode-locked) + (editor-error "The major mode of this buffer is locked: " buffer)) + ;; The very first buffer is created before the editor + (without-editor-interrupts + (lambda () + (undo-local-bindings! buffer #f) + (%set-buffer-major-mode! buffer mode) + (buffer-modeline-event! buffer 'buffer-modes)))) + +(define (%set-buffer-major-mode! buffer mode) + (set-buffer-modes! buffer (list mode)) + (set-buffer-comtabs! buffer (mode-comtabs mode)) + (set-variable-local-value! buffer + (ref-variable-object mode-name) + (mode-display-name mode)) + ((mode-initialization mode) buffer) + (event-distributor/invoke! event:set-buffer-major-mode buffer)) + +(define event:set-buffer-major-mode + (make-event-distributor)) + +(define (buffer-minor-modes buffer) + (list-copy (cdr (buffer-modes buffer)))) + +(define (buffer-minor-mode? buffer mode) + (if (not (and (mode? mode) (not (mode-major? mode)))) + (error:wrong-type-argument mode "minor mode" 'buffer-minor-mode?)) + (memq mode (cdr (buffer-modes buffer)))) + +(define (enable-buffer-minor-mode! buffer mode) + (if (not (minor-mode? mode)) + (error:wrong-type-argument mode "minor mode" 'enable-buffer-minor-mode!)) + (without-editor-interrupts + (lambda () + (let ((modes (buffer-modes buffer))) + (if (not (memq mode (cdr modes))) + (begin + (set-cdr! modes (append! (cdr modes) (list mode))) + (set-buffer-comtabs! buffer + (cons (minor-mode-comtab mode) + (buffer-comtabs buffer))) + (add-minor-mode-line-entry! buffer mode) + ((mode-initialization mode) buffer) + (buffer-modeline-event! buffer 'buffer-modes))))))) + +(define (disable-buffer-minor-mode! buffer mode) + (if (not (minor-mode? mode)) + (error:wrong-type-argument mode "minor mode" + 'disable-buffer-minor-mode!)) + (without-editor-interrupts + (lambda () + (let ((modes (buffer-modes buffer))) + (if (memq mode (cdr modes)) + (begin + (set-cdr! modes (delq! mode (cdr modes))) + (set-buffer-comtabs! buffer + (delq! (minor-mode-comtab mode) + (buffer-comtabs buffer))) + (remove-minor-mode-line-entry! buffer mode) + (buffer-modeline-event! buffer 'buffer-modes))))))) \ No newline at end of file diff --git a/edwin/buffrm.scm b/edwin/buffrm.scm new file mode 100644 index 0000000..3e59497 --- /dev/null +++ b/edwin/buffrm.scm @@ -0,0 +1,532 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Frames + +(declare (usual-integrations)) + +(define-class buffer-frame combination-leaf-window + ( + ;; The inferior (of type BUFFER-WINDOW) that displays the buffer's + ;; text. + text-inferior + + ;; The inferior (of type MODELINE-WINDOW) that displays the + ;; modeline. May be #F if this window has no modeline (e.g. a + ;; typein window). + modeline-inferior + + ;; The inferior (of type VERTICAL-BORDER-WINDOW) that draws a + ;; vertical border on the right-hand side of the window when this + ;; window has a neighbor to its right. + border-inferior + + ;; A nonnegative integer that is updated when this window is + ;; selected. This updating is performed by the editor frame that + ;; this window is a part of. + last-select-time + )) + +(define-method buffer-frame (:make-leaf frame) + (let ((frame* (==> superior :make-inferior buffer-frame))) + (set-buffer-frame-size! frame* (window-x-size frame) (window-y-size frame)) + (set-window-buffer! frame* (window-buffer frame)) + (initial-modeline! frame* modeline-inferior) + frame*)) + +(define-method buffer-frame (:initialize! frame window*) + (usual==> frame :initialize! window*) + (set! text-inferior (make-inferior frame buffer-window)) + (set! border-inferior (make-inferior frame vertical-border-window)) + (set! last-select-time 0)) + +(define-method buffer-frame (:kill! window) + (remove-buffer-window! (window-buffer window) window) + (usual==> window :kill!)) + +(define-method buffer-frame (:update-display! window screen x-start y-start + xl xu yl yu display-style) + ;; Assumes that interrupts are disabled. + (update-inferior! text-inferior screen x-start y-start + xl xu yl yu display-style + buffer-window:update-display!) + (if modeline-inferior + (update-inferior! modeline-inferior screen x-start y-start + xl xu yl yu display-style + modeline-window:update-display!)) + (update-inferior! border-inferior screen x-start y-start + xl xu yl yu display-style + vertical-border-window:update-display!) + #t) + +(define (initial-modeline! frame modeline?) + ;; **** Kludge: The text-inferior will generate modeline events, so + ;; if the modeline gets redisplayed first it will be left with its + ;; redisplay-flag set but its superior's redisplay-flag cleared. + (with-instance-variables buffer-frame frame (modeline?) + (if modeline? + (begin + (set! modeline-inferior (make-inferior frame modeline-window)) + (set! inferiors + (append! (delq! modeline-inferior inferiors) + (list modeline-inferior)))) + (set! modeline-inferior #f)))) + +(define-integrable (frame-text-inferior frame) + (with-instance-variables buffer-frame frame () + (inferior-window text-inferior))) + +(define-integrable (frame-modeline-inferior frame) + (with-instance-variables buffer-frame frame () + (and modeline-inferior + (inferior-window modeline-inferior)))) + +(define-method buffer-frame (:set-size! window x y) + (set-buffer-frame-size! window x y)) + +(define-method buffer-frame (:set-x-size! window x) + (set-buffer-frame-size! window x y-size)) + +(define-method buffer-frame (:set-y-size! window y) + (set-buffer-frame-size! window x-size y)) + +(define (set-buffer-frame-size! window x y) + (with-instance-variables buffer-frame window (x y) + (usual==> window :set-size! x y) + (if modeline-inferior + (begin + (set! y (- y (inferior-y-size modeline-inferior))) + (set-inferior-start! modeline-inferior 0 y) + (set-inferior-x-size! modeline-inferior x))) + (if (window-has-right-neighbor? window) + (begin + (set! x (- x (inferior-x-size border-inferior))) + (set-inferior-start! border-inferior x 0) + (set-inferior-y-size! border-inferior y)) + (set-inferior-start! border-inferior #f #f)) + (set-inferior-start! text-inferior 0 0) + (set-inferior-size! text-inferior x y))) + +(define-method buffer-frame (:minimum-x-size window) + (if (window-has-right-neighbor? window) + (+ (ref-variable window-min-width) + (inferior-x-size border-inferior)) + (ref-variable window-min-width))) + +(define-method buffer-frame (:minimum-y-size window) + (if modeline-inferior + (+ (ref-variable window-min-height) + (inferior-y-size modeline-inferior)) + (ref-variable window-min-height))) + +;;;; External Entries + +(define-integrable (buffer-frame? object) + (object-of-class? buffer-frame object)) + +(define (make-buffer-frame superior new-buffer modeline?) + (let ((frame (==> superior :make-inferior buffer-frame))) + (set-window-buffer! frame new-buffer) + (initial-modeline! frame modeline?) + frame)) + +(define-integrable (buffer-frame-x-size frame) + (window-x-size (frame-text-inferior frame))) + +(define-integrable (buffer-frame-y-size frame) + (window-y-size (frame-text-inferior frame))) + +(define-integrable (buffer-frame-needs-redisplay? frame) + (buffer-window/needs-redisplay? (frame-text-inferior frame))) + +(define-integrable (window-cursor-enable! frame) + (buffer-window/cursor-enable! (frame-text-inferior frame))) + +(define-integrable (window-cursor-disable! frame) + (buffer-window/cursor-disable! (frame-text-inferior frame))) + +(define-integrable (window-select-time frame) + (with-instance-variables buffer-frame frame () + last-select-time)) + +(define-integrable (set-window-select-time! frame time) + (with-instance-variables buffer-frame frame (time) + (set! last-select-time time))) + +(define-integrable (window-buffer frame) + (buffer-window/buffer (frame-text-inferior frame))) + +(define (set-window-buffer! frame buffer) + ;; BUFFER-WINDOW/SET-BUFFER! expects to have interrupts locked here. + (without-interrupts + (lambda () + ;; Someday this will bite someone... + (if (and (string-ci=? (buffer-name buffer) "bluffer") + (null? (buffer-windows buffer))) + (buffer-reset! buffer)) + (if (window-buffer frame) + (remove-buffer-window! (window-buffer frame) frame)) + (buffer-window/set-buffer! (frame-text-inferior frame) buffer) + (add-buffer-window! buffer frame)))) + +(define-integrable (window-point frame) + (buffer-window/point (frame-text-inferior frame))) + +(define-integrable (set-window-point! frame mark) + (buffer-window/set-point! (frame-text-inferior frame) mark)) + +(define-integrable (window-redraw! frame) + (buffer-window/redraw! (frame-text-inferior frame))) + +(define (window-modeline-event! frame type) + (let ((window (frame-modeline-inferior frame))) + (if window + (modeline-window:event! window type))) + (screen-modeline-event! (window-screen frame) frame type)) + +(define (notice-window-changes! frame) + (let ((window (frame-modeline-inferior frame))) + (if window + (modeline-window:notice-changes! window))) + (%notice-window-changes! (frame-text-inferior frame))) + +(define-integrable (window-override-message window) + (buffer-window/override-message (frame-text-inferior window))) + +(define-integrable (window-set-override-message! window message) + (buffer-window/set-override-message! (frame-text-inferior window) message)) + +(define-integrable (window-clear-override-message! window) + (buffer-window/clear-override-message! (frame-text-inferior window))) + +(define-integrable (window-direct-update! frame display-style) + (buffer-window/direct-update! (frame-text-inferior frame) display-style)) + +(define-integrable (window-home-cursor! window) + (buffer-window/home-cursor! (frame-text-inferior window))) + +(define-integrable (window-char->image frame char) + (%window-char->image (frame-text-inferior frame) char)) + +(define-integrable (window-direct-output-cursor! frame) + (buffer-window/direct-output-cursor! (frame-text-inferior frame))) + +(define-integrable (window-direct-output-forward-char! frame) + (buffer-window/direct-output-forward-char! (frame-text-inferior frame))) + +(define-integrable (window-direct-output-backward-char! frame) + (buffer-window/direct-output-backward-char! (frame-text-inferior frame))) + +(define-integrable (window-direct-output-insert-char! frame char) + (buffer-window/direct-output-insert-char! (frame-text-inferior frame) char)) + +(define-integrable (window-direct-output-insert-newline! frame) + (buffer-window/direct-output-insert-newline! (frame-text-inferior frame))) + +(define-integrable (window-direct-output-insert-substring! frame + string start end) + (buffer-window/direct-output-insert-substring! (frame-text-inferior frame) + string start end)) + +(define-integrable (window-scroll-y-absolute! frame y-point) + (buffer-window/scroll-y-absolute! (frame-text-inferior frame) y-point)) + +(define-integrable (window-scroll-y-relative! frame delta) + (buffer-window/scroll-y-relative! (frame-text-inferior frame) delta)) + +(define-integrable (set-window-start-mark! frame mark force?) + (buffer-window/set-start-mark! (frame-text-inferior frame) mark force?)) + +(define-integrable (window-y-center frame) + (buffer-window/y-center (frame-text-inferior frame))) + +(define-integrable (window-start-mark frame) + (buffer-window/start-mark (frame-text-inferior frame))) + +(define-integrable (window-mark-visible? frame mark) + (buffer-window/mark-visible? (frame-text-inferior frame) mark)) + +(define-integrable (window-mark->x frame mark) + (buffer-window/mark->x (frame-text-inferior frame) mark)) + +(define-integrable (window-mark->y frame mark) + (buffer-window/mark->y (frame-text-inferior frame) mark)) + +(define-integrable (window-mark->coordinates frame mark) + (buffer-window/mark->coordinates (frame-text-inferior frame) mark)) + +(define-integrable (window-point-x frame) + (buffer-window/point-x (frame-text-inferior frame))) + +(define-integrable (window-point-y frame) + (buffer-window/point-y (frame-text-inferior frame))) + +(define-integrable (window-point-coordinates frame) + (buffer-window/point-coordinates (frame-text-inferior frame))) + +(define-integrable (window-coordinates->mark frame x y) + (buffer-window/coordinates->mark (frame-text-inferior frame) x y)) + +(define-integrable (set-window-debug-trace! frame debug-trace) + (%set-window-debug-trace! (frame-text-inferior frame) debug-trace)) + +(define-variable-per-buffer truncate-lines + "True means do not display continuation lines; +give each line of text one screen line. +Automatically becomes local when set in any fashion. + +Note that this is overridden by the variable +truncate-partial-width-windows if that variable is true +and this buffer is not full-screen width." + #f + boolean?) + +(define-variable truncate-partial-width-windows + "True means truncate lines in all windows less than full screen wide." + #t + boolean?) + +(define-variable-per-buffer tab-width + "Distance between tab stops (for display of tab characters), in columns. +Automatically becomes local when set in any fashion." + 8 + exact-nonnegative-integer?) + +(define-variable-per-buffer char-image-strings + "A vector of 256 strings mapping ascii bytes to image strings. +Each image is a short string of at least one character. +Index 0 might contain \"^@\" so ascii NUL appears as ^@. +The indices for normal printing characters usually contain a +string containing just that character, e.g. index 65 usually contains \"A\". +Automatically becomes local when set in any fashion." + default-char-image-strings + (lambda (object) + (and (vector? object) + (= (vector-length object) 256) + (let loop ((i 0)) + (if (= i 256) + #T + (and (string? (vector-ref object i)) + (<= 1 (string-length (vector-ref object i)) 255) + (loop (+ i 1)))))))) + +(let ((setup-truncate-lines! + (lambda (buffer variable) + variable ;ignore + (for-each window-redraw! ;recaches these variables + (if buffer + (buffer-windows buffer) + (window-list)))))) + (add-variable-assignment-daemon! + (ref-variable-object truncate-lines) + setup-truncate-lines!) + (add-variable-assignment-daemon! + (ref-variable-object truncate-partial-width-windows) + setup-truncate-lines!) + (add-variable-assignment-daemon! + (ref-variable-object tab-width) + setup-truncate-lines!) + (add-variable-assignment-daemon! + (ref-variable-object char-image-strings) + setup-truncate-lines!)) + +;;;; Window Configurations + +(define-structure (window-configuration (conc-name window-configuration/)) + (screen-x-size #f read-only #t) + (screen-y-size #f read-only #t) + (root-window #f read-only #t) + (root-x-size #f read-only #t) + (root-y-size #f read-only #t) + (selected-window #f read-only #t) + (cursor-window #f read-only #t) + (minibuffer-scroll-window #f read-only #t)) + +(define-structure (saved-combination (conc-name saved-combination/)) + (vertical? #f read-only #t) + (children #f read-only #t)) + +(define-structure (saved-window (conc-name saved-window/)) + (buffer #f read-only #t) + (point #f read-only #t) + (mark #f read-only #t) + (start-mark #f read-only #t)) + +(define (guarantee-window-configuration object procedure) + (if (not (window-configuration? object)) + (error:wrong-type-argument object "window configuration" procedure))) + +(define (screen-window-configuration screen) + (guarantee-screen screen 'SCREEN-WINDOW-CONFIGURATION) + (let ((frame (screen-root-window screen)) + (converted-windows '())) + (let ((root-window + (let convert-window ((window (editor-frame-root-window frame))) + (if (combination? window) + (let ((vertical? (combination-vertical? window))) + (make-saved-combination + vertical? + (let loop ((window (combination-child window))) + (cons (cons (if vertical? + (window-y-size window) + (window-x-size window)) + (convert-window window)) + (let ((next (window-next window))) + (if next + (loop next) + '())))))) + (let ((saved-window + (let ((buffer (window-buffer window))) + (make-saved-window + buffer + (mark-right-inserting-copy (window-point window)) + (let ((ring (buffer-mark-ring buffer))) + (if (ring-empty? ring) + #f + (mark-right-inserting-copy + (ring-ref ring 0)))) + (mark-right-inserting-copy + (window-start-mark window)))))) + (set! converted-windows + (cons (cons window saved-window) converted-windows)) + saved-window)))) + (converted-window + (lambda (window) + (let ((association (assq window converted-windows))) + (and association + (cdr association))))) + (selected-window (editor-frame-selected-window frame))) + (make-window-configuration + (screen-x-size screen) + (screen-y-size screen) + root-window + (window-x-size frame) + (window-y-size frame) + (converted-window selected-window) + (let ((window (editor-frame-cursor-window frame))) + (and (not (eq? window selected-window)) + (converted-window window))) + (let ((window (weak-car *minibuffer-scroll-window*))) + (and (window? window) + (converted-window window))))))) + +(define (set-screen-window-configuration! screen configuration) + (guarantee-screen screen 'SET-SCREEN-WINDOW-CONFIGURATION!) + (guarantee-window-configuration configuration + 'SET-SCREEN-WINDOW-CONFIGURATION!) + (if (and (= (screen-x-size screen) + (window-configuration/screen-x-size configuration)) + (= (screen-y-size screen) + (window-configuration/screen-y-size configuration))) + (begin + (delete-other-windows (screen-window0 screen)) + (let ((x-size (window-configuration/root-x-size configuration)) + (y-size (window-configuration/root-y-size configuration)) + (frame (screen-root-window screen))) + (if (not (and (= x-size (window-x-size frame)) + (= y-size (window-y-size frame)))) + (set-editor-frame-size! frame x-size y-size))) + (let ((converted-windows '()) + (need-buffers '())) + (let loop + ((window (screen-window0 screen)) + (saved-window (window-configuration/root-window configuration))) + (if (saved-combination? saved-window) + (let ((vertical? (saved-combination/vertical? saved-window))) + (let child-loop + ((window window) + (children (saved-combination/children saved-window))) + (let ((new + ((if vertical? + window-split-vertically! + window-split-horizontally!) + window + (caar children)))) + (loop window (cdar children)) + (if (null? (cddr children)) + (loop new (cdadr children)) + (child-loop new (cdr children)))))) + (let ((buffer (saved-window/buffer saved-window))) + (if (buffer-alive? buffer) + (begin + (%set-buffer-point! buffer + (saved-window/point saved-window)) + (select-buffer-no-record buffer window) + (let ((mark (saved-window/mark saved-window))) + (if mark (push-buffer-mark! buffer mark))) + (set-window-start-mark! + window + (saved-window/start-mark saved-window) + #t)) + (set! need-buffers (cons window need-buffers))) + (set! converted-windows + (cons (cons saved-window window) converted-windows))))) + (for-each (lambda (window) + (let ((buffer (other-buffer #f))) + (if buffer + (select-buffer-no-record buffer window)))) + need-buffers) + (let ((convert-window + (lambda (saved-window) + (let ((association (assq saved-window converted-windows))) + (and association (cdr association)))))) + (let ((window + (window-configuration/selected-window configuration))) + (if window + (let ((window (convert-window window))) + (without-interrupts + (lambda () (screen-select-window! screen window)))))) + (let ((window (window-configuration/cursor-window configuration))) + (if window + (let ((window (convert-window window))) + (without-interrupts + (lambda () (screen-select-cursor! screen window)))))) + (let ((window + (window-configuration/minibuffer-scroll-window + configuration))) + (if window + (weak-set-car! *minibuffer-scroll-window* + (convert-window window))))))))) + +(define (with-saved-configuration thunk) + (let ((screen (selected-screen))) + (let ((configuration (screen-window-configuration screen))) + (fluid-let ((restore-saved-continuation? #t)) + (dynamic-wind + (lambda () unspecific) + thunk + (lambda () + (if restore-saved-continuation? + (set-screen-window-configuration! screen configuration)))))))) + +(define (dont-restore-saved-configuration) + ;; This conditional will signal an error if this procedure is called + ;; outside the dynamic context of WITH-SAVED-CONFIGURATION. + (if restore-saved-continuation? + (set! restore-saved-continuation? #f)) + unspecific) + +(define restore-saved-continuation?) \ No newline at end of file diff --git a/edwin/bufinp.scm b/edwin/bufinp.scm new file mode 100644 index 0000000..48885f8 --- /dev/null +++ b/edwin/bufinp.scm @@ -0,0 +1,116 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Input Ports + +(declare (usual-integrations)) + +(define (with-input-from-mark mark thunk #!optional receiver) + (let ((port (make-buffer-input-port mark (group-end mark)))) + (let ((value + (parameterize ((current-input-port port)) + (thunk)))) + (if (default-object? receiver) + value + (receiver value (input-port/mark port)))))) + +(define (with-input-from-region region thunk) + (parameterize ((current-input-port + (make-buffer-input-port (region-start region) + (region-end region)))) + (thunk))) + +(define (call-with-input-mark mark procedure) + (procedure (make-buffer-input-port mark (group-end mark)))) + +(define (call-with-input-region region procedure) + (procedure + (make-buffer-input-port (region-start region) (region-end region)))) + +(define (make-buffer-input-port start end) + ;; This uses indices, so it can only be used locally + ;; where there is no buffer-modification happening. + (make-port buffer-input-port-type + (make-bstate (mark-group start) + (mark-index start) + (mark-index end) + (mark-index start)))) + +(define (input-port/mark port) + (let ((operation (textual-port-operation port 'BUFFER-MARK))) + (if (not operation) + (error:bad-range-argument port 'INPUT-PORT/MARK)) + (operation port))) + +(define-structure bstate + (group #f read-only #t) + (start #f read-only #t) + (end #f read-only #t) + (index #f)) + +(define buffer-input-port-type + (make-port-type + `((BUFFER-MARK + ,(lambda (port) + (let ((state (port/state port))) + (make-mark (bstate-group state) + (bstate-index state))))) + (CHAR-READY? + ,(lambda (port) + (let ((state (port/state port))) + (fix:< (bstate-index state) + (bstate-end state))))) + (PEEK-CHAR + ,(lambda (port) + (let ((state (port/state port))) + (let ((index (bstate-index state))) + (if (fix:< index (bstate-end state)) + (group-right-char (bstate-group state) index) + (eof-object)))))) + (READ-CHAR + ,(lambda (port) + (let ((state (port/state port))) + (let ((index (bstate-index state))) + (if (fix:< index (bstate-end state)) + (let ((char (group-right-char (bstate-group state) index))) + (set-bstate-index! state (fix:+ index 1)) + char) + (eof-object)))))) + (UNREAD-CHAR + ,(lambda (port char) + (let ((state (port/state port))) + (let ((index (bstate-index state))) + (if (fix:<= index (bstate-start state)) + (error "No character to unread:" port)) + (if (not (char=? (group-left-char (bstate-group state) index) + char)) + (error "Incorrect char being unread:" char)) + (set-bstate-index! state (fix:- index 1)))))) + (WRITE-SELF + ,(lambda (port output) + (write-string " from buffer at " output) + (write (input-port/mark port) output)))) + #f)) \ No newline at end of file diff --git a/edwin/bufmnu.scm b/edwin/bufmnu.scm new file mode 100644 index 0000000..1518061 --- /dev/null +++ b/edwin/bufmnu.scm @@ -0,0 +1,432 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Menu + +(declare (usual-integrations)) + +(define-variable buffer-menu-kill-on-quit + "If not false, kill the *Buffer-List* buffer when leaving it." + #f + boolean?) + +(define-command list-buffers + "Display a list of names of existing buffers. +Inserts it in buffer *Buffer-List* and displays that. +Note that buffers with names starting with spaces are omitted. +Non-null optional arg FILES-ONLY? means mention only file buffers. + +The M column contains a * for buffers that are modified. +The R column contains a % for buffers that are read-only." + "P" + (lambda (files-only?) + (pop-up-buffer (update-buffer-list files-only?) #f))) + +(define-command buffer-menu + "Make a menu of buffers so you can save, delete or select them. +With argument, show only buffers that are visiting files. +Type ? after invocation to get help on commands available. +Type q immediately to make the buffer menu go away." + "P" + (lambda (files-only?) + (pop-up-buffer (update-buffer-list files-only?) #t) + (message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help."))) + +(define (update-buffer-list files-only?) + (let ((buffer (temporary-buffer "*Buffer-List*"))) + (set-buffer-major-mode! buffer (ref-mode-object buffer-menu)) + (buffer-put! buffer 'REVERT-BUFFER-FILES-ONLY? files-only?) + (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-buffer-menu) + (fill-buffer-menu! buffer files-only?) + buffer)) + +(define (revert-buffer-menu buffer dont-use-auto-save? dont-confirm?) + dont-use-auto-save? dont-confirm? ;ignore + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?)) + buffer) + +(define (fill-buffer-menu! buffer files-only?) + (let ((buffers (buffer-list)) + (hide-buffer? + (lambda (buffer) + (or (minibuffer? buffer) + (and files-only? + (not (buffer-pathname buffer))))))) + (let ((wn 8) + (ws 5) + (wm 8)) + (for-each + (lambda (buffer) + (if (not (hide-buffer? buffer)) + (begin + (let ((w (string-length (buffer-name buffer)))) + (if (> w wn) + (set! wn w))) + (let ((w + (string-length + (number->string + (group-length (buffer-group buffer)))))) + (if (> w ws) + (set! ws w))) + (let ((w + (string-length + (mode-display-name (buffer-major-mode buffer))))) + (if (> w wm) + (set! wm w)))))) + buffers) + (call-with-output-mark (buffer-point buffer) + (lambda (port) + (let ((write-line + (lambda (k m r buffer size mode file) + (write-string k port) + (write-string m port) + (write-string r port) + (write-string " " port) + (write-string (string-pad-right buffer wn) port) + (write-string " " port) + (write-string (string-pad-left size ws) port) + (write-string " " port) + (write-string (string-pad-right mode wm) port) + (write-string " " port) + (write-string file port) + (newline port)))) + (write-line " " "M" "R" "Buffer" "Size" "Mode" "File") + (write-line " " "-" "-" "------" "----" "----" "----") + (let ((current (current-buffer))) + (for-each + (lambda (buffer) + (if (not (hide-buffer? buffer)) + (write-line + (if (eq? buffer current) "." " ") + (if (buffer-modified? buffer) "*" " ") + (if (buffer-writeable? buffer) " " "%") + (buffer-name buffer) + (number->string (group-length (buffer-group buffer))) + (mode-display-name (buffer-major-mode buffer)) + (let ((truename (buffer-truename buffer))) + (if truename + (->namestring truename) + ""))))) + buffers))))))) + (set-buffer-point! buffer (line-start (buffer-start buffer) 2)) + (set-buffer-read-only! buffer)) + +(define-major-mode buffer-menu read-only-noarg "Buffer Menu" + "Major mode for editing a list of buffers. +Each line describes one of the buffers in Emacs. +Letters do not insert themselves; instead, they are commands. +m -- mark buffer to be displayed. +q -- select buffer of line point is on. + Also show buffers marked with m in other windows. +1 -- select that buffer in full-screen window. +2 -- select that buffer in one window, + together with buffer selected before this one in another window. +f -- select that buffer in place of the buffer menu buffer. +o -- select that buffer in another window, + so the buffer menu buffer remains visible in its window. +~ -- clear modified-flag on that buffer. +s -- mark that buffer to be saved, and move down. +d or k -- mark that buffer to be deleted, and move down. +C-d -- mark that buffer to be deleted, and move up. +x -- delete or save marked buffers. +u -- remove all kinds of marks from current line. +Delete -- back up a line and remove marks." + (lambda (buffer) + (local-set-variable! truncate-lines #t buffer) + (event-distributor/invoke! (ref-variable buffer-menu-mode-hook buffer) + buffer))) + +(define-variable buffer-menu-mode-hook + "An event distributor that is invoked when entering Buffer-menu mode." + (make-event-distributor)) + +(define-key 'buffer-menu #\m 'buffer-menu-mark) +(define-key 'buffer-menu #\q 'buffer-menu-quit) +(define-key 'buffer-menu #\1 'buffer-menu-1-window) +(define-key 'buffer-menu #\2 'buffer-menu-2-window) +(define-key 'buffer-menu #\f 'buffer-menu-this-window) +(define-key 'buffer-menu #\o 'buffer-menu-other-window) +(define-key 'buffer-menu #\~ 'buffer-menu-not-modified) +(define-key 'buffer-menu #\s 'buffer-menu-save) +(define-key 'buffer-menu #\d 'buffer-menu-delete) +(define-key 'buffer-menu #\k 'buffer-menu-delete) +(define-key 'buffer-menu #\c-d 'buffer-menu-delete-backwards) +(define-key 'buffer-menu #\c-k 'buffer-menu-delete) +(define-key 'buffer-menu #\x 'buffer-menu-execute) +(define-key 'buffer-menu #\u 'buffer-menu-unmark) +(define-key 'buffer-menu #\rubout 'buffer-menu-backup-unmark) +(define-key 'buffer-menu #\space 'buffer-menu-next-line) +(define-key 'buffer-menu #\c-\] 'buffer-menu-abort) +(define-key 'buffer-menu #\? 'describe-mode) + +(define-command buffer-menu-mark + "Mark buffer on this line for being displayed by \\[buffer-menu-quit] command." + "p" + (lambda (argument) + (set-multiple-marks! 0 #\> argument))) + +(define-command buffer-menu-quit + "Select this line's buffer; also display buffers marked with >. +You can mark buffers with the \\[buffer-menu-mark] command." + () + (lambda () + (let ((lstart (current-lstart)) + (window (current-window))) + (let ((menu (window-buffer window)) + (buffer (buffer-menu-buffer lstart)) + (others (map buffer-menu-buffer (find-buffers-marked 0 #\>)))) + (if (and (ref-variable preserve-window-arrangement) + (null? others)) + (buffer-menu-select menu buffer #f) + (begin + (delete-other-windows window) + (buffer-menu-select menu buffer (memq menu others)) + (let ((height (max (quotient (1+ (window-y-size window)) + (1+ (length others))) + (1+ (ref-variable window-min-height))))) + (define (loop window buffers) + (let ((new (window-split-vertically! window height))) + (if new + (begin + (select-buffer (car buffers) new) + (loop new (cdr buffers)))))) + (loop window others)))))) + (clear-message))) + +(define-command buffer-menu-1-window + "Select this line's buffer, alone, in full screen." + () + (lambda () + (let ((window (current-window))) + (delete-other-windows window) + (buffer-menu-select (window-buffer window) + (buffer-menu-buffer (current-lstart)) + #f)) + (clear-message))) + +(define-command buffer-menu-2-window + "Select this line's buffer, with previous buffer in second window." + () + (lambda () + (buffer-menu-select (window-buffer (current-window)) + (buffer-menu-buffer (current-lstart)) + #f) + (with-variable-value! (ref-variable-object pop-up-windows) #t + (lambda () + (pop-up-buffer (previous-buffer) #f))) + (clear-message))) + +(define-command buffer-menu-this-window + "Select this line's buffer." + () + (lambda () + (buffer-menu-find select-buffer))) + +(define-command buffer-menu-other-window + "Select this line's buffer in another window." + () + (lambda () + (buffer-menu-find select-buffer-other-window))) + +(define (buffer-menu-find select-buffer) + (let ((buffer (buffer-menu-buffer (current-lstart)))) + (if (not (eq? (current-buffer) buffer)) + (select-buffer buffer))) + (clear-message)) + +(define-command buffer-menu-not-modified + "Mark buffer on this line as unmodified (no changes to save)." + () + (lambda () + (buffer-not-modified! (buffer-menu-buffer (current-lstart))) + (let ((lstart (current-lstart))) + (if (char=? #\* (buffer-menu-mark lstart 1)) + (set-buffer-menu-mark! lstart 1 #\Space))))) + +(define-command buffer-menu-save + "Mark buffer on this line to be saved by \\[buffer-menu-execute] command." + "p" + (lambda (argument) + (set-multiple-marks! 1 #\S argument))) + +(define-command buffer-menu-delete + "Mark buffer on this line to be killed by \\[buffer-menu-execute] command." + "p" + (lambda (argument) + (set-multiple-marks! 0 #\D argument))) + +(define-command buffer-menu-delete-backwards + "Mark buffer on this line to be killed by \\[buffer-menu-execute] command +and then move up one line." + "p" + (lambda (argument) + (do ((i 0 (+ i 1))) + ((>= i argument)) + (set-buffer-menu-mark! (current-lstart) 0 #\D) + (set-current-point! (previous-lstart))))) + +(define-command buffer-menu-execute + "Save and/or Kill buffers marked with \\[buffer-menu-save] or \\[buffer-menu-delete]." + () + (lambda () + (buffer-menu-save-and-kill!))) + +(define-command buffer-menu-unmark + "Remove all marks from this line." + () + (lambda () + (let ((lstart (mark-right-inserting (current-lstart)))) + (let ((buffer (buffer-menu-buffer lstart))) + (set-buffer-menu-mark! lstart 0 #\Space) + (set-buffer-menu-mark! lstart 1 + (if (buffer-modified? buffer) #\* #\Space)))) + (set-current-point! (next-lstart)))) + +(define-command buffer-menu-backup-unmark + "Remove all marks from the previous line." + () + (lambda () + (set-current-point! (previous-lstart)) + ((ref-command buffer-menu-unmark)) + (set-current-point! (previous-lstart)))) + +(define-command buffer-menu-next-line + "Move down to the next line." + "p" + (lambda (argument) + (set-current-point! (line-start (current-point) argument 'BEEP)))) + +(define-command buffer-menu-abort + "Abort buffer menu edit." + () + (lambda () + (kill-buffer-interactive (current-buffer)) + (clear-message))) + +(define (buffer-menu-select menu buffer needed?) + (select-buffer buffer) + (if (not (or (eq? menu buffer) needed?)) + (if (ref-variable buffer-menu-kill-on-quit) + (kill-buffer-interactive menu) + (bury-buffer menu)))) + +(define (buffer-menu-save-and-kill!) + (for-each buffer-menu-save! (find-buffers-marked 1 #\S)) + (for-each buffer-menu-kill! (find-buffers-marked 0 #\D))) + +(define (buffer-menu-save! lstart) + (save-buffer (buffer-menu-buffer lstart) #f) + (set-buffer-menu-mark! lstart 1 #\space)) + +(define (buffer-menu-kill! lstart) + (define (erase-line) + (with-read-only-defeated lstart + (lambda () + (delete-string lstart (line-start lstart 1))))) + (let ((buffer (find-buffer (buffer-menu-buffer-name lstart)))) + (cond ((not buffer) (erase-line)) + ((not (eq? buffer (current-buffer))) + (kill-buffer-interactive buffer) + (erase-line))))) + +(define (buffer-menu-buffer lstart) + (let ((name (buffer-menu-buffer-name lstart))) + (or (find-buffer name) + (editor-error "No buffer named '" name "'")))) + +(define (buffer-menu-buffer-name lstart) + (guarantee-buffer-line lstart) + (buffer-line-name lstart)) + +(define (current-lstart) + (line-start (current-point) 0)) + +(define (next-lstart) + (line-start (current-point) 1 'ERROR)) + +(define (previous-lstart) + (line-start (current-point) -1 'ERROR)) + +(define (set-multiple-marks! column char n) + (dotimes n + (lambda (i) + i ;ignore + (set-buffer-menu-mark! (current-lstart) column char) + (set-current-point! (next-lstart))))) + +(define (guarantee-buffer-line lstart) + (if (not (buffer-line? lstart)) + (editor-error "No buffer on this line"))) + +(define (buffer-line? lstart) + (and (mark>= lstart (line-start (group-start lstart) 2)) + (not (mark= lstart (line-end lstart 0))))) + +(define (buffer-line-name lstart) + (let ((start (mark+ lstart 4))) + (extract-string + start + (skip-chars-backward + " \t" + (let ((end (line-end start 0))) + (or (re-search-forward "\t\\| " start end) + end)))))) + +(define (buffer-menu-mark lstart column) + (guarantee-buffer-line lstart) + (mark-right-char (mark+ lstart column))) + +(define (set-buffer-menu-mark! lstart column char) + (guarantee-buffer-line lstart) + (let ((m (mark+ lstart column))) + (with-read-only-defeated m + (lambda () + (delete-right-char m) + (region-insert-char! m char))))) + +(define (list-buffers-format k m r buffer size mode file) + (let* ((result + (string-append k m r " " (pad-on-right-to buffer 13) " " size)) + (result (string-append (pad-on-right-to result 24) " " mode))) + (string-append (pad-on-right-to result 39) " " file))) + +(define list-buffers-header + (string-append + (list-buffers-format " " "M" "R" "Buffer" "Size" "Mode" "File") + "\n" + (list-buffers-format " " "-" "-" "------" "----" "----" "----") + "\n")) + +(define (find-buffers-marked column char) + (define (loop lstart) + (let ((next (line-start lstart 1))) + (cond ((not next) '()) + ((char=? (mark-right-char (mark+ lstart column)) char) + (cons (mark-permanent! lstart) (loop next))) + (else (loop next))))) + (loop (line-start (buffer-start (current-buffer)) 2))) \ No newline at end of file diff --git a/edwin/bufout.scm b/edwin/bufout.scm new file mode 100644 index 0000000..2b5a23b --- /dev/null +++ b/edwin/bufout.scm @@ -0,0 +1,110 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Output Ports +;;; Package: (edwin buffer-output-port) + +(declare (usual-integrations)) + +(define (with-output-to-mark mark thunk) + (call-with-output-mark mark + (lambda (port) + (parameterize ((current-output-port port)) + (thunk))))) + +(define (call-with-output-mark mark procedure) + (let ((port (mark->output-port mark))) + (let ((value (procedure port))) + (operation/close port) + value))) + +(define (mark->output-port mark #!optional buffer) + (make-port mark-output-port-type + (cons (mark-left-inserting-copy mark) + (if (default-object? buffer) + #f + buffer)))) + +(define (output-port->mark port) + (mark-temporary-copy (port/mark port))) + +(define-integrable (port/mark port) + (car (port/state port))) + +(define-integrable (port/buffer port) + (cdr (port/state port))) + +(define (operation/flush-output port) + (let ((mark (port/mark port)) + (buffer (port/buffer port))) + (if buffer + (for-each (if (mark= mark (buffer-point buffer)) + (lambda (window) + (set-window-point! window mark) + (window-direct-update! window #f)) + (lambda (window) + (window-direct-update! window #f))) + (buffer-windows buffer))))) + +(define (operation/write-self port output) + (write-string " to buffer at " output) + (write (port/mark port) output)) + +(define (operation/write-char port char) + (guarantee 8-bit-char? char) + (region-insert-char! (port/mark port) char) + 1) + +(define (operation/write-substring port string start end) + (if (string? string) + (begin + (region-insert-substring! (port/mark port) string start end) + (fix:- end start)) + (generic-port-operation:write-substring port string start end))) + +(define (operation/line-start? port) + (line-start? (port/mark port))) + +(define (operation/fresh-line port) + (if (not (operation/line-start? port)) + (region-insert-newline! (port/mark port)))) + +(define (operation/close port) + (mark-temporary! (port/mark port))) + +(define (operation/x-size port) + (mark-x-size (port/mark port))) + +(define mark-output-port-type + (make-port-type `((CLOSE ,operation/close) + (FLUSH-OUTPUT ,operation/flush-output) + (FRESH-LINE ,operation/fresh-line) + (LINE-START? ,operation/line-start?) + (WRITE-CHAR ,operation/write-char) + (WRITE-SELF ,operation/write-self) + (WRITE-SUBSTRING ,operation/write-substring) + (X-SIZE ,operation/x-size)) + #f)) \ No newline at end of file diff --git a/edwin/bufset.scm b/edwin/bufset.scm new file mode 100644 index 0000000..533b5fe --- /dev/null +++ b/edwin/bufset.scm @@ -0,0 +1,106 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Set Abstraction + +(declare (usual-integrations)) + +(define-structure (bufferset (constructor %make-bufferset)) + buffer-list + (names #f read-only #t)) + +(define (make-bufferset initial-buffer) + (%make-bufferset (list initial-buffer) + (let ((names (make-string-table 16 false))) + (string-table-put! names + (buffer-name initial-buffer) + initial-buffer) + names))) + +(define (bufferset-select-buffer! bufferset buffer) + (if (memq buffer (bufferset-buffer-list bufferset)) + (set-bufferset-buffer-list! + bufferset + (cons buffer (delq! buffer (bufferset-buffer-list bufferset))))) + unspecific) + +(define (bufferset-bury-buffer! bufferset buffer) + (if (memq buffer (bufferset-buffer-list bufferset)) + (set-bufferset-buffer-list! + bufferset + (append! (delq! buffer (bufferset-buffer-list bufferset)) + (list buffer)))) + unspecific) + +(define (bufferset-guarantee-buffer! bufferset buffer) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (begin + (string-table-put! (bufferset-names bufferset) + (buffer-name buffer) + buffer) + (set-bufferset-buffer-list! bufferset + (append! (bufferset-buffer-list bufferset) + (list buffer))))) + unspecific) + +(define (bufferset-find-buffer bufferset name) + (string-table-get (bufferset-names bufferset) name)) + +(define (bufferset-create-buffer bufferset name) + (if (bufferset-find-buffer bufferset name) + (error "Attempt to re-create buffer" name)) + (let ((buffer + (make-buffer name + (ref-variable editor-default-mode) + (if within-editor? + (buffer-default-directory (current-buffer)) + (working-directory-pathname))))) + (string-table-put! (bufferset-names bufferset) name buffer) + (set-bufferset-buffer-list! + bufferset + (append! (bufferset-buffer-list bufferset) (list buffer))) + buffer)) + +(define (bufferset-find-or-create-buffer bufferset name) + (or (bufferset-find-buffer bufferset name) + (bufferset-create-buffer bufferset name))) + +(define (bufferset-kill-buffer! bufferset buffer) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (error "Attempt to kill unknown buffer" buffer)) + (set-bufferset-buffer-list! bufferset + (delq! buffer (bufferset-buffer-list bufferset))) + (string-table-remove! (bufferset-names bufferset) (buffer-name buffer))) + +(define (bufferset-rename-buffer bufferset buffer new-name) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (error "Attempt to rename unknown buffer" buffer)) + (if (bufferset-find-buffer bufferset new-name) + (error "Attempt to rename buffer to existing buffer name" new-name)) + (let ((names (bufferset-names bufferset))) + (string-table-remove! names (buffer-name buffer)) + (set-buffer-name! buffer new-name) + (string-table-put! names new-name buffer))) \ No newline at end of file diff --git a/edwin/bufwfs.scm b/edwin/bufwfs.scm new file mode 100644 index 0000000..53660e7 --- /dev/null +++ b/edwin/bufwfs.scm @@ -0,0 +1,432 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Windows: Fill and Scroll + +(declare (usual-integrations)) + +(define (fill-top window start) + (let ((group (%window-group window)) + (start-column 0) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window))) + (let loop + ((outline (o3-outline start)) + (index (o3-index start)) + (y (o3-y start))) + (if (fix:<= y 0) + (begin + (set-o3-outline! start outline) + (set-o3-index! start index) + (set-o3-y! start y)) + (let* ((end-index (fix:- index 1)) + (start-index (%window-line-start-index window end-index)) + (end-column + (group-columns group start-index end-index + start-column tab-width + char-image-strings)) + (y-size (column->y-size end-column x-size truncate-lines?)) + (y (fix:- y y-size))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window (fix:- end-index start-index) y-size + false outline) + start-index + y)))))) + +(define (fill-middle window top-end bot-start) + (let ((group (%window-group window)) + (start-column 0) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (bot-start-index (o3-index bot-start))) + (let loop + ((outline (o3-outline top-end)) + (index (o3-index top-end)) + (y (o3-y top-end))) + (let ((start-index (fix:+ index 1))) + (if (fix:< start-index bot-start-index) + (let ((index&column + (group-line-columns group start-index bot-start-index + start-column tab-width + char-image-strings))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((y-size + (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window + (fix:- end-index start-index) + y-size + outline + false) + end-index + (fix:+ y y-size))))) + (begin + (if (not (fix:= start-index bot-start-index)) + (error "Mismatched indexes:" start-index bot-start-index)) + (if (not (fix:= y (o3-y bot-start))) + (error "Mismatched y coordinates:" y (o3-y bot-start))) + (set-outline-next! outline (o3-outline bot-start)) + (set-outline-previous! (o3-outline bot-start) outline))))))) + +(define (fill-bottom window end) + (let ((group (%window-group window)) + (start-column 0) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (y-size (window-y-size window)) + (group-end (%window-group-end-index window))) + (let loop + ((outline (o3-outline end)) + (index (o3-index end)) + (y (o3-y end))) + (if (or (fix:>= index group-end) (fix:>= y y-size)) + (begin + (set-o3-outline! end outline) + (set-o3-index! end index) + (set-o3-y! end y)) + (let ((start-index (fix:+ index 1))) + (let ((index&column + (group-line-columns group start-index group-end + start-column tab-width + char-image-strings))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((y-size + (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window + (fix:- end-index start-index) + y-size + outline + false) + end-index + (fix:+ y y-size)))))))))) + +(define (generate-outlines window start end) + (let ((group (%window-group window)) + (start-column 0) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (y-size (window-y-size window)) + (group-end (%window-group-end-index window))) + (let loop ((outline false) (start-index (o3-index start)) (y (o3-y start))) + (let ((index&column + (group-line-columns group start-index group-end + start-column tab-width char-image-strings))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((line-y (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y line-y) + (let ((outline* + (make-outline window + (fix:- end-index start-index) + line-y + outline + false)) + (y (fix:+ y line-y))) + (if (not outline) + (set-o3-outline! start outline*)) + (if (or (fix:>= end-index group-end) (fix:>= y y-size)) + (begin + (set-o3-outline! end outline*) + (set-o3-index! end end-index) + (set-o3-y! end y)) + (loop outline* (fix:+ end-index 1) y))))))))) + +(define (draw-region! window group start-index end-index start-column + y y-size) + (clip-window-region-1 + (fix:- (%window-saved-yl window) y) (fix:- (%window-saved-yu window) y) + y-size + (lambda (yl yu) + (let ((screen (%window-saved-screen window)) + (xl (fix:+ (%window-saved-x-start window) + (%window-saved-xl window))) + (xu (fix:+ (%window-saved-x-start window) + (%window-saved-xu window))) + (y-start (fix:+ (%window-saved-y-start window) y)) + (char-image-strings (%window-char-image-strings window)) + (truncate-lines? (%window-truncate-lines? window)) + (tab-width (%window-tab-width window)) + (results substring-image-results)) + (let ((xm (fix:- xu 1)) + (yl (fix:+ y-start yl)) (yu (fix:+ y-start yu))) + (let ((columns (fix:- xm xl))) + (let line-loop + ((index start-index) + (column-offset (fix:- start-column xl)) + (partial 0) + (y y-start)) + (if (fix:< y yu) + (let loop + ((column-offset column-offset) + (xl* xl) + (index index)) + (let ((end-index* + (or (next-specific-property-change group + index + end-index + 'HIGHLIGHTED) + end-index)) + ;; If line is clipped off top of window, draw it + ;; anyway so that index and column calculations + ;; get done. Use first visible line for image + ;; output so as to avoid consing a dummy image + ;; buffer. + (line + (screen-get-output-line + screen + (if (fix:< y yl) yl y) + xl* xu + (get-text-property group index 'HIGHLIGHTED #f)))) + (let ((fill-line + (lambda (index xl*) + (group-image! group index end-index* + line xl* xm + tab-width column-offset results + char-image-strings) + (cond ((fix:= (vector-ref results 0) end-index) + (let ((xl* (vector-ref results 1))) + (let ((line + (screen-get-output-line + screen + (if (fix:< y yl) yl y) + xl* xu false))) + (do ((x xl* (fix:+ x 1))) + ((fix:= x xu)) + (string-set! line x #\space))))) + ((fix:= (vector-ref results 0) end-index*) + (loop (fix:+ column-offset + (fix:- (vector-ref results 1) + xl*)) + (vector-ref results 1) + (vector-ref results 0))) + (truncate-lines? + (string-set! line xm #\$)) + (else + (string-set! line xm #\\) + (line-loop (vector-ref results 0) + (fix:+ column-offset columns) + (vector-ref results 2) + (fix:+ y 1))))))) + (if (fix:= partial 0) + (fill-line index xl*) + (begin + (partial-image! (group-right-char group index) + partial + line xl* xm + tab-width + char-image-strings) + (if (fix:> partial columns) + (begin + (string-set! line xm #\\) + (line-loop index + (fix:+ column-offset columns) + (fix:- partial columns) + (fix:+ y 1))) + (fill-line (fix:+ index 1) + (fix:+ xl* partial)))))))))))))))) + +(define (scroll-lines-up window start end new-start-y) + (if (fix:>= new-start-y 0) + (%scroll-lines-up window start end new-start-y) + (let ((start-outline (o3-outline start)) + (amount (fix:- (o3-y start) new-start-y))) + (if (if (fix:> (o3-y end) (window-y-size window)) + (let ((outline (o3-outline end))) + (or (eq? start-outline outline) + (fix:<= (fix:- (o3-y end) (outline-y-size outline)) + amount))) + (fix:<= (o3-y end) amount)) + (begin + (deallocate-outlines! window start-outline (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false) + (begin + (if (fix:> (o3-y end) (window-y-size window)) + (let ((outline (o3-outline end))) + (set-o3-outline! end (outline-previous outline)) + (set-o3-index! + end + (fix:- (o3-index end) + (fix:+ (outline-index-length outline) 1))) + (set-o3-y! end (fix:- (o3-y end) (outline-y-size outline))) + (deallocate-outlines! window outline outline))) + (let loop + ((outline start-outline) + (index (o3-index start)) + (new-start-y new-start-y)) + (let ((new-end-y (fix:+ new-start-y (outline-y-size outline)))) + (cond ((fix:< new-end-y 0) + (loop (outline-next outline) + (fix:+ index + (fix:+ (outline-index-length outline) 1)) + new-end-y)) + ((fix:> new-end-y 0) + (set-o3-outline! start outline) + (set-o3-index! start index) + (set-o3-y! start (fix:+ new-start-y amount)) + (if (not (eq? start-outline outline)) + (deallocate-outlines! window + start-outline + (outline-previous outline))) + (%scroll-lines-up window start end new-start-y)) + (else + (set-o3-outline! start (outline-next outline)) + (set-o3-index! + start + (fix:+ (fix:+ index (outline-index-length outline)) + 1)) + (set-o3-y! start amount) + (deallocate-outlines! window start-outline outline) + (%scroll-lines-up window start end new-end-y)))))))))) + +(define (%scroll-lines-up window start end new-start-y) + (let ((yl (o3-y start)) + (yu (o3-y end))) + (let ((amount (fix:- yl new-start-y))) + (if (and (fix:< yl (%window-saved-yu window)) + (fix:< (%window-saved-yl window) yu) + (let ((yl (fix:max (%window-saved-yl window) new-start-y)) + (yu (fix:min (%window-saved-yu window) yu))) + (and (fix:< amount (fix:- yu yl)) + (screen-scroll-lines-up + (%window-saved-screen window) + (fix:+ (%window-saved-xl window) + (%window-saved-x-start window)) + (fix:+ (%window-saved-xu window) + (%window-saved-x-start window)) + (fix:+ yl (%window-saved-y-start window)) + (fix:+ yu (%window-saved-y-start window)) + amount)))) + (begin + (set-o3-y! start new-start-y) + (set-o3-y! end (fix:- yu amount)) + true) + (begin + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false))))) + +(define (scroll-lines-down window start end new-start-y) + (let ((y-size (window-y-size window))) + (if (or (fix:>= new-start-y y-size) + (and (fix:< (o3-y start) 0) + (eq? (o3-outline start) (o3-outline end)))) + (begin + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false) + (let ((new-start-y + (if (fix:< (o3-y start) 0) + (let ((outline (o3-outline start))) + (let ((y-size (outline-y-size outline))) + (set-o3-outline! start (outline-next outline)) + (set-o3-index! + start + (fix:+ (o3-index start) + (fix:+ (outline-index-length outline) 1))) + (set-o3-y! start (fix:+ (o3-y start) y-size)) + (deallocate-outlines! window outline outline) + (fix:+ new-start-y y-size))) + new-start-y))) + (let loop + ((outline (o3-outline start)) + (start-index (o3-index start)) + (start-y new-start-y)) + (let ((end-y (fix:+ start-y (outline-y-size outline)))) + (cond ((fix:>= end-y y-size) + (if (not (eq? outline (o3-outline end))) + (deallocate-outlines! window + (outline-next outline) + (o3-outline end))) + (set-o3-outline! end outline) + (set-o3-index! end + (fix:+ start-index + (outline-index-length outline))) + (set-o3-y! end + (fix:- end-y + (fix:- new-start-y (o3-y start))))) + ((not (eq? outline (o3-outline end))) + (loop (outline-next outline) + (fix:+ (fix:+ start-index + (outline-index-length outline)) + 1) + end-y))))) + (%scroll-lines-down window start end new-start-y))))) + +(define (%scroll-lines-down window start end new-start-y) + (let ((yl (o3-y start)) + (yu (o3-y end))) + (let ((amount (fix:- new-start-y yl))) + (if (and (fix:< yl (%window-saved-yu window)) + (fix:< (%window-saved-yl window) yu) + (let ((yl (fix:max (%window-saved-yl window) yl)) + (yu + (fix:min (%window-saved-yu window) (fix:+ yu amount)))) + (and (fix:< amount (fix:- yu yl)) + (screen-scroll-lines-down + (%window-saved-screen window) + (fix:+ (%window-saved-xl window) + (%window-saved-x-start window)) + (fix:+ (%window-saved-xu window) + (%window-saved-x-start window)) + (fix:+ yl (%window-saved-y-start window)) + (fix:+ yu (%window-saved-y-start window)) + amount)))) + (begin + (set-o3-y! start new-start-y) + (set-o3-y! end (fix:+ yu amount)) + true) + (begin + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false))))) \ No newline at end of file diff --git a/edwin/bufwin.scm b/edwin/bufwin.scm new file mode 100644 index 0000000..c1e84ef --- /dev/null +++ b/edwin/bufwin.scm @@ -0,0 +1,1264 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Windows: Base + +(declare (usual-integrations)) + +;;; The following instance variables contain permanent marks, which +;;; must be copied if they are passed to someone outside the buffer +;;; window abstraction, because they are modified by side-effect. +;;; +;;; current-start-mark +;;; current-end-mark +;;; start-mark +;;; start-line-mark +;;; start-clip-mark +;;; end-clip-mark + +(define-class buffer-window vanilla-window + ( + ;; The buffer being displayed in this window. + buffer + + ;; Caches for the values of buffer-local variables that are needed + ;; for redisplay. + truncate-lines? + tab-width + char-image-strings + + ;; The point marker in this window. + point + + ;; This is the inferior window (of class CURSOR-WINDOW) that + ;; displays the cursor for this window. + cursor-inferior + + ;; This is the inferior window (of class BLANK-WINDOW) that keeps + ;; the bottom of the window clear when there is no text in it. + ;; This is only used when the end of the buffer is visible in the + ;; window. When not in use, it is moved offscreen so the window + ;; clipping will prevent it from being updated. + blank-inferior + + ;; The topmost and bottommost OUTLINE structures for this window, + ;; respectively. If only one line is shown, these are EQ?. + start-outline + end-outline + + ;; A previously allocated OUTLINE structure that is available for + ;; reallocation. Any other free OUTLINE structures are chained to + ;; this one through its NEXT field. + free-outline + + ;; A permanent right-inserting mark at the beginning of the text + ;; line modelled by START-OUTLINE. + current-start-mark + + ;; A permanent left-inserting mark at the end of the text line + ;; modelled by END-OUTLINE. + current-end-mark + + ;; The number of characters on the first line that are invisible, + ;; i.e. off the top of the window. + current-start-delta + + ;; The value of START-PARTIAL for the current window contents. + current-start-partial + + ;; The Y position, relative to the window, of the top edge of + ;; START-OUTLINE. A non-positive number. + current-start-y + + ;; The Y position, relative to the window, of the bottom edge of + ;; END-OUTLINE. A positive number. + current-end-y + + ;; A previously allocated O3 structure that is available for + ;; reallocation. Any other free O3 structures are chained to this + ;; one through its OUTLINE field. + free-o3 + + ;; This is normally #F. However, when the normal display of the + ;; buffer is overridden by a one-line message, as is commonly done + ;; for the typein window, this variable contains the message + ;; string. + override-string + + ;; This permanent mark is the smallest that is visible in the + ;; window. If the window's start is not known, this is #F. + start-mark + + ;; This permanent mark is at the beginning of the line containing + ;; START-MARK. It is #F if START-MARK is. Note that this is the + ;; same as CURRENT-START-MARK at the end of a display update, and + ;; is changed due to point motion and scrolling. + start-line-mark + + ;; This is the Y coordinate of START-LINE-MARK. It is undefined if + ;; START-LINE-MARK is #F, otherwise it is guaranteed to be + ;; non-positive. + start-line-y + + ;; This is the number of columns between START-LINE-MARK + ;; (inclusive) and START-MARK (exclusive). In other words, it is + ;; the starting column of START-MARK. This is undefined if + ;; START-MARK is #F. + start-column + + ;; If the character to the right of START-MARK is completely + ;; visible, this is zero. Otherwise, this is the number of columns + ;; of that character that are visible. This is undefined if + ;; START-MARK is #F. + start-partial + + ;; This contains the buffer's MODIFIED-TICK from the last time that + ;; redisplay completed for this window. + modified-tick + + ;; This contains the daemon that is invoked when the buffer's + ;; display clipping is changed. + clip-daemon + + ;; These variables delimit the region of the buffer that has been + ;; unaffected by clipping since the last display update. If the + ;; clipping has not changed since then, they are #F. + start-clip-mark + end-clip-mark + + ;; This flag is set to #F at the end of a display update, and + ;; subsequently set to a true value if the point has moved, or if + ;; it was inside a changed region, or if it was outside a clipping + ;; region, or any of several other conditions that could possibly + ;; affect the validity of our idea about where point is. However, + ;; there are two possible true values: #T means that the START-MARK + ;; for the window has been recomputed and is known to be correct. + ;; 'SINCE-START-MARK means the new START-MARK has not yet been + ;; computed. + point-moved? + + ;; If true, this flag indicates that the window should be entirely + ;; redrawn at the next display update. + force-redraw? + + ;; These variables record where the last display update drew its + ;; output. SAVED-SCREEN is the screen on which it occurred. + ;; SAVED-X-START and SAVED-Y-START is the position, in the screen's + ;; coordinates, at which the window was located. SAVED-XL, + ;; SAVED-XU, SAVED-YL, and SAVED-YU (window's coordinates) delimit + ;; the rectangular portion of the window that was drawn. + saved-screen + saved-x-start + saved-y-start + saved-xl + saved-xu + saved-yl + saved-yu + + ;; This variable, if not #F, is a procedure that is called at + ;; interesting times to generate a debugging trace. + debug-trace)) + +;;;; Instance Variable Accessors + +(define-integrable (%window-buffer window) + (with-instance-variables buffer-window window () buffer)) + +(define-integrable (%window-group window) + (buffer-group (%window-buffer window))) + +(define-integrable (%set-window-buffer! window buffer*) + (with-instance-variables buffer-window window (buffer*) + (set! buffer buffer*))) + +(define-integrable (%window-truncate-lines? window) + (with-instance-variables buffer-window window () truncate-lines?)) + +(define-integrable (%set-window-truncate-lines?! window truncate-lines?*) + (with-instance-variables buffer-window window (truncate-lines?*) + (set! truncate-lines? truncate-lines?*))) + +(define-integrable (%window-tab-width window) + (with-instance-variables buffer-window window () tab-width)) + +(define-integrable (%set-window-tab-width! window tab-width*) + (with-instance-variables buffer-window window (tab-width*) + (set! tab-width tab-width*))) + +(define-integrable (%window-char-image-strings window) + (with-instance-variables buffer-window window () char-image-strings)) + +(define-integrable (%set-window-char-image-strings! window char-image-strings*) + (with-instance-variables buffer-window window (char-image-strings*) + (set! char-image-strings char-image-strings*))) + +(define-integrable (%window-char->image window char) + (vector-ref (%window-char-image-strings window) + (char->integer char))) + +(define-integrable (%window-point window) + (with-instance-variables buffer-window window () point)) + +(define-integrable (%window-point-index window) + (mark-index (%window-point window))) + +(define-integrable (%set-window-point! window point*) + (with-instance-variables buffer-window window (point*) + (set! point point*))) + +(define (%set-window-point-index! window index) + #| Optimization causes lossage. -- cph + (let ((point (%window-point window))) + (if point + (set-mark-index! point index) + (%set-window-point! window + (make-permanent-mark (%window-group window) + index + #t)))) + |# + (%set-window-point! window + (make-permanent-mark (%window-group window) + index + #t))) + +(define (set-window-point-index! window index) + (%set-window-point-index! window index) + (%set-buffer-point-index! (%window-buffer window) index)) + +(define-integrable (%window-cursor-inferior window) + (with-instance-variables buffer-window window () cursor-inferior)) + +(define-integrable (%set-window-cursor-inferior! window inferior) + (with-instance-variables buffer-window window (inferior) + (set! cursor-inferior inferior))) + +(define-integrable (%window-blank-inferior window) + (with-instance-variables buffer-window window () blank-inferior)) + +(define-integrable (%set-window-blank-inferior! window inferior) + (with-instance-variables buffer-window window (inferior) + (set! blank-inferior inferior))) + +(define-integrable (%window-start-outline window) + (with-instance-variables buffer-window window () start-outline)) + +(define-integrable (%set-window-start-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! start-outline outline))) + +(define-integrable (%window-end-outline window) + (with-instance-variables buffer-window window () end-outline)) + +(define-integrable (%set-window-end-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! end-outline outline))) + +(define-integrable (%window-free-outline window) + (with-instance-variables buffer-window window () free-outline)) + +(define-integrable (%set-window-free-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! free-outline outline))) + +(define-integrable (%window-current-start-mark window) + (with-instance-variables buffer-window window () current-start-mark)) + +(define-integrable (%window-current-start-index window) + (mark-index (%window-current-start-mark window))) + +(define-integrable (%set-window-current-start-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! current-start-mark mark))) + +(define-integrable (%window-current-end-mark window) + (with-instance-variables buffer-window window () current-end-mark)) + +(define-integrable (%window-current-end-index window) + (mark-index (%window-current-end-mark window))) + +(define-integrable (%set-window-current-end-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! current-end-mark mark))) + +(define-integrable (%window-current-start-delta window) + (with-instance-variables buffer-window window () current-start-delta)) + +(define-integrable (%set-window-current-start-delta! window delta) + (with-instance-variables buffer-window window (delta) + (set! current-start-delta delta))) + +(define-integrable (%window-current-start-partial window) + (with-instance-variables buffer-window window () current-start-partial)) + +(define-integrable (%set-window-current-start-partial! window partial) + (with-instance-variables buffer-window window (partial) + (set! current-start-partial partial))) + +(define-integrable (%window-current-start-y window) + (with-instance-variables buffer-window window () current-start-y)) + +(define-integrable (%set-window-current-start-y! window y) + (with-instance-variables buffer-window window (y) + (set! current-start-y y))) + +(define-integrable (%window-current-end-y window) + (with-instance-variables buffer-window window () current-end-y)) + +(define-integrable (%set-window-current-end-y! window y) + (with-instance-variables buffer-window window (y) + (set! current-end-y y))) + +(define-integrable (%window-free-o3 window) + (with-instance-variables buffer-window window () free-o3)) + +(define-integrable (%set-window-free-o3! window o3) + (with-instance-variables buffer-window window (o3) + (set! free-o3 o3))) + +(define-integrable (%window-override-string window) + (with-instance-variables buffer-window window () override-string)) + +(define-integrable (%set-window-override-string! window string) + (with-instance-variables buffer-window window (string) + (set! override-string string))) + +(define-integrable (%window-start-mark window) + (with-instance-variables buffer-window window () start-mark)) + +(define-integrable (%window-start-index window) + (mark-index (%window-start-mark window))) + +(define-integrable (%set-window-start-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! start-mark mark))) + +(define-integrable (%window-start-line-mark window) + (with-instance-variables buffer-window window () start-line-mark)) + +(define-integrable (%window-start-line-index window) + (mark-index (%window-start-line-mark window))) + +(define-integrable (%set-window-start-line-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! start-line-mark mark))) + +(define-integrable (%window-start-line-y window) + (with-instance-variables buffer-window window () start-line-y)) + +(define-integrable (%set-window-start-line-y! window y) + (with-instance-variables buffer-window window (y) + (set! start-line-y y))) + +(define-integrable (%window-start-column window) + (with-instance-variables buffer-window window () start-column)) + +(define-integrable (%set-window-start-column! window column) + (with-instance-variables buffer-window window (column) + (set! start-column column))) + +(define-integrable (%window-start-partial window) + (with-instance-variables buffer-window window () start-partial)) + +(define-integrable (%set-window-start-partial! window partial) + (with-instance-variables buffer-window window (partial) + (set! start-partial partial))) + +(define-integrable (%window-modified-tick window) + (with-instance-variables buffer-window window () modified-tick)) + +(define-integrable (%set-window-modified-tick! window tick) + (with-instance-variables buffer-window window (tick) + (set! modified-tick tick))) + +(define-integrable (%window-start-changes-index window) + (group-start-changes-index (%window-group window))) + +(define-integrable (%window-end-changes-index window) + (group-end-changes-index (%window-group window))) + +(define-integrable (%window-clip-daemon window) + (with-instance-variables buffer-window window () clip-daemon)) + +(define-integrable (%set-window-clip-daemon! window daemon) + (with-instance-variables buffer-window window (daemon) + (set! clip-daemon daemon))) + +(define-integrable (%window-start-clip-mark window) + (with-instance-variables buffer-window window () start-clip-mark)) + +(define-integrable (%window-start-clip-index window) + (mark-index (%window-start-clip-mark window))) + +(define-integrable (%set-window-start-clip-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! start-clip-mark mark))) + +(define-integrable (%window-end-clip-mark window) + (with-instance-variables buffer-window window () end-clip-mark)) + +(define-integrable (%window-end-clip-index window) + (mark-index (%window-end-clip-mark window))) + +(define-integrable (%set-window-end-clip-mark! window mark) + (with-instance-variables buffer-window window (mark) + (set! end-clip-mark mark))) + +(define-integrable (%window-point-moved? window) + (with-instance-variables buffer-window window () point-moved?)) + +(define-integrable (%set-window-point-moved?! window point-moved?*) + (with-instance-variables buffer-window window (point-moved?*) + (set! point-moved? point-moved?*))) + +(define-integrable (%window-force-redraw? window) + (with-instance-variables buffer-window window () force-redraw?)) + +(define-integrable (%set-window-force-redraw?! window force-redraw?*) + (with-instance-variables buffer-window window (force-redraw?*) + (set! force-redraw? force-redraw?*))) + +(define-integrable (%window-saved-screen window) + (with-instance-variables buffer-window window () saved-screen)) + +(define-integrable (%set-window-saved-screen! window screen) + (with-instance-variables buffer-window window (screen) + (set! saved-screen screen))) + +(define-integrable (%window-saved-x-start window) + (with-instance-variables buffer-window window () saved-x-start)) + +(define-integrable (%set-window-saved-x-start! window x-start) + (with-instance-variables buffer-window window (x-start) + (set! saved-x-start x-start))) + +(define-integrable (%window-saved-y-start window) + (with-instance-variables buffer-window window () saved-y-start)) + +(define-integrable (%set-window-saved-y-start! window y-start) + (with-instance-variables buffer-window window (y-start) + (set! saved-y-start y-start))) + +(define-integrable (%window-saved-xl window) + (with-instance-variables buffer-window window () saved-xl)) + +(define-integrable (%set-window-saved-xl! window xl) + (with-instance-variables buffer-window window (xl) + (set! saved-xl xl))) + +(define-integrable (%window-saved-xu window) + (with-instance-variables buffer-window window () saved-xu)) + +(define-integrable (%set-window-saved-xu! window xu) + (with-instance-variables buffer-window window (xu) + (set! saved-xu xu))) + +(define-integrable (%window-saved-yl window) + (with-instance-variables buffer-window window () saved-yl)) + +(define-integrable (%set-window-saved-yl! window yl) + (with-instance-variables buffer-window window (yl) + (set! saved-yl yl))) + +(define-integrable (%window-saved-yu window) + (with-instance-variables buffer-window window () saved-yu)) + +(define-integrable (%set-window-saved-yu! window yu) + (with-instance-variables buffer-window window (yu) + (set! saved-yu yu))) + +(define-integrable (%window-debug-trace window) + (with-instance-variables buffer-window window () debug-trace)) + +(define-integrable (%set-window-debug-trace! window procedure) + (with-instance-variables buffer-window window (procedure) + (set! debug-trace procedure))) + +;;;; Outlines + +(define-structure (outline + (constructor %make-outline) + (print-procedure + (bracketed-print-method 'OUTLINE + (lambda (outline port) + (write-string "index: " port) + (write (outline-index-length outline) port) + (write-string " y: " port) + (write (outline-y-size outline) port))))) + ;; The number of characters in the text line. This is exclusive of + ;; the newlines at the line's beginning and end, if any. + index-length + + ;; The number of screen lines that are occupied by this text line. + y-size + + ;; A pointer to the previous outline structure, the one representing + ;; the text line that appears directly above this line. + previous + + ;; A pointer to the next outline structure, the one representing the + ;; text line that appears directly below this line. + next) + +(define (make-outline window index-length y-size previous next) + (let ((outline + (let ((outline (%window-free-outline window))) + (if (%window-free-outline window) + (begin + (let ((free (outline-next outline))) + (if free (set-outline-previous! free #f)) + (%set-window-free-outline! window free)) + (set-outline-index-length! outline index-length) + (set-outline-y-size! outline y-size) + (set-outline-previous! outline previous) + (set-outline-next! outline next) + outline) + (%make-outline index-length y-size previous next))))) + (if previous (set-outline-next! previous outline)) + (if next (set-outline-previous! next outline)) + outline)) + +(define (deallocate-outlines! window start-outline end-outline) + (let ((free-outline (%window-free-outline window))) + (if (outline-next end-outline) + (set-outline-previous! (outline-next end-outline) #f)) + (set-outline-next! end-outline free-outline) + (if free-outline + (set-outline-previous! free-outline end-outline))) + (if (outline-previous start-outline) + (set-outline-next! (outline-previous start-outline) #f)) + (set-outline-previous! start-outline #f) + (%set-window-free-outline! window start-outline)) + +(define-integrable (outline-last outline) + (do ((outline outline (outline-next outline))) + ((not (outline-next outline)) outline))) + +(define-integrable (outline-end-y outline start-y) + (do ((outline outline (outline-next outline)) + (y start-y (fix:+ y (outline-y-size outline)))) + ((not outline) y))) + +(define-integrable (outline-start-y outline end-y) + (do ((outline outline (outline-previous outline)) + (y end-y (fix:- y (outline-y-size outline)))) + ((not outline) y))) + +(define-structure (o3 + (constructor %make-o3) + (print-procedure + (bracketed-print-method 'O3 + (lambda (o3 port) + (write-string "index: " port) + (write (o3-index o3) port) + (write-string " y: " port) + (write (o3-y o3) port) + (if (outline? (o3-outline o3)) + (begin + (write-string " " port) + (write (o3-outline o3) port))))))) + outline + index + y) + +(define (make-o3 window outline index y) + (let ((o3 (%window-free-o3 window))) + (if o3 + (begin + (%set-window-free-o3! window (o3-outline o3)) + (set-o3-outline! o3 outline) + (set-o3-index! o3 index) + (set-o3-y! o3 y) + o3) + (%make-o3 outline index y)))) + +(define (deallocate-o3! window o3) + (set-o3-outline! o3 (%window-free-o3 window)) + (%set-window-free-o3! window o3)) + +;;;; Narrowing + +(define-integrable (%window-group-start-mark window) + (group-display-start (%window-group window))) + +(define-integrable (%window-group-end-mark window) + (group-display-end (%window-group window))) + +(define-integrable (%window-group-start-index window) + (mark-index (%window-group-start-mark window))) + +(define-integrable (%window-group-end-index window) + (mark-index (%window-group-end-mark window))) + +(define-integrable (%window-group-start-index? window index) + (fix:<= index (%window-group-start-index window))) + +(define-integrable (%window-group-end-index? window index) + (fix:>= index (%window-group-end-index window))) + +(define-integrable (%window-line-start-index window index) + (let ((start (%window-group-start-index window))) + (or (%find-previous-newline (%window-group window) index start) + start))) + +(define-integrable (%window-line-end-index window index) + (let ((end (%window-group-end-index window))) + (or (%find-next-newline (%window-group window) index end) + end))) + +(define (%window-line-start-index? window index) + (or (%window-group-start-index? window index) + (char=? (string-ref (group-text (%window-group window)) + (fix:- (group-index->position-integrable + (%window-group window) + index + #f) + 1)) + #\newline))) + +(define (%window-line-end-index? window index) + (or (%window-group-end-index? window index) + (char=? (string-ref (group-text (%window-group window)) + (group-index->position-integrable + (%window-group window) + index + #t)) + #\newline))) + +(define (clip-mark-to-display window mark) + (if (not (mark? mark)) + (error:wrong-type-argument mark "mark" 'CLIP-MARK-TO-DISPLAY)) + (if (and (%window-point window) + (not (mark~ (%window-point window) mark))) + (error:bad-range-argument mark 'CLIP-MARK-TO-DISPLAY)) + (cond ((group-display-start-index? (mark-group mark) (mark-index mark)) + (group-display-start (mark-group mark))) + ((group-display-end-index? (mark-group mark) (mark-index mark)) + (group-display-end (mark-group mark))) + (else + mark))) + +;;;; Utilities + +(define-integrable (%window-extract-string window start end) + (group-extract-string (%window-group window) start end)) + +(define-integrable (%window-modeline-event! window type) + (window-modeline-event! (window-superior window) type)) + +;;;; Standard Methods + +(define-method buffer-window (:initialize! window window*) + (usual==> window :initialize! window*) + (%reset-window-structures! window) + (%clear-window-buffer-state! window)) + +(define-method buffer-window (:kill! window) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%unset-window-buffer! window) + (set-interrupt-enables! mask)) + (usual==> window :kill!)) + +(define-method buffer-window (:salvage! window) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! window (%window-group-start-index window)) + (%set-window-point-moved?! window 'SINCE-START-SET) + (%reset-window-structures! window) + (buffer-window/redraw! window) + (set-interrupt-enables! mask) + unspecific)) + +(define-method buffer-window (:set-size! window x y) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-size! x y)) + (buffer-window/redraw! window) + (%release-window-outlines! window) + (set-window-size! window x y) + (%set-window-point-moved?! window 'SINCE-START-SET)) + +(define-method buffer-window (:set-x-size! window x) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-x-size! x)) + (buffer-window/redraw! window) + (set-window-x-size! window x) + (%set-window-point-moved?! window 'SINCE-START-SET)) + +(define-method buffer-window (:set-y-size! window y) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-y-size! y)) + (buffer-window/redraw! window) + (%release-window-outlines! window) + (set-window-y-size! window y) + (%set-window-point-moved?! window 'SINCE-START-SET)) + +(define (buffer-window/cursor-enable! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'cursor-enable!)) + (==> (inferior-window (%window-cursor-inferior window)) :enable!)) + +(define (buffer-window/cursor-disable! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'cursor-disable!)) + (==> (inferior-window (%window-cursor-inferior window)) :disable!)) + +;;;; Update + +(define (buffer-window:update-display! window screen x-start y-start + xl xu yl yu display-style) + ;; Assumes that interrupts are disabled. + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window ':update-display! + screen x-start y-start xl xu yl yu + display-style)) + (%set-window-saved-screen! window screen) + (%set-window-saved-x-start! window x-start) + (%set-window-saved-y-start! window y-start) + (%set-window-saved-xl! window xl) + (%set-window-saved-xu! window xu) + (%set-window-saved-yl! window yl) + (%set-window-saved-yu! window yu) + (update-buffer-window! window screen x-start y-start xl xu yl yu + display-style)) + +(define-method buffer-window :update-display! + buffer-window:update-display!) + +(define (buffer-window/direct-update! window display-style) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'direct-update! + display-style)) + (and (%window-saved-screen window) + (begin + (%notice-window-changes! window) + (with-screen-in-update (%window-saved-screen window) display-style + (lambda () + (let ((finished? + (update-buffer-window! window + (%window-saved-screen window) + (%window-saved-x-start window) + (%window-saved-y-start window) + (%window-saved-xl window) + (%window-saved-xu window) + (%window-saved-yl window) + (%window-saved-yu window) + display-style))) + (if finished? + (set-car! (window-redisplay-flags window) #f)) + finished?)))))) + +(define (update-buffer-window! window screen x-start y-start xl xu yl yu + display-style) + (if (%window-override-string window) + (update-override-string! window screen x-start y-start xl xu yl yu) + (update-outlines! window)) + (update-inferior! (%window-blank-inferior window) screen x-start y-start + xl xu yl yu display-style + blank-window:update-display!) + (update-inferior! (%window-cursor-inferior window) screen x-start y-start + xl xu yl yu display-style + cursor-window:update-display!) + #t) + +(define (buffer-window/redraw! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'force-redraw!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-force-redraw?! window #t) + (%recache-window-buffer-local-variables! window) + (%clear-window-incremental-redisplay-state! window) + (window-needs-redisplay! window) + (set-interrupt-enables! mask) + unspecific)) + +;;;; Window State + +(define (%reset-window-structures! window) + (set-window-inferiors! window '()) + (%set-window-cursor-inferior! window (make-inferior window cursor-window)) + (%set-window-blank-inferior! window (make-inferior window blank-window)) + (%release-window-outlines! window) + (%set-window-free-o3! window #f) + (%set-window-override-string! window #f) + (%set-window-clip-daemon! window (make-clip-daemon window)) + (%set-window-debug-trace! window #f) + (%set-window-saved-screen! window #f) + (%set-window-force-redraw?! window #f)) + +(define (%release-window-outlines! window) + (%set-window-start-outline! window #f) + (%set-window-end-outline! window #f) + (%set-window-free-outline! window #f)) + +(define (%clear-window-buffer-state! window) + (%set-window-buffer! window #f) + (%set-window-point! window #f) + (clear-window-start! window) + (%clear-window-incremental-redisplay-state! window)) + +(define (%clear-window-incremental-redisplay-state! window) + (if (%window-start-outline window) + (begin + (deallocate-outlines! window + (%window-start-outline window) + (%window-end-outline window)) + (%set-window-start-outline! window #f) + (%set-window-end-outline! window #f))) + (if (%window-current-start-mark window) + (begin + (mark-temporary! (%window-current-start-mark window)) + (%set-window-current-start-mark! window #f) + (mark-temporary! (%window-current-end-mark window)) + (%set-window-current-end-mark! window #f) + (%set-window-current-start-delta! window #f) + (%set-window-current-start-partial! window #f))) + (%clear-window-outstanding-changes! window)) + +(define-integrable (%clear-window-outstanding-changes! window) + (if (%window-buffer window) + (update-modified-tick! window)) + (if (%window-start-clip-mark window) + (begin + (mark-temporary! (%window-start-clip-mark window)) + (%set-window-start-clip-mark! window #f) + (mark-temporary! (%window-end-clip-mark window)) + (%set-window-end-clip-mark! window #f))) + (%set-window-point-moved?! window #f)) + +(define-integrable (update-modified-tick! window) + (%set-window-modified-tick! window + (group-modified-tick (%window-group window)))) + +(define (%recache-window-buffer-local-variables! window) + (let ((maybe-recache + (lambda (read write new-value) + (let ((old-value (read window))) + (if (not (eqv? new-value old-value)) + (begin + (%set-window-force-redraw?! window #t) + (clear-window-start! window) + (write window new-value)))))) + (buffer (%window-buffer window))) + (maybe-recache + %window-truncate-lines? + %set-window-truncate-lines?! + (or (variable-local-value buffer (ref-variable-object truncate-lines)) + (and (variable-local-value + buffer + (ref-variable-object truncate-partial-width-windows)) + (window-has-horizontal-neighbor? (window-superior window))))) + (maybe-recache + %window-tab-width + %set-window-tab-width! + (variable-local-value buffer (ref-variable-object tab-width))) + (maybe-recache + %window-char-image-strings + %set-window-char-image-strings! + (variable-local-value buffer (ref-variable-object char-image-strings))))) + +;;;; Buffer and Point + +(define-integrable (buffer-window/buffer window) + (%window-buffer window)) + +(define (buffer-window/set-buffer! window new-buffer) + ;; Interrupts must be disabled when this is called. + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-buffer! new-buffer)) + (if (not (buffer? new-buffer)) + (error:wrong-type-argument new-buffer "buffer" 'SET-WINDOW-BUFFER!)) + (if (%window-buffer window) + (%unset-window-buffer! window)) + (%set-window-buffer! window new-buffer) + (%recache-window-buffer-local-variables! window) + (let ((group (%window-group window))) + (add-group-clip-daemon! group (%window-clip-daemon window)) + (%set-window-point-index! window (mark-index (group-point group)))) + (if (and (buffer-display-start new-buffer) + (window-x-size window)) + (set-new-coordinates! window + (mark-index (buffer-display-start new-buffer)) + 0 + #f)) + (buffer-window/redraw! window)) + +(define (%unset-window-buffer! window) + ;; Interrupts must be disabled when this is called. + (let ((buffer (%window-buffer window))) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'unset-buffer! buffer)) + (set-buffer-display-start! + buffer + (mark-permanent! (buffer-window/start-mark window))) + (%set-buffer-point! buffer (buffer-window/point window))) + (remove-group-clip-daemon! (%window-group window) + (%window-clip-daemon window)) + (%clear-window-buffer-state! window)) + +(define-integrable (buffer-window/point window) + (%window-point window)) + +(define (buffer-window/set-point! window mark) + (let ((mark (clip-mark-to-display window mark))) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-point! mark)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-point-index! window (mark-index mark)) + (%set-window-point-moved?! window 'SINCE-START-SET) + (window-needs-redisplay! window) + (set-interrupt-enables! mask) + unspecific))) + +;;;; Start Mark + +(define (buffer-window/start-mark window) + (guarantee-start-mark! window) + (mark-temporary-copy (%window-start-mark window))) + +(define (buffer-window/set-start-mark! window mark force?) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-start-mark! mark)) + (set-new-coordinates! window + (mark-index (clip-mark-to-display window mark)) + 0 + (and force? (buffer-window/y-center window)))) + +(define (buffer-window/scroll-y-relative! window y-delta) + (if (not (fix:= y-delta 0)) + (begin + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'scroll-y-relative! + y-delta)) + (guarantee-start-mark! window) + (set-new-coordinates! window + (%window-start-line-index window) + (fix:- (%window-start-line-y window) y-delta) + (if (fix:> y-delta 0) + 0 + (fix:- (window-y-size window) 1)))))) + +(define (buffer-window/scroll-y-absolute! window y-point) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'scroll-y-absolute! + y-point)) + (if (not (and (fix:<= 0 y-point) + (fix:< y-point (window-y-size window)))) + (error:bad-range-argument y-point 'WINDOW-SCROLL-Y-ABSOLUTE!)) + (let ((cws + (compute-window-start window (%window-point-index window) y-point))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-start! window cws) + (set-interrupt-enables! mask) + unspecific))) + +(define (buffer-window/y-center window) + (let ((y-size (window-y-size window))) + (let ((result + (round->exact + (* y-size (/ (ref-variable cursor-centering-point) 100))))) + (if (< result y-size) + result + (- y-size 1))))) + +(define-variable cursor-centering-point + "The distance from the top of the window at which to center the point. +This number is a percentage, where 0 is the window's top and 100 the bottom." + 50 + (lambda (cursor-centering-point) + (and (real? cursor-centering-point) + (<= 0 cursor-centering-point 100)))) + +(define (set-new-coordinates! window index y point-y) + (let ((cws (compute-window-start window index y))) + (let ((start (vector-ref cws 0)) + (y-start (vector-ref cws 1))) + (cond ((predict-index-visible? window start y-start + (%window-point-index window)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-start! window cws) + (set-interrupt-enables! mask) + unspecific)) + (point-y + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-point-index! + window + (or (predict-index window start y-start + (vector-ref cws 4) point-y) + (%window-group-end-index window))) + (set-window-start! window cws) + (set-interrupt-enables! mask) + unspecific)))))) + +(define (set-window-start! window cws) + (let ((start-line (vector-ref cws 0)) + (start (vector-ref cws 2))) + (if (fix:= start-line start) + (if (%window-start-line-mark window) + (begin + (set-mark-index! (%window-start-line-mark window) start-line) + (if (not (eq? (%window-start-line-mark window) + (%window-start-mark window))) + (begin + (mark-temporary! (%window-start-mark window)) + (%set-window-start-mark! + window + (%window-start-line-mark window))))) + (let ((mark + (make-permanent-mark (%window-group window) start-line #f))) + (%set-window-start-line-mark! window mark) + (%set-window-start-mark! window mark))) + (if (%window-start-line-mark window) + (begin + (set-mark-index! (%window-start-line-mark window) start-line) + (if (eq? (%window-start-line-mark window) + (%window-start-mark window)) + (%set-window-start-mark! + window + (make-permanent-mark (%window-group window) start #f)) + (set-mark-index! (%window-start-mark window) start))) + (let ((group (%window-group window))) + (%set-window-start-line-mark! + window + (make-permanent-mark group start-line #f)) + (%set-window-start-mark! + window + (make-permanent-mark group start #f)))))) + (%set-window-start-line-y! window (vector-ref cws 1)) + (%set-window-start-column! window (vector-ref cws 3)) + (%set-window-start-partial! window (vector-ref cws 4)) + (if (eq? (%window-point-moved? window) 'SINCE-START-SET) + (%set-window-point-moved?! window #t)) + (window-needs-redisplay! window)) + +(define (clear-window-start! window) + (if (%window-start-line-mark window) + (begin + (mark-temporary! (%window-start-line-mark window)) + (%set-window-start-line-mark! window #f))) + (if (%window-start-mark window) + (begin + (mark-temporary! (%window-start-mark window)) + (%set-window-start-mark! window #f))) + (%set-window-start-line-y! window 0) + (%set-window-start-column! window 0) + (%set-window-start-partial! window 0)) + +(define (guarantee-start-mark! window) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%guarantee-start-mark! window) + (set-interrupt-enables! mask) + unspecific)) + +(define (%guarantee-start-mark! window) + (let ((index-at! + (lambda (index y) + (set-window-start! window (compute-window-start window index y))))) + (if (not (%window-start-line-mark window)) + (index-at! (%window-point-index window) + (buffer-window/y-center window)) + (let ((start-line (%window-start-line-index window))) + (cond ((not (%window-line-start-index? window start-line)) + (index-at! (%window-start-index window) 0)) + ((eq? (%window-point-moved? window) 'SINCE-START-SET) + (let ((point (%window-point-index window))) + (if (or (%window-start-clip-mark window) + (fix:> (group-modified-tick (%window-group window)) + (%window-modified-tick window)) + (not (%window-current-start-mark window)) + (fix:< + point + (if (fix:< (%window-current-start-y window) 0) + (fix:+ (%window-current-start-index window) + (outline-index-length + (%window-start-outline window))) + (%window-current-start-index window))) + (fix:> point + (if (fix:> (%window-current-end-y window) + (window-y-size window)) + (fix:- (%window-current-end-index window) + (outline-index-length + (%window-end-outline window))) + (%window-current-end-index window)))) + (let ((start-y (%window-start-line-y window)) + (y-size (window-y-size window)) + (scroll-step + (ref-variable scroll-step + (%window-buffer window)))) + (if (fix:= 0 scroll-step) + (if (predict-y-limited window start-line + start-y point + 0 y-size) + (%set-window-point-moved?! window #t) + (index-at! point + (buffer-window/y-center window))) + (let ((y + (predict-y-limited window start-line + start-y point + (fix:- 0 scroll-step) + (fix:+ y-size + scroll-step)))) + (cond ((not y) + (index-at! + point + (buffer-window/y-center window))) + ((fix:< y 0) + (index-at! point (fix:+ y scroll-step))) + ((fix:>= y y-size) + (index-at! point + (fix:- y scroll-step))))))) + (%set-window-point-moved?! window #t))))))))) + +(define-variable scroll-step + "The number of lines to try scrolling a window by when point moves out. +If that fails to bring point back on screen, point is centered instead. +If this is zero, point is always centered after it moves off screen." + 0 + (lambda (scroll-step) + (and (fix:fixnum? scroll-step) + (fix:>= scroll-step 0)))) + +;;;; Override Message + +(define (buffer-window/override-message window) + (%window-override-string window)) + +(define (buffer-window/set-override-message! window message) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'set-override-message! + message)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-override-string! window message) + (window-needs-redisplay! window) + (set-interrupt-enables! mask) + unspecific)) + +(define (buffer-window/clear-override-message! window) + (if (%window-override-string window) + (begin + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'clear-override-message!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-override-string! window #f) + (buffer-window/redraw! window) + (set-interrupt-enables! mask) + unspecific)))) + +(define (update-override-string! window screen x-start y-start xl xu yl yu) + ;; This should probably update like any other string, paying + ;; attention to TRUNCATE-LINES? and going to multiple lines if + ;; necessary. For now we'll force it to be truncated to a single + ;; line, which is fine as long as the minibuffer is only one line. + (if (and (fix:= yl 0) (not (fix:= yu 0))) + (let ((string (%window-override-string window)) + (xl (fix:+ x-start xl)) + (xu (fix:+ x-start xu)) + (results substring-image-results)) + (let ((end (string-length string)) + (line + (screen-get-output-line screen (fix:+ y-start yl) xl xu #f))) + (substring-image! string 0 end + line xl (fix:- xu 1) + #f 0 results + (%window-char-image-strings window)) + (if (fix:= (vector-ref results 0) end) + (do ((x (vector-ref results 1) (fix:+ x 1))) + ((fix:= x xu)) + (string-set! line x #\space)) + (string-set! line (fix:- xu 1) #\$)) + (set-inferior-start! (%window-cursor-inferior window) + (vector-ref results 1) + 0)))) + (%update-blank-inferior! window 1 #t) + (update-modified-tick! window)) + +;;;; Update Finalization + +(define (set-outlines! window start end) + (%set-window-start-outline! window (o3-outline start)) + (%set-window-end-outline! window (o3-outline end)) + (if (%window-current-start-mark window) + (begin + (set-mark-index! (%window-current-start-mark window) (o3-index start)) + (set-mark-index! (%window-current-end-mark window) (o3-index end))) + (begin + (%set-window-current-start-mark! + window + (make-permanent-mark (%window-group window) (o3-index start) #f)) + (%set-window-current-end-mark! + window + (make-permanent-mark (%window-group window) (o3-index end) #t)))) + (%set-window-current-start-delta! window + (fix:- (%window-start-index window) + (%window-start-line-index window))) + (%set-window-current-start-partial! window (%window-start-partial window)) + (%set-window-current-start-y! window (o3-y start)) + (%set-window-current-end-y! window (o3-y end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + (update-blank-inferior! window #t) + (update-cursor! window) + (%window-modeline-event! window 'SET-OUTLINES)) + +(define (update-blank-inferior! window signal?) + (%update-blank-inferior! window (%window-current-end-y window) signal?)) + +(define (%update-blank-inferior! window end-y signal?) + (let ((inferior (%window-blank-inferior window))) + (if (fix:< end-y (window-y-size window)) + (begin + (%set-window-x-size! (inferior-window inferior) + (window-x-size window)) + (%set-window-y-size! (inferior-window inferior) + (fix:- (window-y-size window) end-y)) + (%set-inferior-x-start! inferior 0) + (%set-inferior-y-start! inferior end-y) + (if signal? + (setup-redisplay-flags! (inferior-redisplay-flags inferior)))) + (begin + (%set-inferior-x-start! inferior #f) + (%set-inferior-y-start! inferior #f))))) + +(define (update-cursor! window) + (let ((xy (buffer-window/point-coordinates window))) + (if (and (fix:<= 0 (car xy)) + (fix:< (car xy) (window-x-size window)) + (fix:<= 0 (cdr xy)) + (fix:< (cdr xy) (window-y-size window))) + (set-inferior-position! (%window-cursor-inferior window) xy) + (begin + (if point-not-visible-error? + (error "point not visible at end of redisplay")) + (set-window-point-index! + window + (or (predict-index window + (%window-start-line-index window) + (%window-start-line-y window) + (%window-start-partial window) + 0) + (%window-group-end-index window))) + (update-cursor! window))))) + +(define point-not-visible-error? + #f) \ No newline at end of file diff --git a/edwin/bufwiu.scm b/edwin/bufwiu.scm new file mode 100644 index 0000000..81b992e --- /dev/null +++ b/edwin/bufwiu.scm @@ -0,0 +1,549 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Windows: Image Update + +(declare (usual-integrations)) + +;;;; Insert/Delete + +(define (%notice-window-changes! window) + ;; Assumes that interrupts are disabled. + (let ((group (%window-group window))) + (if (fix:> (group-modified-tick group) (%window-modified-tick window)) + (let ((start (group-start-changes-index group)) + (end (group-end-changes-index group))) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + '%notice-window-changes!)) + (if (not (%window-force-redraw? window)) + ;; If this change intersects the visible region of the + ;; buffer, request a display update. + (if start + (window-needs-redisplay! window) + ;; Otherwise mark the window to indicate that it has + ;; been updated to reflect these changes. + (%set-window-modified-tick! window + (group-modified-tick group)))) + (if start + (begin + ;; If this change affects START-MARK, invalidate it + ;; and request a display update. + (if (and (%window-start-line-mark window) + (%start-clobbered? window start end)) + (begin + (clear-window-start! window) + (window-needs-redisplay! window))) + ;; If this change affects POINT, invalidate it and + ;; request a display update. + (if (and (fix:<= start (%window-point-index window)) + (fix:<= (%window-point-index window) end)) + (begin + (%set-window-point-moved?! window 'SINCE-START-SET) + (window-needs-redisplay! window))))))))) + +(define-integrable (%start-clobbered? window start end) + (let ((wlstart (%window-start-line-index window)) + (wstart (%window-start-index window)) + (partial (%window-start-partial window))) + (or (and (%window-current-start-delta window) + ;; If the delta between START-LINE and START has changed + ;; since the last redisplay, then the window start has + ;; been clobbered. For example, if the first line was + ;; only partially visible, and is then entirely deleted, + ;; WLSTART and WSTART will be equal -- which would + ;; normally indicate that the window start is OK. + (not (and (fix:= (%window-current-start-delta window) + (fix:- wstart wlstart)) + (fix:= (%window-current-start-partial window) + partial)))) + (and (if (and (fix:= wlstart wstart) + (fix:= 0 partial)) + (fix:< start wstart) + (fix:<= start wstart)) + (fix:<= wlstart end))))) + +;;;; Clip + +(define (make-clip-daemon window) + ;; It is assumed that the clip daemon is called before the clipping + ;; has been performed. It is also assumed that interrupts are + ;; disabled. + (lambda (group start end) + (if (not (%window-force-redraw? window)) + (begin + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'clip-daemon + group start end)) + (if (not (%window-start-clip-mark window)) + (begin + (%set-window-start-clip-mark! + window + (make-permanent-mark group + (group-display-start-index group) + #t)) + (%set-window-end-clip-mark! + window + (make-permanent-mark group + (group-display-end-index group) + #f)))) + (begin + (if (fix:> start (%window-start-clip-index window)) + (set-mark-index! (%window-start-clip-mark window) start)) + (if (fix:< end (%window-end-clip-index window)) + (set-mark-index! (%window-end-clip-mark window) end))) + (if (and (not (window-needs-redisplay? window)) + (or (fix:>= (%window-start-clip-index window) + (%window-current-start-index window)) + (fix:<= (%window-end-clip-index window) + (%window-current-end-index window)))) + (window-needs-redisplay! window)))) + (if (and (%window-start-line-mark window) + (or (fix:>= start (%window-start-line-index window)) + (fix:< end (%window-start-index window)))) + (begin + (clear-window-start! window) + (window-needs-redisplay! window))) + (let ((point (%window-point-index window))) + (cond ((fix:< point start) + (set-window-point-index! window start) + (%set-window-point-moved?! window 'SINCE-START-SET)) + ((fix:< end point) + (set-window-point-index! window end) + (%set-window-point-moved?! window 'SINCE-START-SET)))))) + +;;;; Update + +(define (update-outlines! window) + ;; This procedure sets FORCE-REDRAW? if any cached variable has changed. + (%recache-window-buffer-local-variables! window) + (%guarantee-start-mark! window) + (if (%window-force-redraw? window) + (begin + (%set-window-force-redraw?! window #f) + (preserve-nothing! window)) + (let ((start (%window-current-start-index window)) + (end (%window-current-end-index window))) + (cond ((or (not start) + (and (%window-start-clip-mark window) + (or (fix:< start (%window-group-start-index window)) + (fix:< (%window-group-start-index window) + (%window-start-clip-index window)) + (fix:< (%window-group-end-index window) end) + (fix:< (%window-end-clip-index window) + (%window-group-end-index window))))) + (preserve-nothing! window)) + ((and (fix:> (group-modified-tick (%window-group window)) + (%window-modified-tick window)) + (fix:<= start (%window-end-changes-index window)) + (fix:<= (%window-start-changes-index window) end)) + (let ((start-changes + (let ((start-changes + (%window-start-changes-index window))) + (if (%window-group-start-index? window start-changes) + (%window-group-start-index window) + (%window-line-start-index window start-changes)))) + (end-changes + (let ((end-changes (%window-end-changes-index window))) + (if (%window-group-end-index? window end-changes) + (%window-group-end-index window) + (%window-line-end-index window end-changes))))) + (if (fix:<= start-changes start) + (if (fix:< end-changes end) + (preserve-bottom! window end-changes end) + (preserve-nothing! window)) + (if (fix:< end-changes end) + (preserve-top-and-bottom! window + start start-changes + end-changes end) + (preserve-top! window start start-changes))))) + (else + (preserve-all! window start end))))) + (%clear-window-outstanding-changes! window)) + +(define (preserve-top! window start start-changes) + (let ((start-outline (%window-start-outline window)) + (start-y (%window-current-start-y window))) + (let ((last-unchanged + (last-unchanged-outline start-outline + start + start-changes))) + (deallocate-outlines! window + (outline-next last-unchanged) + (%window-end-outline window)) + (preserve-contiguous-region! window + (make-o3 window start-outline start start-y) + (make-o3 window + last-unchanged + (fix:- start-changes 1) + (outline-end-y start-outline + start-y)))))) + +(define (preserve-bottom! window end-changes end) + (let ((end-outline (%window-end-outline window)) + (end-y (%window-current-end-y window))) + (let ((first-unchanged + (first-unchanged-outline end-outline end end-changes))) + (if (not (eq? first-unchanged (%window-start-outline window))) + (deallocate-outlines! window + (%window-start-outline window) + (outline-previous first-unchanged))) + (preserve-contiguous-region! window + (make-o3 window + first-unchanged + (fix:+ end-changes 1) + (outline-start-y end-outline + end-y)) + (make-o3 window end-outline end end-y))))) + +(define (preserve-contiguous-region! window start end) + (let ((wlstart (%window-start-line-index window)) + (wlsy (%window-start-line-y window))) + (if (maybe-scroll window start end wlstart wlsy) + (fill-edges window start end) + (regenerate-outlines window wlstart wlsy)))) + +(define (preserve-top-and-bottom! window start start-changes end-changes end) + (let ((wlstart (%window-start-line-index window)) + (wlsy (%window-start-line-y window)) + (top-head (%window-start-outline window)) + (bot-tail (%window-end-outline window)) + (top-start-y (%window-current-start-y window)) + (bot-end-y (%window-current-end-y window))) + (let ((top-tail (last-unchanged-outline top-head start start-changes)) + (bot-head (first-unchanged-outline bot-tail end end-changes))) + (deallocate-outlines! window + (outline-next top-tail) + (outline-previous bot-head)) + (let ((top-start (make-o3 window top-head start top-start-y)) + (top-end + (make-o3 window + top-tail + (fix:- start-changes 1) + (outline-end-y top-head top-start-y))) + (bot-start + (make-o3 window + bot-head + (fix:+ end-changes 1) + (outline-start-y bot-tail bot-end-y))) + (bot-end (make-o3 window bot-tail end bot-end-y))) + (if (maybe-scroll window top-start top-end wlstart wlsy) + (if (maybe-scroll window bot-start bot-end wlstart wlsy) + (begin + (fill-middle window top-end bot-start) + (deallocate-o3! window top-end) + (deallocate-o3! window bot-start) + (fill-edges window top-start bot-end)) + (fill-edges window top-start top-end)) + (if (maybe-scroll window bot-start bot-end wlstart wlsy) + (fill-edges window bot-start bot-end) + (regenerate-outlines window wlstart wlsy))))))) + +(define (preserve-all! window start-index end-index) + (let ((wlstart (%window-start-line-index window)) + (wlsy (%window-start-line-y window)) + (start-y (%window-current-start-y window)) + (end-y (%window-current-end-y window))) + (let ((scroll-down + (lambda (y) + (let ((start + (make-o3 window + (%window-start-outline window) + start-index + start-y)) + (end + (make-o3 window + (%window-end-outline window) + end-index + end-y))) + (if (scroll-lines-down window start end y) + (begin + (fill-top window start) + (set-outlines! window start end)) + (regenerate-outlines window wlstart wlsy))))) + (scroll-up + (lambda (y) + (let ((start + (make-o3 window + (%window-start-outline window) + start-index + start-y)) + (end + (make-o3 window + (%window-end-outline window) + end-index + end-y))) + (if (scroll-lines-up window start end y) + (begin + (fill-bottom window end) + (set-outlines! window start end)) + (regenerate-outlines window wlstart wlsy)))))) + (cond ((fix:= wlstart start-index) + (cond ((fix:= wlsy start-y) + (if (%window-point-moved? window) + (update-cursor! window) + (%window-modeline-event! window 'PRESERVE-ALL!))) + ((fix:< wlsy start-y) + (scroll-up wlsy)) + (else + (scroll-down wlsy)))) + ((fix:< wlstart start-index) + (let ((y + (predict-y-limited window wlstart wlsy start-index start-y + (window-y-size window)))) + (if (not y) + (regenerate-outlines window wlstart wlsy) + (scroll-down y)))) + (else + (let ((y + (predict-y-limited window wlstart wlsy start-index + (fix:- 1 (fix:- end-y start-y)) + 1))) + (if (not y) + (regenerate-outlines window wlstart wlsy) + (scroll-up y)))))))) + +(define-integrable (preserve-nothing! window) + (regenerate-outlines window + (%window-start-line-index window) + (%window-start-line-y window))) + +(define (first-unchanged-outline end-outline end end-changes) + (let loop ((outline end-outline) (end end)) + (let ((end-next (fix:- end (fix:+ (outline-index-length outline) 1)))) + (if (fix:> end-next end-changes) + (begin + (if (not (outline-previous outline)) + (error "can't find END-CHANGES")) + (loop (outline-previous outline) end-next)) + (begin + (if (not (fix:= end-next end-changes)) + (error "overshot END-CHANGES" end-next end-changes)) + outline))))) + +(define (last-unchanged-outline start-outline start start-changes) + (let loop ((outline start-outline) (start start)) + (let ((start-next (fix:+ start (fix:+ (outline-index-length outline) 1)))) + (if (fix:< start-next start-changes) + (begin + (if (not (outline-next outline)) + (error "can't find START-CHANGES")) + (loop (outline-next outline) start-next)) + (begin + (if (not (fix:= start-next start-changes)) + (error "overshot START-CHANGES" start-next start-changes)) + outline))))) + +(define (regenerate-outlines window wlstart wlsy) + (let ((start (make-o3 window #f wlstart wlsy)) + (end (make-o3 window #f #f #f))) + (generate-outlines window start end) + (set-outlines! window start end))) + +(define-integrable (fill-edges window start end) + (fill-top window start) + (fill-bottom window end) + (set-outlines! window start end)) + +(define (maybe-scroll window start end wlstart wlsy) + (let ((y + (predict-y-limited window wlstart wlsy + (o3-index start) + (fix:- 1 (fix:- (o3-y end) (o3-y start))) + (window-y-size window)))) + (cond ((not y) + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + #f) + ((fix:= (o3-y start) y) + #t) + ((fix:< (o3-y start) y) + (scroll-lines-down window start end y)) + (else + (scroll-lines-up window start end y))))) + +;;;; Direct Output + +;;; The direct output procedures are hairy and should be used only +;;; under restricted conditions. In particular, the cursor may not be +;;; at the right margin (for insert and forward) or the left margin +;;; (for backward), and the character being inserted must be an +;;; ordinary graphic character. For insert, the buffer must be +;;; modifiable, and the modeline must already show that it has been +;;; modified. None of the procedures may be used if the window needs +;;; redisplay. + +(define (buffer-window/needs-redisplay? window) + (%notice-window-changes! window) + (or (window-needs-redisplay? window) + (not (%window-saved-screen window)) + (screen-needs-update? (%window-saved-screen window)))) + +(define (buffer-window/direct-output-cursor! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'direct-output-cursor!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (let ((x-start (inferior-x-start (%window-cursor-inferior window))) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-move-cursor + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start))) + (set-interrupt-enables! mask) + unspecific)) + +(define (buffer-window/direct-output-forward-char! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-forward-char!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-point-index! window (fix:+ (%window-point-index window) 1)) + (let ((x-start + (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1)) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-move-cursor + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start)) + (%set-inferior-x-start! (%window-cursor-inferior window) x-start)) + (set-interrupt-enables! mask) + unspecific)) + +(define (buffer-window/direct-output-backward-char! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-backward-char!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-window-point-index! window (fix:- (%window-point-index window) 1)) + (let ((x-start + (fix:- (inferior-x-start (%window-cursor-inferior window)) 1)) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-move-cursor + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start)) + (%set-inferior-x-start! (%window-cursor-inferior window) x-start)) + (set-interrupt-enables! mask) + unspecific)) + +(define (buffer-window/home-cursor! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'home-cursor!)) + (if (and (%window-saved-screen window) + (fix:<= (%window-saved-xl window) 0) + (fix:< 0 (%window-saved-xu window)) + (fix:<= (%window-saved-yl window) 0) + (fix:< 0 (%window-saved-yu window))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (screen-direct-output-move-cursor (%window-saved-screen window) + (%window-saved-x-start window) + (%window-saved-y-start window)) + (set-interrupt-enables! mask) + unspecific))) + +(define (buffer-window/direct-output-insert-char! window char) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-insert-char! char)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (let ((x-start (inferior-x-start (%window-cursor-inferior window))) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-char + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start) + char + #f) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) 1))) + (%set-inferior-x-start! (%window-cursor-inferior window) + (fix:+ x-start 1))) + (update-modified-tick! window) + (set-interrupt-enables! mask) + unspecific)) + +(define (buffer-window/direct-output-insert-substring! window string start end) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-insert-substring! + (string-copy string) start end)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (group-insert-substring! (%window-group window) + (%window-point-index window) + string start end) + (let ((x-start (inferior-x-start (%window-cursor-inferior window))) + (y-start (inferior-y-start (%window-cursor-inferior window))) + (length (fix:- end start))) + (screen-direct-output-substring + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start) + string start end + #f) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) + length))) + (%set-inferior-x-start! (%window-cursor-inferior window) + (fix:+ x-start length))) + (update-modified-tick! window) + (set-interrupt-enables! mask) + unspecific)) + +(define (direct-output-outline window y) + (let loop + ((outline (%window-start-outline window)) + (start-y (%window-current-start-y window))) + (let ((end-y (fix:+ start-y (outline-y-size outline)))) + (if (fix:< y end-y) + outline + (loop (outline-next outline) end-y))))) + +(define (buffer-window/direct-output-insert-newline! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-insert-newline!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (group-insert-char! (%window-group window) + (%window-point-index window) + #\newline) + (let ((end-y (%window-current-end-y window))) + (screen-direct-output-move-cursor (%window-saved-screen window) + (%window-saved-x-start window) + (fix:+ (%window-saved-y-start window) + end-y)) + (%set-window-end-outline! + window + (make-outline window 0 1 (%window-end-outline window) #f)) + (%set-window-current-end-y! window (fix:+ end-y 1)) + (update-blank-inferior! window #f) + (%set-inferior-x-start! (%window-cursor-inferior window) 0) + (%set-inferior-y-start! (%window-cursor-inferior window) end-y)) + (update-modified-tick! window) + (set-interrupt-enables! mask) + unspecific)) \ No newline at end of file diff --git a/edwin/bufwmc.scm b/edwin/bufwmc.scm new file mode 100644 index 0000000..4c45187 --- /dev/null +++ b/edwin/bufwmc.scm @@ -0,0 +1,588 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Buffer Windows: Mark <-> Coordinate Maps + +(declare (usual-integrations)) + +(define-integrable (buffer-window/mark->x window mark) + (buffer-window/index->x window (mark-index mark))) + +(define-integrable (buffer-window/mark->y window mark) + (buffer-window/index->y window (mark-index mark))) + +(define-integrable (buffer-window/mark->coordinates window mark) + (buffer-window/index->coordinates window (mark-index mark))) + +(define-integrable (buffer-window/point-x window) + (buffer-window/index->x window (%window-point-index window))) + +(define-integrable (buffer-window/point-y window) + (buffer-window/index->y window (%window-point-index window))) + +(define-integrable (buffer-window/point-coordinates window) + (buffer-window/index->coordinates window (%window-point-index window))) + +(define (buffer-window/index->x window index) + (let ((start (%window-line-start-index window index)) + (group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window))) + (column->x (group-columns group start index 0 tab-width char-image-strings) + (window-x-size window) + (%window-truncate-lines? window) + (%window-line-end-index? window index)))) + +(define (buffer-window/index->y window index) + (call-with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + line-start-index + (predict-y window start-index start-y index)))) + +(define (buffer-window/index->coordinates window index) + (call-with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + (let ((group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window))) + (let ((xy + (column->coordinates + (group-columns group line-start-index index 0 tab-width + char-image-strings) + (window-x-size window) + (%window-truncate-lines? window) + (%window-line-end-index? window index)))) + (cons (car xy) + (fix:+ (cdr xy) + (predict-y window + start-index + start-y + line-start-index)))))))) + +(define (buffer-window/coordinates->mark window x y) + (let ((index (buffer-window/coordinates->index window x y))) + (and index + (make-mark (%window-group window) index)))) + +(define (buffer-window/coordinates->index window x y) + (call-with-values (lambda () (start-point-for-y window y)) + (lambda (start-index start-y) + (predict-index window start-index start-y x y)))) + +(define (buffer-window/mark-visible? window mark) + ;; True iff cursor at this position would be on-screen. + (let ((index (mark-index mark))) + (and (fix:<= (%window-group-start-index window) index) + (fix:<= index (%window-group-end-index window)) + (call-with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + line-start-index + (predict-index-visible? window start-index start-y index)))))) + +(define (start-point-for-index window index) + (if (outlines-valid? window) + (let ((start-index (%window-current-start-index window)) + (start-y (%window-current-start-y window))) + (if (and (fix:<= start-index index) + (fix:<= index (%window-current-end-index window))) + (let loop + ((outline (%window-start-outline window)) + (index* start-index) + (y start-y)) + (let ((index** + (fix:+ index* (fix:+ (outline-index-length outline) 1)))) + (if (fix:< index index**) + (values index* y index*) + (loop (outline-next outline) + index** + (fix:+ y (outline-y-size outline)))))) + (values start-index + start-y + (%window-line-start-index window index)))) + (begin + (guarantee-start-mark! window) + (values (%window-start-line-index window) + (%window-start-line-y window) + (%window-line-start-index window index))))) + +(define (start-point-for-y window y) + (if (outlines-valid? window) + (let ((start-index (%window-current-start-index window)) + (start-y (%window-current-start-y window))) + (if (fix:< y start-y) + (values start-index start-y) + (let loop + ((outline (%window-start-outline window)) + (index start-index) + (y* start-y)) + (let ((y** (fix:+ y* (outline-y-size outline)))) + (cond ((fix:< y y**) + (values index y*)) + ((not (outline-next outline)) + (values start-index start-y)) + (else + (loop (outline-next outline) + (fix:+ index + (fix:+ (outline-index-length outline) 1)) + y**))))))) + (begin + (guarantee-start-mark! window) + (values (%window-start-line-index window) + (%window-start-line-y window))))) + +(define-integrable (outlines-valid? window) + (and (fix:= (group-modified-tick (%window-group window)) + (%window-modified-tick window)) + (not (%window-start-clip-mark window)) + (not (%window-point-moved? window)) + (not (%window-force-redraw? window)) + (%window-start-line-mark window) + (fix:= (%window-start-line-index window) + (%window-current-start-index window)))) + +(define (predict-y window start y index) + ;; Assuming that the character at index START appears at coordinate + ;; Y, return the coordinate for the character at INDEX. START is + ;; assumed to be a line start. + (if (fix:= index start) + y + (let ((group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (x-size (window-x-size window)) + (truncate-lines? (%window-truncate-lines? window))) + (if (fix:< index start) + (let ((group-start (%window-group-start-index window))) + (let loop ((start start) (y y)) + (let* ((end (fix:- start 1)) + (start + (or (%find-previous-newline group end group-start) + group-start)) + (columns (group-columns group start end 0 tab-width + char-image-strings)) + (y + (fix:- y + (column->y-size columns + x-size + truncate-lines?)))) + (if (fix:< index start) + (loop start y) + (fix:+ y + (column->y (group-columns group start index + 0 tab-width + char-image-strings) + x-size + truncate-lines? + (%window-line-end-index? window + index))))))) + (let ((group-end (%window-group-end-index window))) + (let loop ((start start) (y y)) + (let ((e&c + (group-line-columns group start group-end 0 tab-width + char-image-strings))) + (if (fix:> index (car e&c)) + (loop (fix:+ (car e&c) 1) + (fix:+ y + (column->y-size (cdr e&c) + x-size + truncate-lines?))) + (fix:+ y + (column->y (group-columns group start index + 0 tab-width + char-image-strings) + x-size + truncate-lines? + (%window-line-end-index? + window + index))))))))))) + +(define (predict-y-limited window start y index yl yu) + ;; Like PREDICT-Y, except returns #F if the result is not in the + ;; range specified by YL and YU. Prevents long search to find INDEX + ;; when it is far away from the window. + (if (fix:= index start) + (and (fix:<= yl y) + (fix:< y yu) + y) + (let ((group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (x-size (window-x-size window)) + (truncate-lines? (%window-truncate-lines? window))) + (if (fix:< index start) + (let ((group-start (%window-group-start-index window))) + (let loop ((start start) (y y)) + (and (fix:<= yl y) + (let* ((end (fix:- start 1)) + (start + (or (%find-previous-newline group end group-start) + group-start)) + (columns + (group-columns group start end 0 tab-width + char-image-strings)) + (y + (fix:- y + (column->y-size columns + x-size + truncate-lines?)))) + (if (fix:< index start) + (loop start y) + (let ((y + (fix:+ + y + (column->y (group-columns group + start + index + 0 + tab-width + char-image-strings) + x-size + truncate-lines? + (%window-line-end-index? + window + index))))) + (and (fix:<= yl y) + (fix:< y yu) + y))))))) + (let ((group-end (%window-group-end-index window))) + (let loop ((start start) (y y)) + (and (fix:< y yu) + (let ((e&c + (group-line-columns group start group-end 0 + tab-width char-image-strings))) + (if (fix:> index (car e&c)) + (loop (fix:+ (car e&c) 1) + (fix:+ y + (column->y-size (cdr e&c) + x-size + truncate-lines?))) + (let ((y + (fix:+ + y + (column->y (group-columns group + start + index + 0 + tab-width + char-image-strings) + x-size + truncate-lines? + (%window-line-end-index? + window + index))))) + (and (fix:<= yl y) + (fix:< y yu) + y))))))))))) + +(define (predict-index-visible? window start y index) + (and (fix:>= index start) + (let ((x-size (window-x-size window)) + (y-size (window-y-size window)) + (group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (group-end (%window-group-end-index window))) + (let loop ((start start) (y y)) + (and (fix:< y y-size) + (let ((e&c + (group-line-columns group start group-end 0 tab-width + char-image-strings))) + (if (fix:> index (car e&c)) + (loop (fix:+ (car e&c) 1) + (fix:+ y + (column->y-size (cdr e&c) + x-size + truncate-lines?))) + (let ((y + (fix:+ y + (column->y (group-columns group + start + index + 0 + tab-width + char-image-strings) + x-size + truncate-lines? + (%window-line-end-index? + window + index))))) + (and (fix:<= 0 y) + (fix:< y y-size)))))))))) + +(define (predict-index window start y-start x y) + ;; Assumes that START is a line start. + (let ((group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (x-size (window-x-size window)) + (truncate-lines? (%window-truncate-lines? window))) + (if (fix:< y y-start) + (let ((group-start (%window-group-start-index window))) + (let loop ((start start) (y-start y-start)) + (and (fix:< group-start start) + (let* ((end (fix:- start 1)) + (start + (or (%find-previous-newline group end group-start) + group-start)) + (columns (group-columns group start end 0 tab-width + char-image-strings)) + (y-start + (fix:- y-start + (column->y-size columns + x-size + truncate-lines?)))) + (if (fix:< y y-start) + (loop start y-start) + (vector-ref + (group-column->index + group start end 0 + (let ((column + (coordinates->column x + (fix:- y y-start) + x-size))) + (if (fix:< column columns) + column + columns)) + tab-width + char-image-strings) + 0)))))) + (let ((group-end (%window-group-end-index window))) + (let loop ((start start) (y-start y-start)) + (let ((e&c (group-line-columns group start group-end 0 tab-width + char-image-strings))) + (let ((y-end + (fix:+ y-start + (column->y-size (cdr e&c) + x-size + truncate-lines?)))) + (if (fix:>= y y-end) + (and (fix:< (car e&c) group-end) + (loop (fix:+ (car e&c) 1) y-end)) + (vector-ref (group-column->index + group start (car e&c) 0 + (let ((column + (coordinates->column x + (fix:- y y-start) + x-size))) + (if (fix:< column (cdr e&c)) + column + (cdr e&c))) + tab-width + char-image-strings) + 0))))))))) + +(define (compute-window-start window index y-index) + ;; INDEX is an index into WINDOW's buffer, and Y-INDEX is the + ;; desired y coordinate, in WINDOW's coordinate space, at which + ;; INDEX is desired to appear. Returns a vector of values: + ;; 0 START-LINE, index at start of first line that is visible in the + ;; window. + ;; 1 Y-START, coordinate at which START-LINE will appear. Negative + ;; if START-LINE is less than START, otherwise zero. + ;; 2 START, index of first visible char (in upper left corner). + ;; 3 START-COLUMN, first visible column of window. Positive if + ;; START is greater than START-LINE, otherwise zero. + ;; 4 START-PARTIAL. If START char is fully visible, this is zero. + ;; Otherwise this is positive and indicates the number of columns + ;; that *are* visible. + ;; 5 #F means that it's not possible to place the INDEX char at + ;; Y-INDEX, but that the other values are a starting point that + ;; gets the INDEX char as close as possible to Y-INDEX. + ;; Otherwise, this is #T indicating that the starting point is + ;; satisfactory. + (if (%window-truncate-lines? window) + (compute-window-start-tl window index y-index) + (compute-window-start-ntl window index y-index))) + +(define (compute-window-start-tl window index y-index) + (let ((group (%window-group window))) + (let ((group-start (group-display-start-index group)) + (group-end (group-display-end-index group))) + (let ((start + (let ((index + (group-find-previous-char group group-start index + #\newline))) + (if index + (fix:+ index 1) + group-start)))) + (cond ((fix:= y-index 0) + (vector start y-index start 0 0 #t)) + ((fix:< y-index 0) + (let loop ((start start) (y-start y-index)) + (let ((nl + (group-find-next-char group start group-end + #\newline))) + (if nl + (let ((start (fix:+ nl 1)) + (y-start (fix:+ y-start 1))) + (if (fix:= y-start 0) + (vector start y-start start 0 0 #t) + (loop start y-start))) + (vector start 0 start 0 0 #f))))) + ((fix:= start group-start) + (vector start 0 start 0 0 #f)) + (else + (let loop ((end (fix:- start 1)) (y-start y-index)) + (let ((nl + (group-find-previous-char group group-start end + #\newline)) + (y-start (fix:- y-start 1))) + (cond ((fix:= y-start 0) + (let ((start (if nl (fix:+ nl 1) group-start))) + (vector start y-start start 0 0 #t))) + ((not nl) + (vector group-start 0 group-start 0 0 #f)) + (else + (loop nl y-start))))))))))) + +(define (compute-window-start-ntl window index y-index) + (let ((group (%window-group window)) + (char-image-strings (%window-char-image-strings window)) + (tab-width (%window-tab-width window)) + (x-size (window-x-size window))) + (let ((group-start (group-display-start-index group)) + (group-end (group-display-end-index group)) + (x-max (fix:- x-size 1))) + (let ((start + (let ((index + (group-find-previous-char group group-start index + #\newline))) + (if index + (fix:+ index 1) + group-start)))) + (let ((y-start + (fix:- y-index + (column->y (group-columns group start index 0 tab-width + char-image-strings) + x-size + #f + (%window-line-end-index? window index))))) + (cond ((fix:= y-start 0) + (vector start y-start start 0 0 #t)) + ((fix:< y-start 0) + (let loop ((start start) (y-start y-start)) + (let* ((column (fix:* (fix:- 0 y-start) x-max)) + (icp + (group-column->index group start group-end + 0 column tab-width + char-image-strings))) + (cond ((fix:= (vector-ref icp 1) column) + (vector start + y-start + (vector-ref icp 0) + (vector-ref icp 1) + (vector-ref icp 2) + #t)) + ((fix:= (vector-ref icp 0) group-end) + (vector start 0 start 0 0 #f)) + (else + (loop (fix:+ (vector-ref icp 0) 1) + (fix:+ + y-start + (column->y-size (vector-ref icp 1) + x-size + #f)))))))) + ((fix:= start group-start) + (vector start 0 start 0 0 #f)) + (else + (let loop ((end (fix:- start 1)) (y-start y-start)) + (let ((nl + (group-find-previous-char group group-start end + #\newline))) + (let ((start (if nl (fix:+ nl 1) group-start))) + (let ((y-start + (fix:- + y-start + (column->y-size (group-columns group start end + 0 tab-width + char-image-strings) + x-size + #f)))) + (cond ((fix:= y-start 0) + (vector start y-start start 0 0 #t)) + ((fix:< y-start 0) + (let ((icp + (group-column->index + group start end + 0 (fix:* (fix:- 0 y-start) x-max) + tab-width char-image-strings))) + (vector start + y-start + (vector-ref icp 0) + (vector-ref icp 1) + (vector-ref icp 2) + #t))) + ((not nl) + (vector group-start 0 group-start 0 0 #f)) + (else + (loop nl y-start)))))))))))))) + +;;;; Column<->Coordinate Utilities + +(define (column->y-size column-size x-size truncate-lines?) + ;; Assume X-SIZE > 1. + (cond ((or truncate-lines? (fix:< column-size x-size)) + 1) + ((fix:= (fix:remainder column-size (fix:- x-size 1)) 0) + (fix:quotient column-size (fix:- x-size 1))) + (else + (fix:+ (fix:quotient column-size (fix:- x-size 1)) 1)))) + +(define (column->coordinates column x-size truncate-lines? line-end?) + (let ((x-max (fix:- x-size 1))) + (cond ((fix:< column x-max) + (cons column 0)) + (truncate-lines? + (cons x-max 0)) + ((and line-end? (fix:= (fix:remainder column x-max) 0)) + (cons x-max (fix:- (fix:quotient column x-max) 1))) + (else + (cons (fix:remainder column x-max) + (fix:quotient column x-max)))))) + +(define (column->x column x-size truncate-lines? line-end?) + (let ((x-max (fix:- x-size 1))) + (cond ((fix:< column x-max) + column) + (truncate-lines? + x-max) + ((and line-end? (fix:= (fix:remainder column x-max) 0)) + x-max) + (else + (fix:remainder column x-max))))) + +(define (column->y column x-size truncate-lines? line-end?) + (let ((x-max (fix:- x-size 1))) + (cond ((or truncate-lines? (fix:< column x-max)) + 0) + ((and line-end? (fix:= (fix:remainder column x-max) 0)) + (fix:- (fix:quotient column x-max) 1)) + (else + (fix:quotient column x-max))))) + +(define-integrable (coordinates->column x y x-size) + (fix:+ x (fix:* y (fix:- x-size 1)))) \ No newline at end of file diff --git a/edwin/c-mode.scm b/edwin/c-mode.scm new file mode 100644 index 0000000..515e3ae --- /dev/null +++ b/edwin/c-mode.scm @@ -0,0 +1,274 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C Mode (from GNU Emacs) + +(declare (usual-integrations)) + +(define-major-mode c fundamental "C" + "Major mode for editing C code. +Expression and list commands understand all C brackets. +Tab indents for C code. +Comments are delimited with /* ... */. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. + +Variables controlling indentation style: + c-tab-always-indent + True means TAB in C mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + c-auto-newline + True means automatically newline before and after braces, + and after colons and semicolons, inserted in C code. + c-indent-level + Indentation of C statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + c-continued-statement-offset + Extra indentation given to a substatement, such as the + then-clause of an if or body of a while. + c-continued-brace-offset + Extra indent for substatements that start with open-braces. + This is in addition to c-continued-statement-offset. + c-brace-offset + Extra indentation for line if it starts with an open brace. + c-brace-imaginary-offset + An open brace following other text is treated as if it were + this far to the right of the start of its line. + c-argdecl-indent + Indentation level of declarations of C function arguments. + c-label-offset + Extra indentation for line that is a label, or case or default. + +Settings for K&R and BSD indentation styles are + c-indent-level 5 8 + c-continued-statement-offset 5 8 + c-brace-offset -5 -8 + c-argdecl-indent 0 8 + c-label-offset -5 -8 + +\\{c}" + (lambda (buffer) + (local-set-variable! syntax-table c-syntax-table buffer) + (local-set-variable! syntax-ignore-comments-backwards #t buffer) + (standard-alternate-paragraph-style! buffer) + (local-set-variable! paragraph-ignore-fill-prefix #t buffer) + (local-set-variable! indent-line-procedure (ref-command c-indent-command) + buffer) + (local-set-variable! require-final-newline #t buffer) + (local-set-variable! comment-start "/* " buffer) + (local-set-variable! comment-end " */" buffer) + (local-set-variable! comment-column 32 buffer) + (local-set-variable! comment-locator-hook c-comment-locate buffer) + (local-set-variable! comment-indent-hook c-comment-indent buffer) + (local-set-variable! local-abbrev-table + (ref-variable c-mode-abbrev-table buffer) + buffer) + (event-distributor/invoke! (ref-variable c-mode-hook buffer) buffer))) + +(define-command c-mode + "Enter C mode." + () + (lambda () (set-current-major-mode! (ref-mode-object c)))) + +(define-variable c-mode-abbrev-table + "Mode-specific abbrev table for C code.") +(define-abbrev-table 'c-mode-abbrev-table '()) + +(define-variable c-mode-hook + "An event distributor that is invoked when entering C mode." + (make-event-distributor)) + +(define c-syntax-table + (let ((syntax-table (make-char-syntax-table))) + (for-each (lambda (char) (set-char-syntax! syntax-table char ".")) + (string->list "+-=%<>&|")) + (set-char-syntax! syntax-table #\' "\"") + (set-char-syntax! syntax-table #\\ "\\") + (set-char-syntax! syntax-table #\/ ". 14") + (set-char-syntax! syntax-table #\* ". 23") + syntax-table)) + +(define (c-comment-locate start) + (and (re-search-forward "/\\*+ *" start (line-end start 0)) + (cons (re-match-start 0) (re-match-end 0)))) + +(define (c-comment-indent start) + (if (re-match-forward "^/\\*" start (line-end start 0)) + 0 + (max (+ (mark-column (horizontal-space-start start)) 1) + (ref-variable comment-column start)))) + +(define-variable c-auto-newline + "True means automatically newline before and after braces, +and after colons and semicolons, inserted in C code." + #f + boolean?) + +(define-variable c-tab-always-indent + "True means TAB in C mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used." + #t + boolean?) + +(define-key 'c #\linefeed 'reindent-then-newline-and-indent) +(define-key 'c #\) 'lisp-insert-paren) +(define-key 'c #\{ 'electric-c-brace) +(define-key 'c #\} 'electric-c-brace) +(define-key 'c #\; 'electric-c-semi) +(define-key 'c #\: 'electric-c-terminator) +(define-key 'c #\c-m-h 'mark-c-procedure) +(define-key 'c #\c-m-q 'indent-c-exp) +(define-key 'c #\rubout 'backward-delete-char-untabify) +(define-key 'c #\tab 'c-indent-command) + +(define-command electric-c-brace + "Insert character and correct line's indentation." + "P" + (lambda (argument) + (let ((point (current-point)) + (char (last-command-key))) + (if (and (not argument) + (line-end? point) + (or (line-blank? point) + (and (ref-variable c-auto-newline) + (begin + ((ref-command c-indent-command) #f) + (insert-newline) + #t)))) + (begin + (insert-char char) + ((ref-command c-indent-command) #f) + (if (ref-variable c-auto-newline) + (begin + (insert-newline) + ((ref-command c-indent-command) #f)))) + ((ref-command self-insert-command) #f)) + (if (eqv? #\} char) + (mark-flash (backward-one-sexp (current-point)) 'RIGHT))))) + +(define-command electric-c-semi + "Insert character and correct line's indentation." + "P" + (lambda (argument) + (if (ref-variable c-auto-newline) + ((ref-command electric-c-terminator) argument) + ((ref-command self-insert-command) argument)))) + +(define-command electric-c-terminator + "Insert character and correct line's indentation." + "P" + (lambda (argument) + (let ((point (current-point)) + (char (last-command-key))) + (if (and (not argument) + (line-end? point) + (not (let ((mark (indentation-end point))) + (or (char-match-forward #\# mark) + ;; Colon is special only after a label, or + ;; case. So quickly rule out most other + ;; uses of colon and do no indentation for + ;; them. + (and (eqv? #\: char) + (not (re-match-forward "case\\b" + mark + (line-end mark 0) + #f)) + (mark< (skip-chars-forward + " \t" + (skip-chars-forward "a-zA-Z0-9_$" mark)) + point)) + (let ((state + (parse-partial-sexp + (backward-definition-start point 1 'LIMIT) + point))) + (or (parse-state-in-string? state) + (parse-state-in-comment? state) + (parse-state-quoted? state))))))) + (begin + (insert-char char) + ((ref-command c-indent-command) #f) + (if (and (ref-variable c-auto-newline) + (not (c-inside-parens? point))) + (begin + (insert-newline) + ((ref-command c-indent-command) #f)))) + ((ref-command self-insert-command) argument))))) + +(define (c-inside-parens? mark) + (let ((container (backward-up-list mark 1 #f))) + (and container + (mark>= container (backward-definition-start mark 1 'LIMIT)) + (char-match-forward #\( container)))) + +(define-command mark-c-procedure + "Put mark at end of C procedure, point at beginning." + () + (lambda () + (push-current-mark! (current-point)) + (let ((end (forward-definition-end (current-point) 1 'LIMIT))) + (push-current-mark! end) + (set-current-point! + (backward-paragraph (backward-definition-start end 1 'LIMIT) + 1 + 'LIMIT))))) + +(define-command c-indent-command + "Indent current line as C code, or in some cases insert a tab character. +If c-tab-always-indent is true (the default), always indent current line. +Otherwise, indent the current line only if point is at the left margin +or in the line's indentation; otherwise insert a tab. + +A numeric argument, regardless of its value, +means indent rigidly all the lines of the expression starting after point +so that this line becomes properly indented. +The relative indentation among the lines of the expression are preserved." + "P" + (lambda (#!optional argument) + (let ((point (current-point))) + (cond ((and (not (default-object? argument)) argument) + (let ((shift-amount (c-indent-line point)) + (start + (if (ref-variable c-tab-always-indent) + (line-start point 0) + point))) + (indent-code-rigidly start + (forward-sexp start 1 'ERROR) + shift-amount + "#"))) + ((or (ref-variable c-tab-always-indent) + (within-indentation? point)) + (c-indent-line point) + (if (within-indentation? point) + (set-current-point! (indentation-end point)))) + (else + ((ref-command insert-tab))))))) + +(define-command indent-c-exp + "Indent each line of the C grouping following point." + () + (lambda () + (c-indent-expression (current-point)))) \ No newline at end of file diff --git a/edwin/calias.scm b/edwin/calias.scm new file mode 100644 index 0000000..2857442 --- /dev/null +++ b/edwin/calias.scm @@ -0,0 +1,290 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Alias Keys + +(declare (usual-integrations)) + +(define alias-keys '()) + +(define (define-alias-key key alias) + (let ((entry (assq key alias-keys))) + (if entry + (set-cdr! entry alias) + (set! alias-keys (cons (cons key alias) alias-keys)))) + unspecific) + +(define (undefine-alias-key key) + (set! alias-keys (del-assq! key alias-keys)) + unspecific) + +(define (remap-alias-key key) + (let ((entry (assq key alias-keys))) + (cond (entry + (remap-alias-key (cdr entry))) + ((and (char? key) + (char-bits-set? char-bit:control key)) + (let ((code (char-code key)) + (remap + (lambda (code) + (make-char code + (fix:andc (char-bits key) char-bit:control))))) + (cond ((<= #x40 code #x5F) (remap (- code #x40))) + ((<= #x61 code #x7A) (remap (- code #x60))) + (else key)))) + (else key)))) + +(define (unmap-alias-key key) + (if (and (char? key) + (ascii-controlified? key) + (let ((code (char-code key))) + (not (or (= code #x09) ;tab + (= code #x0A) ;linefeed + (= code #x0C) ;page + (= code #x0D) ;return + (= code #x1B) ;altmode + ))) + (char-bits-clear? char-bit:control key)) + (unmap-alias-key + (make-char (let ((code (char-code key))) + (+ code (if (<= #x01 code #x1A) #x60 #x40))) + (fix:or (char-bits key) char-bit:control))) + (let ((entry + (find (lambda (entry) + (eqv? (cdr entry) key)) + alias-keys))) + (if entry + (unmap-alias-key (car entry)) + key)))) + +(define-variable enable-emacs-key-names + "True means keys are shown using Emacs-style names." + #t + boolean?) + +(define (key-name key) + (cond ((ref-variable enable-emacs-key-names) (emacs-key-name key #t)) + ((char? key) (char->name (unmap-alias-key key))) + ((special-key? key) (special-key/name key)) + ((button? key) (button-name key)) + (else (error:wrong-type-argument key "key" 'key-name)))) + +(define (xkey->name xkey) + (let ((keys (xkey->list xkey))) + (string-append-separated + (key-name (car keys)) + (let ((key-name + (if (ref-variable enable-emacs-key-names) + (lambda (key) + (emacs-key-name key #f)) + (lambda (key) + (key-name (unmap-alias-key key)))))) + (let loop ((keys (cdr keys))) + (if (pair? keys) + (string-append-separated (key-name (car keys)) + (loop (cdr keys))) + "")))))) + +(define (emacs-key-name key handle-prefixes?) + (cond ((char? key) + (let ((code (char-code key)) + (bits (char-bits key))) + (define (prefix bits suffix) + (if (zero? bits) + suffix + (string-append "M-" suffix))) + (define (process-code bits) + (if (<= code #x20) + (cond ((= code #x09) (prefix bits "TAB")) + ((= code #x0A) (prefix bits "LFD")) + ((= code #x0D) (prefix bits "RET")) + ((= code #x1B) (prefix bits "ESC")) + ((= code #x20) (prefix bits "SPC")) + (else + (string-append (if (zero? bits) "C-" "C-M-") + (string + (integer->char + (+ (if (<= #x01 code #x1A) #x60 #x40) + code)))))) + (prefix bits + (if (= code #x7F) + "DEL" + (vector-ref (ref-variable char-image-strings #f) + code))))) + (cond ((or (fix:= bits 0) + (fix:= bits char-bit:meta)) + (process-code bits)) + ((and handle-prefixes? + (not (fix:= 0 (fix:and bits + (fix:or char-bit:control + char-bit:meta))))) + (string-append (if (fix:= bits char-bit:control) + "C-^ " + "C-z ") + (process-code 0))) + (else + (char->name (unmap-alias-key key)))))) + ((special-key? key) (special-key/name key)) + ((button? key) (button-name key)) + (else (error:wrong-type-argument key "key" 'emacs-key-name)))) + +(define (key? object) + (or (char? object) + (special-key? object) + (button? object))) + +(define (key-bucky-bits key) + (cond ((char? key) (char-bits key)) + ((special-key? key) (special-key/bucky-bits key)) + ((button? key) (button-bits key)) + (else (error:wrong-type-argument key "key" 'key-bucky-bits)))) + +(define (keylist x)) (y (xkey->list y))) + (or (keylist xkey) + (cond ((or (key? xkey) (button? xkey)) + (list xkey)) + ((and (pair? xkey) + (list-of-type? xkey key?)) + xkey) + ((and (string? xkey) + (not (string-null? xkey))) + (string->list xkey)) + (else + (error "Not a key or list of keys" xkey)))) + +;;;; Special Keys (system-dependent) + +(define-structure (special-key (constructor %make-special-key) + (conc-name special-key/) + (print-procedure + (standard-print-method 'special-key + (lambda (key) + (list (special-key/name key)))))) + (symbol #f read-only #t) + (bucky-bits #f read-only #t)) + +(define (intern-special-key name bucky-bits) + (let ((name-entry (assq name (cdr hashed-keys)))) + (if name-entry + (let ((bits-entry (assq bucky-bits (cdr name-entry)))) + (if bits-entry + (cdr bits-entry) + (let ((new-key (%make-special-key name bucky-bits))) + (set-cdr! name-entry + (cons (cons bucky-bits new-key) + (cdr name-entry))) + new-key))) + (let ((new-key (%make-special-key name bucky-bits))) + (set-cdr! hashed-keys + (cons (cons name (list (cons bucky-bits new-key))) + (cdr hashed-keys))) + new-key)))) + +(define (special-key/name special-key) + (string-append (bucky-bits->prefix (special-key/bucky-bits special-key)) + (symbol->string (special-key/symbol special-key)))) + +(define (make-special-key name bits) + (hook/make-special-key name bits)) + +(define hashed-keys (list 'hashed-keys)) +(define hook/make-special-key intern-special-key) + +;; Predefined special keys +(define-syntax define-special-key + (sc-macro-transformer + (lambda (form environment) + environment + `(define ,(cadr form) + (intern-special-key ',(cadr form) 0))))) + +(define-special-key backspace) +(define-special-key stop) +(define-special-key f1) +(define-special-key f2) +(define-special-key f3) +(define-special-key f4) +(define-special-key menu) +(define-special-key system) +(define-special-key user) +(define-special-key f5) +(define-special-key f6) +(define-special-key f7) +(define-special-key f8) +(define-special-key f9) +(define-special-key f10) +(define-special-key f11) +(define-special-key f12) +(define-special-key insertline) +(define-special-key deleteline) +(define-special-key insertchar) +(define-special-key deletechar) +(define-special-key home) +(define-special-key prior) +(define-special-key next) +(define-special-key up) +(define-special-key down) +(define-special-key left) +(define-special-key right) +(define-special-key select) +(define-special-key print) \ No newline at end of file diff --git a/edwin/cinden.scm b/edwin/cinden.scm new file mode 100644 index 0000000..add6163 --- /dev/null +++ b/edwin/cinden.scm @@ -0,0 +1,416 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C Indentation (from GNU Emacs) + +(declare (usual-integrations)) + +(define-variable c-indent-level + "Indentation of C statements with respect to containing block." + 2 + exact-integer?) + +(define-variable c-brace-imaginary-offset + "Imagined indentation of a C open brace that actually follows a statement." + 0 + exact-integer?) + +(define-variable c-brace-offset + "Extra indentation for braces, compared with other text in same context." + 0 + exact-integer?) + +(define-variable c-argdecl-indent + "Indentation level of declarations of C function arguments." + 5 + exact-integer?) + +(define-variable c-label-offset + "Offset of C label lines and case statements relative to usual indentation." + -2 + exact-integer?) + +(define-variable c-continued-statement-offset + "Extra indent for lines not starting new statements." + 2 + exact-integer?) + +(define-variable c-continued-brace-offset + "Extra indent for substatements that start with open-braces. +This is in addition to c-continued-statement-offset." + 0 + exact-integer?) + +(define (c-indent-line start) + (let ((old-indentation (mark-indentation start)) + (new-indentation (c-compute-indentation start))) + (if (not (fix:= new-indentation old-indentation)) + (change-indentation new-indentation start)) + (- new-indentation old-indentation))) + +(define (c-compute-indentation start) + (let ((start (line-start start 0))) + (let ((indentation (calculate-indentation start #f))) + (if (exact-integer? indentation) + (if (char-match-forward #\# start) + 0 + (indent-line:adjust-indentation (horizontal-space-end start) + indentation)) + (nonstandard-indentation start indentation))))) + +(define (nonstandard-indentation start state) + (cond ((parse-state-in-string? state) + (mark-indentation start)) + ((parse-state-in-comment? state) + (mark-column + (let ((comment-start (parse-state-comment-start state))) + (if (and (char-match-forward #\* (indentation-end start)) + (match-forward "/*" comment-start)) + (mark1+ comment-start) + (or (re-match-forward "/\\(/+\\|\\*+\\)[ \t]*" + comment-start) + comment-start))))) + (else + (error "Illegal non-standard indentation:" state)))) + +(define (indent-line:adjust-indentation start indentation) + (cond ((or (looking-at-keyword? "case" start) + (and (re-match-forward "[A-Za-z]" start) + (char-match-forward #\: (forward-sexp start 1 'LIMIT)))) + (max 1 (+ indentation (ref-variable c-label-offset start)))) + ((looking-at-keyword? "else" start) + (mark-indentation + (backward-to-start-of-if + start + (backward-definition-start start 1 'LIMIT)))) + ((char-match-forward #\} start) + (max 0 (- indentation (ref-variable c-indent-level start)))) + ((char-match-forward #\{ start) + (max 0 (+ indentation (ref-variable c-brace-offset start)))) + (else (max 0 indentation)))) + +(define (calculate-indentation mark parse-start) + (let ((indent-point (line-start mark 0))) + (let ((state + (let loop + ((start + (or parse-start (backward-definition-start mark 1 'LIMIT)))) + (let ((state (parse-partial-sexp start indent-point 0))) + (if (mark= (parse-state-location state) indent-point) + state + (loop (parse-state-location state))))))) + (let ((container (parse-state-containing-sexp state))) + (cond ((or (parse-state-in-string? state) + (parse-state-in-comment? state)) + state) + ((not container) + (calculate-indentation:top-level indent-point + (or parse-start + (group-start mark)))) + ((char-match-forward #\{ container) + (calculate-indentation:statement indent-point container)) + (else + ;; Line is expression, not statement: indent to just + ;; after the surrounding open. + (mark-column (mark1+ container)))))))) + +(define (calculate-indentation:top-level indent-point parse-start) + (if (or (re-match-forward "[ \t]*{" indent-point) + (function-start? indent-point parse-start)) + ;; This appears to be the start of a function or a function + ;; body, so indent in the left-hand column. + 0 + (let ((m (backward-to-noncomment indent-point parse-start))) + (if (or (not m) (not (extract-left-char m))) + ;; This appears to be the beginning of a top-level data + ;; definition, so indent in the left-hand column. + 0 + ;; Look at the previous left-justified line to determine + ;; if we're in a data definition or a function preamble. + (let ((m (re-search-backward "^[^ \t\n\f#]" m))) + (if (not m) + 0 + (let ((m (function-start? m parse-start))) + (if (and m (mark< m indent-point)) + ;; Previous line is a function start and we're + ;; indenting a line that follows the parameter + ;; list and precedes the body, so indent it as + ;; a parameter declaration. + (ref-variable c-argdecl-indent indent-point) + 0)))))))) + +(define (function-start? lstart parse-start) + ;; True iff LSTART points at the beginning of a function definition. + ;; If true, returns a mark pointing to the end of the function's + ;; parameter list. + (and (re-match-forward "\\sw\\|\\s_" lstart) + (re-match-forward "[^\"\n=(]*(" lstart) + (let ((open (mark-1+ (re-match-end 0)))) + ;; OPEN looks like the start of a parameter list. If it + ;; doesn't end in comma or semicolon, and furthermore isn't + ;; in a comment, we conclude that it is a parameter list, and + ;; consequently that we're looking at a function. + (and (not (parse-state-in-comment? + (parse-partial-sexp parse-start open))) + (let ((m (forward-sexp open 1))) + (and m + (let ((m (skip-chars-forward " \t\f" m))) + (and (not (re-match-forward "[,;]" m)) + m)))))))) + +(define (calculate-indentation:statement indent-point container) + (let ((mark + (let loop ((start indent-point)) + (let ((m (backward-to-noncomment start container))) + ;; Back up over label lines, since they don't affect + ;; whether our line is a continuation. + (case (and m (mark> m container) (extract-left-char m)) + ((#\:) + (if (let ((m (backward-to-noncomment (mark-1+ m) container))) + (and m + (mark> m container) + (re-match-forward "'\\|\\sw\\|\\s_" (mark-1+ m)))) + (loop (line-start m 0)) + m)) + ((#\,) + (let ((ls (line-start m 0))) + (if (mark<= ls container) + #f + (loop (horizontal-space-end ls))))) + (else m)))))) + (if (and mark (not (memv (extract-left-char mark) '(#F #\, #\; #\{ #\})))) + ;; This line is continuation of preceding line's statement; + ;; indent c-continued-statement-offset more than the previous + ;; line of the statement. + (+ (ref-variable c-continued-statement-offset indent-point) + (mark-column (backward-to-start-of-continued-exp mark container)) + (if (re-match-forward "[ \t]*{" indent-point) + (ref-variable c-continued-brace-offset indent-point) + 0)) + (or (skip-comments&labels (mark1+ container) indent-point) + ;; If no previous statement, indent it relative to line + ;; brace is on. For open brace in column zero, don't let + ;; statement start there too. If c-indent-level is zero, + ;; use c-brace-offset + c-continued-statement-offset + ;; instead. For open-braces not the first thing in a + ;; line, add in c-brace-imaginary-offset. + (+ (if (and (line-start? container) + (= 0 (ref-variable c-indent-level indent-point))) + (+ (ref-variable c-brace-offset indent-point) + (ref-variable c-continued-statement-offset indent-point)) + (ref-variable c-indent-level indent-point)) + (let ((container (skip-chars-backward " \t" container))) + ;; If open brace is not the first non-white thing on + ;; the line, add the c-brace-imaginary-offset. + (+ (if (line-start? container) + 0 + (ref-variable c-brace-imaginary-offset indent-point)) + (mark-indentation + ;; If the open brace is preceded by a + ;; parenthesized expression, move to the + ;; beginning of that; possibly a different line. + (if (eqv? #\) (extract-left-char container)) + (backward-sexp container 1 'LIMIT) + container))))))))) + +(define (skip-comments&labels start end) + (let ((gend (group-end start))) + (let loop ((mark start) (colon-line-end false)) + (let ((mark (whitespace-end mark gend))) + (cond ((mark>= mark end) + false) + ((or (char-match-forward #\# mark) + (match-forward "//" mark)) + (loop (line-start mark 1 'LIMIT) colon-line-end)) + ((match-forward "/*" mark) + (loop (or (search-forward "*/" mark gend) gend) colon-line-end)) + ((re-match-forward "case[ \t\n].*:\\|[a-zA-Z0-9_$]*[ \t\n]*:" + mark gend false) + (loop (re-match-end 0) (line-end mark 0))) + ((and colon-line-end (mark> colon-line-end mark)) + (- (mark-indentation mark) + (ref-variable c-label-offset mark))) + (else + (mark-column mark))))))) + +(define (c-indent-expression expression-start) + (let ((end + (mark-left-inserting-copy + (line-start (forward-sexp expression-start 1 'ERROR) 0)))) + (if (mark< expression-start end) + (let loop + ((start expression-start) + (state false) + (indent-stack (list false)) + (contain-stack (list expression-start)) + (last-depth 0)) + (call-with-values + (lambda () (c-indent-expression:parse-line start end state)) + (lambda (start state) + (let* ((depth (parse-state-depth state)) + (depth-delta (- depth last-depth)) + (indent-stack (adjust-stack depth-delta indent-stack)) + (contain-stack (adjust-stack depth-delta contain-stack)) + (indent-line + (lambda () + (if (not (line-blank? start)) + (c-indent-expression:per-line + (skip-chars-forward " \t" start) + expression-start + indent-stack + contain-stack))))) + (if (not (car contain-stack)) + (set-car! contain-stack + (or (parse-state-containing-sexp state) + (backward-sexp start 1 'LIMIT)))) + (if (mark= start end) + (begin + (mark-temporary! end) + (indent-line)) + (begin + (indent-line) + (loop start state indent-stack contain-stack + depth)))))))))) + +(define (c-indent-expression:parse-line start end state) + (let loop ((start start) (state state)) + (if (and state (parse-state-in-comment? state)) + (c-indent-line start)) + (let ((start* (line-start start 1))) + (let ((state* (parse-partial-sexp start start* false false state))) + (cond ((mark= start* end) + (values start* state*)) + ((parse-state-in-comment? state*) + (if (not (and state (parse-state-in-comment? state))) + (c-comment-indent (parse-state-comment-start state*))) + (loop start* state*)) + ((parse-state-in-string? state*) + (loop start* state*)) + (else + (values start* state*))))))) + +(define (c-indent-expression:per-line start expression-start + indent-stack contain-stack) + (let ((indentation + (indent-line:adjust-indentation + start + (cond ((not (car indent-stack)) + (let ((indentation + (let ((indentation (calculate-indentation start #f))) + (if (exact-integer? indentation) + indentation + (nonstandard-indentation start indentation))))) + (set-car! indent-stack indentation) + indentation)) + ((not (char-match-forward #\{ (car contain-stack))) + (car indent-stack)) + (else + ;; Line is at statement level. Is it a new + ;; statement? Is it an else? Find last non-comment + ;; character before this line. + (let ((mark (backward-to-noncomment start expression-start))) + (cond ((not (memv (extract-left-char mark) + '(#F #\, #\; #\} #\: #\{))) + (+ (ref-variable c-continued-statement-offset mark) + (mark-column + (backward-to-start-of-continued-exp + mark + (car contain-stack))) + (if (char-match-forward #\{ start) + (ref-variable c-continued-brace-offset mark) + 0))) + ((looking-at-keyword? "else" start) + (mark-indentation + (backward-to-start-of-if mark expression-start))) + (else + (car indent-stack))))))))) + (if (not (char-match-forward #\# start)) + (maybe-change-indentation indentation start)))) + +(define (whitespace-start start end) + (skip-chars-backward " \t\n" start end)) + +(define (whitespace-end start end) + (skip-chars-forward " \t\n" start end)) + +(define (looking-at-keyword? keyword start) + (let ((end (line-end start 0))) + (and (re-match-forward (string-append keyword "\\b") start end false) + (not (re-match-forward (string-append keyword "\\s_") start end + false))))) + +(define (backward-to-noncomment start end) + (let loop ((start start)) + (let ((mark + (let ((mark (whitespace-start start end))) + (or (match-backward "*/" mark) + mark)))) + (let ((state (parse-partial-sexp end mark))) + (if (parse-state-in-comment? state) + (loop (parse-state-comment-start state)) + (let ((mark* (indentation-end mark))) + (cond ((not (char-match-forward #\# mark*)) mark) + ((mark<= mark* end) mark*) + (else (loop mark*))))))))) + +(define (backward-to-start-of-continued-exp start end) + (let ((mark + (line-start (if (char-match-backward #\) start) + (backward-sexp start 1 'LIMIT) + start) + 0))) + (horizontal-space-end (if (mark<= mark end) (mark1+ end) mark)))) + +(define (backward-to-start-of-if start end) + (let loop ((mark start) (if-level 1)) + (let ((mark (backward-sexp mark 1 'LIMIT))) + (let ((adjust-level + (lambda (if-level) + (if (= if-level 0) + mark + (loop mark if-level))))) + (cond ((looking-at-keyword? "else" mark) + (adjust-level (+ if-level 1))) + ((looking-at-keyword? "if" mark) + (adjust-level (- if-level 1))) + ((mark>= mark end) + (adjust-level if-level)) + (else + end)))))) + +(define (adjust-stack depth-delta stack) + (cond ((= depth-delta 0) + stack) + ((> depth-delta 0) + (let loop ((depth-delta depth-delta) (stack stack)) + (if (= 1 depth-delta) + (cons false stack) + (loop (- depth-delta 1) (cons false stack))))) + (else + (let loop ((depth-delta depth-delta) (stack stack)) + (if (= -1 depth-delta) + (cdr stack) + (loop (+ depth-delta 1) (cdr stack))))))) \ No newline at end of file diff --git a/edwin/class.scm b/edwin/class.scm new file mode 100644 index 0000000..f477227 --- /dev/null +++ b/edwin/class.scm @@ -0,0 +1,111 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Class/Object System + +(declare (usual-integrations)) + +;;; ****************************************************************** +;;; This software is intended for use in the Edwin window system only. +;;; Don't think about using it for anything else, since it is not, and +;;; likely will not ever, be supported as a part of the Scheme system. +;;; ****************************************************************** + +(define-structure (class (constructor %make-class)) + (name false read-only true) + (superclass false read-only true) + object-size + instance-transforms + (methods false read-only true)) + +(define (class-method class name) + (class-methods/ref (class-methods class) name)) + +(define (class-methods/ref methods name) + (or (method-lookup methods name) + (error "Unknown method:" name))) + +(define (method-lookup methods name) + (let loop ((methods methods)) + (and methods + (let ((entry (assq name (car methods)))) + (if entry + (cdr entry) + (loop (cdr methods))))))) + +(define (class-method-define class name method) + (let ((methods (class-methods class))) + (let ((entry (assq name (car methods)))) + (if entry + (set-cdr! entry method) + (set-car! methods (cons (cons name method) (car methods)))))) + name) + +(define-integrable (usual-method class name) + (class-method (class-superclass class) name)) + +(define (subclass? class class*) + (or (eq? class class*) + (let loop ((class (class-superclass class))) + (and class + (or (eq? class class*) + (loop (class-superclass class))))))) + +(define (make-object class) + (if (not (class? class)) + (error:wrong-type-argument class "class" 'MAKE-OBJECT)) + (let ((object (make-vector (class-object-size class) false))) + (vector-set! object 0 class) + object)) + +(define (object? object) + (and (vector? object) + (not (zero? (vector-length object))) + (class? (vector-ref object 0)))) + +(define (object-of-class? class object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? class (vector-ref object 0)))) + +(define-integrable (object-class object) + (vector-ref object 0)) + +(define-integrable (object-methods object) + (class-methods (object-class object))) + +(define-integrable (object-method object name) + (class-method (object-class object) name)) + +(define (send object operation . args) + (apply (object-method object operation) object args)) + +(define (send-if-handles object operation . args) + (let ((method (method-lookup (object-methods object) operation))) + (and method (apply method object args)))) + +(define (send-usual class object operation . args) + (apply (usual-method class operation) object args)) \ No newline at end of file diff --git a/edwin/clscon.scm b/edwin/clscon.scm new file mode 100644 index 0000000..0b63ff0 --- /dev/null +++ b/edwin/clscon.scm @@ -0,0 +1,99 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Class/Object System: Class Constructor + +(declare (usual-integrations)) + +;;; ****************************************************************** +;;; This software is intended for use in the Edwin window system only. +;;; Don't think about using it for anything else, since it is not, and +;;; likely will not ever, be supported as a part of the Scheme system. +;;; ****************************************************************** + +(define (make-class name superclass variables) + (let ((entry (assq name class-descriptors)) + (object-size + (+ (length variables) + (if superclass (class-object-size superclass) 1))) + (transforms (make-instance-transforms superclass variables))) + (let ((make-class + (lambda () + (let ((class + (%make-class name + superclass + object-size + transforms + (cons '() + (and superclass + (class-methods superclass)))))) + (named-structure/set-tag-description! class + (new-make-define-structure-type + 'VECTOR + name + (list->vector (map car transforms)) + (list->vector (map cdr transforms)) + (make-vector (length transforms) (lambda () #f)) + class + object-size)) + class)))) + (if (not entry) + (let ((class (make-class))) + (set! class-descriptors (cons (cons name class) class-descriptors)) + class) + (let ((class (cdr entry))) + (cond ((not (eq? (class-superclass class) superclass)) + (let ((class (make-class))) + (set-cdr! entry class) + class)) + ((and (= object-size (class-object-size class)) + (equal? transforms (class-instance-transforms class))) + class) + (else + (warn "Redefining class:" name) + (set-class-object-size! class object-size) + (set-class-instance-transforms! class transforms) + class))))))) + +(define (make-instance-transforms superclass variables) + (define (generate variables n) + (if (pair? variables) + (cons (cons (car variables) n) + (generate (cdr variables) (+ n 1))) + '())) + (if superclass + (append (class-instance-transforms superclass) + (generate variables (class-object-size superclass))) + (generate variables 1))) + +(define (name->class name) + (let ((entry (assq name class-descriptors))) + (if (not entry) + (error "Unknown class name:" name)) + (cdr entry))) + +(define class-descriptors + '()) \ No newline at end of file diff --git a/edwin/clsmac.scm b/edwin/clsmac.scm new file mode 100644 index 0000000..3448148 --- /dev/null +++ b/edwin/clsmac.scm @@ -0,0 +1,123 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Class/Object System + +(declare (usual-integrations)) + +;;; ****************************************************************** +;;; This software is intended for use in the Edwin window system only. +;;; Don't think about using it for anything else, since it is not, and +;;; likely will not ever, be supported as a part of the Scheme system. +;;; ****************************************************************** + +(define-syntax define-class + (rsc-macro-transformer + (lambda (form environment) + (if (and (syntax-match? '(identifier datum (* symbol)) (cdr form)) + (or (identifier? (caddr form)) + (null? (caddr form)))) + (let ((name (cadr form)) + (superclass (if (null? (caddr form)) #f (caddr form))) + (variables (cadddr form))) + ;; Compile-time definition. + (make-class (identifier->symbol name) + (and superclass + (name->class (identifier->symbol superclass))) + variables) + ;; Load-time definition. + `(,(close-syntax 'define environment) + ,name + (,(close-syntax 'make-class environment) + ',(identifier->symbol name) + ,superclass + ',variables))) + (ill-formed-syntax form))))) + +(define-syntax define-method + (rsc-macro-transformer + (lambda (form environment) + (let ((finish + (lambda (name operation expression) + `(,(close-syntax 'class-method-define environment) + ,name + ',operation + ,expression)))) + (cond ((syntax-match? '(identifier symbol expression) (cdr form)) + (finish (cadr form) (caddr form) (cadddr form))) + ((and (syntax-match? '(identifier (symbol . mit-bvl) + expression) + (cdr form)) + (pair? (cdr (caddr form))) + (identifier? (cadr (caddr form)))) + (finish (cadr form) + (car (caddr form)) + `(,(close-syntax 'named-lambda environment) + ,(caddr form) + (,(close-syntax 'with-instance-variables environment) + ,(cadr form) + ,(cadr (caddr form)) + () + ,@(cdddr form))))) + (else + (ill-formed-syntax form))))))) + +(define with-instance-variables + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ identifier expression (* identifier) + expression) form) + (let ((class-name (cadr form)) + (self-item + (classify-form (caddr form) senv (hist-car (hist-cddr hist)))) + (free-names (cadddr form)) + (body-item + (classify-form `(,(close-syntax 'begin + (runtime-environment->syntactic + system-global-environment)) + ,@(cddddr form)) + senv + (hist-cddr (hist-cddr hist))))) + (expr-item #f (list self-item body-item) + (lambda (self body) + (transform-instance-variables + (class-instance-transforms + (name->class (identifier->symbol class-name))) + self + free-names + body)) + (lambda (self body) + `(with-instance-variables ,class-name ,self ,free-names ,body))))))) + +(define-syntax ==> + (syntax-rules () + ((==> object operation argument ...) + (let ((temp object)) + ((object-method temp 'operation) temp argument ...))))) + +(define-syntax usual==> + (syntax-rules () + ((usual==> object operation argument ...) + (let ((temp object)) + ((usual-method (object-class temp) 'operation) temp argument ...))))) \ No newline at end of file diff --git a/edwin/comatch.scm b/edwin/comatch.scm new file mode 100644 index 0000000..718ffab --- /dev/null +++ b/edwin/comatch.scm @@ -0,0 +1,151 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Combinatoric Matcher + +(declare (usual-integrations)) + +;;; This matcher allows compex matching patterns to be built up from +;;; primitives using combinators. With this implementation, the +;;; patterns are just procedures, but it is simple to change the +;;; implementation so that they use a different representation. + +;;; Each pattern takes two arguments: a start mark and an end mark. +;;; The pattern matches itself against the buffer's contents between +;;; the two marks. A successful match returns a mark to the right of +;;; the rightmost character in the match. A failed match returns #F. + +(define (comatch-apply comatcher start #!optional end) + (comatcher start + (if (default-object? end) (group-end start) end))) + +(define (comatch:general procedure) procedure) + +(define comatch:false (comatch:general (lambda (start end) start end #f))) +(define comatch:true (comatch:general (lambda (start end) end start))) + +(define comatch:to-sexp (comatch:general forward-to-sexp-start)) +(define comatch:sexp (comatch:general forward-one-sexp)) + +(define (comatch:char char #!optional case-fold?) + (if (or (default-object? case-fold?) (not case-fold?)) + (comatch:general + (lambda (start end) + (and (mark< start end) + (char=? char (extract-right-char start)) + (mark1+ start)))) + (comatch:general + (lambda (start end) + (and (mark< start end) + (char-ci=? char (extract-right-char start)) + (mark1+ start)))))) + +(define (comatch:string string #!optional case-fold?) + (let ((case-fold? (if (default-object? case-fold?) #f case-fold?))) + (comatch:general + (lambda (start end) + (match-forward string start end case-fold?))))) + +(define (comatch:regexp regexp #!optional case-fold?) + (let ((regexp + (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp + (if (default-object? case-fold?) + #f + case-fold?))))) + (comatch:general + (lambda (start end) + (re-match-forward regexp start end))))) + +(define (comatch:skip-chars pattern) + (comatch:general + (lambda (start end) + (skip-chars-forward pattern start end)))) + +;;;; Combinators + +(define (comatch:* comatcher) + (comatch:general + (lambda (start end) + (let loop ((start start)) + (let ((mark (comatch-apply comatcher start end))) + (if mark + (loop mark) + start)))))) + +(define (comatch:+ comatcher) + (let ((tail (comatch:* comatcher))) + (comatch:general + (lambda (start end) + (let ((mark (comatch-apply comatcher start end))) + (and mark + (tail mark end))))))) + +(define (comatch:? comatcher) + (comatch:general + (lambda (start end) + (or (comatch-apply comatcher start end) start)))) + +(define (comatch:not comatcher) + (comatch:general + (lambda (start end) + (and (not (comatch-apply comatcher start end)) + start)))) + +(define (comatch:combine-rest initial combine-2) + (lambda comatchers + (if (null? comatchers) + initial + (let loop ((comatchers comatchers)) + (if (null? (cdr comatchers)) + (car comatchers) + (combine-2 (car comatchers) (loop (cdr comatchers)))))))) + +(define comatch:append + (comatch:combine-rest comatch:true + (lambda (c1 c2) + (comatch:general + (lambda (start end) + (let ((start (comatch-apply c1 start end))) + (and start + (comatch-apply c2 start end)))))))) + +(define comatch:or + (comatch:combine-rest comatch:true + (lambda (c1 c2) + (comatch:general + (lambda (start end) + (or (comatch-apply c1 start end) + (comatch-apply c2 start end))))))) + +(define comatch:and + (comatch:combine-rest comatch:true + (lambda (c1 c2) + (comatch:general + (lambda (start end) + (and (comatch-apply c1 start end) + (comatch-apply c2 start end))))))) \ No newline at end of file diff --git a/edwin/comhst.scm b/edwin/comhst.scm new file mode 100644 index 0000000..706f645 --- /dev/null +++ b/edwin/comhst.scm @@ -0,0 +1,130 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Command interpreter history +;;; Translated from "comint.el", by Olin Shivers. + +(declare (usual-integrations)) + +(define-variable-per-buffer comint-input-ring-size + "Size of input history ring." + 30) + +(define-variable comint-input-ring "" #f) +(variable-permanent-local! (ref-variable-object comint-input-ring)) + +(define-variable comint-last-input-match "" #f) +(variable-permanent-local! (ref-variable-object comint-last-input-match)) + +(define comint-input-ring-tag '(COMINT-INPUT-RING)) + +(define (comint-record-input ring string) + (if (or (ring-empty? ring) + (not (string=? string (ring-ref ring 0)))) + (ring-push! ring string))) + +(define-command comint-previous-input + "Cycle backwards through input history." + "*p" + (lambda (argument) + (let ((point (current-point)) + (ring (ref-variable comint-input-ring))) + (let ((size (+ (ring-size ring) 1))) + (let ((index + (modulo (+ argument + (command-message-receive comint-input-ring-tag + (lambda (index left right) + (delete-string left right) + (set-current-mark! left) + index) + (lambda () + (push-current-mark! point) + (cond ((positive? argument) 0) + ((negative? argument) 2) + (else 1))))) + size))) + (message (number->string index)) + (if (positive? index) + (without-interrupts + (lambda () + (let ((start (mark-temporary-copy point))) + (insert-string (ring-ref ring (- index 1)) point) + (set-command-message! comint-input-ring-tag + index + (mark-left-inserting-copy start) + (mark-right-inserting-copy point))))) + (set-command-message! comint-input-ring-tag + index point point))))))) + +(define-command comint-next-input + "Cycle forwards through input history." + "*p" + (lambda (argument) + ((ref-command comint-previous-input) (- argument)))) + +(define-command comint-history-search-backward + "Search backwards through the input history for a matching substring." + (lambda () + (list (prompt-for-string "History search backward" + (ref-variable comint-last-input-match)))) + (lambda (string) + (comint-history-search string true))) + +(define-command comint-history-search-forward + "Search forwards through the input history for a matching substring." + (lambda () + (list (prompt-for-string "History search forward" + (ref-variable comint-last-input-match)))) + (lambda (string) + (comint-history-search string false))) + +(define (comint-history-search string backward?) + (let ((ring (ref-variable comint-input-ring)) + (syntax-table (ref-variable syntax-table)) + (pattern (re-compile-pattern (re-quote-string string) false))) + (let ((size (+ (ring-size ring) 1))) + (call-with-values + (lambda () + (command-message-receive comint-input-ring-tag + values + (lambda () + (let ((point (current-point))) + (values (if backward? 0 size) point point))))) + (lambda (start left right) + (let loop ((index start)) + (let ((index (+ index (if backward? 1 -1)))) + (cond ((if backward? (>= index size) (< index 0)) + (set-command-message! comint-input-ring-tag + start left right) + (editor-failure "Not found")) + ((re-string-search-forward pattern + (ring-ref ring (- index 1)) + #f + syntax-table) + (set-variable! comint-last-input-match string) + ((ref-command comint-previous-input) (- index start))) + (else + (loop index)))))))))) \ No newline at end of file diff --git a/edwin/comint.scm b/edwin/comint.scm new file mode 100644 index 0000000..112b6b5 --- /dev/null +++ b/edwin/comint.scm @@ -0,0 +1,496 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Command interpreter subprocess control +;;; Translated from "comint.el", by Olin Shivers. + +(declare (usual-integrations)) + +(define (make-comint mode buffer program . switches) + (let ((buffer + (if (buffer? buffer) + buffer + (find-or-create-buffer buffer)))) + (if (let ((process (get-buffer-process buffer))) + (or (not process) + (not (process-runnable? process)))) + (begin + (comint-exec buffer (buffer-name buffer) program switches) + (set-buffer-major-mode! buffer mode))) + buffer)) + +(define (comint-exec buffer name program switches) + ;; Get rid of any old processes. + (for-each delete-process (buffer-processes buffer)) + (set-buffer-point! buffer (buffer-end buffer)) + (local-set-variable! comint-program-name program buffer) + (apply start-process + name + buffer + (process-environment-bind scheme-subprocess-environment + (string-append + "TERMCAP=emacs:co#" + (number->string + (screen-x-size (selected-screen))) + ":tc=unknown:") + "TERM=emacs" + "EMACS=t") + program + switches)) + +(define-variable-per-buffer comint-prompt-regexp + "Regexp to recognise prompts in the inferior process. +Defaults to \"^\", the null string at BOL. + +Good choices: + Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) + Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" + franz: \"^\\(->\\|<[0-9]*>:\\) *\" + kcl: \"^>+ *\" + shell: \"^[^#$%>]*[#$%>] *\" + T: \"^>+ *\" + +This is a good thing to set in mode hooks." + "^") + +(define-variable comint-last-input-end "" false) + +(define-variable comint-program-name + "File name of program that is running in this buffer." + false) + +(define (comint-strip-carriage-returns buffer) + (let ((process (get-buffer-process buffer))) + (if process + (add-process-filter process process-filter:strip-carriage-returns)))) + +(define process-filter:strip-carriage-returns + (standard-process-filter + (lambda (mark string start end) + (let ((group (mark-group mark))) + (let loop ((start start)) + (let ((cr + (or (substring-find-next-char string start end #\return) + end)) + (index (mark-index mark))) + (group-insert-substring! group index string start cr) + (set-mark-index! mark (fix:+ index (fix:- cr start))) + (if (not (fix:= cr end)) + (loop (fix:+ cr 1))))))))) + +(define-major-mode comint fundamental "Comint" + "Major mode for interacting with an inferior interpreter. +Interpreter name is same as buffer name, sans the asterisks. +Return at end of buffer sends line as input. +Return not at end copies rest of line to end and sends it. + +This mode is typically customised to create inferior-lisp-mode, +shell-mode, etc.. This can be done by setting the hooks +comint-input-sentinel, comint-input-filter, and comint-get-old-input +to appropriate procedures, and the variable comint-prompt-regexp to +the appropriate regular expression. + +An input history is maintained of size comint-input-ring-size, and +can be accessed with the commands comint-next-input [\\[comint-next-input]] and +comint-previous-input [\\[comint-previous-input]]. Commands not keybound by +default are send-invisible, comint-dynamic-complete, and +comint-list-dynamic-completions. + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it. + +Entry to this mode runs the hooks on comint-mode-hook." + (lambda (buffer) + (local-set-variable! mode-line-process '(": %s") buffer) + (local-set-variable! comint-input-ring + (make-ring + (ref-variable comint-input-ring-size buffer)) + buffer) + (local-set-variable! comint-last-input-end + (mark-right-inserting-copy (buffer-end buffer)) + buffer) + (local-set-variable! comint-last-input-match #f buffer) + (event-distributor/invoke! (ref-variable comint-mode-hook buffer) buffer))) + +(define-variable comint-mode-hook + "An event distributor that is invoked when entering Comint mode." + (make-event-distributor)) + +(define-key 'comint #\C-d 'comint-delchar-or-maybe-eof) +(define-key 'comint #\C-m 'comint-send-input) + +(define-key 'comint #\M-p 'comint-previous-input) +(define-key 'comint #\M-n 'comint-next-input) +(define-key 'comint #\M-s 'comint-previous-similar-input) + +(define-key 'comint '(#\C-c #\C-a) 'comint-bol) +(define-key 'comint '(#\C-c #\C-c) 'comint-interrupt-subjob) +(define-key 'comint '(#\C-c #\C-f) 'comint-continue-subjob) +(define-key 'comint '(#\C-c #\C-l) 'comint-show-output) +(define-key 'comint '(#\C-c #\C-o) 'comint-flush-output) +;;(define-key 'comint '(#\C-c #\C-q) 'comint-send-char) +(define-key 'comint '(#\C-c #\C-r) 'comint-history-search-backward) +(define-key 'comint '(#\C-c #\C-s) 'comint-history-search-forward) +(define-key 'comint '(#\C-c #\C-u) 'comint-kill-input) +(define-key 'comint '(#\C-c #\C-w) 'backward-kill-word) +(define-key 'comint '(#\C-c #\C-z) 'comint-stop-subjob) +(define-key 'comint '(#\C-c #\C-\\) 'comint-quit-subjob) + +(define-command comint-send-input + "Send input to process. +After the process output mark, sends all text from the process mark to +point as input to the process. Before the process output mark, calls +value of variable comint-get-old-input to retrieve old input, copies +it to the end of the buffer, and sends it. A terminal newline is also +inserted into the buffer and sent to the process. In either case, +value of variable comint-input-sentinel is called on the input before +sending it. The input is entered into the input history ring, if +value of variable comint-input-filter returns non-false when called on +the input." + () + (lambda () (comint-send-input "\n" false))) + +(define (comint-send-input terminator delete?) + (let ((process (current-process))) + (let ((mark (process-mark process))) + (let ((string + (let ((point (current-point))) + (if (mark>= point mark) + (let ((end (group-end point))) + (set-current-point! end) + (extract-string mark end)) + (let ((string ((ref-variable comint-get-old-input)))) + (delete-string mark (group-end mark)) + (set-current-point! mark) + (insert-string string mark) + string))))) + (let ((point (current-point))) + (move-mark-to! (ref-variable comint-last-input-end) point) + (if ((ref-variable comint-input-filter) string) + (comint-record-input (ref-variable comint-input-ring) string)) + ((ref-variable comint-input-sentinel) string) + (if delete? + (delete-string mark point) + (insert-newline point)) + (move-mark-to! mark point) + (process-send-string process (string-append string terminator))))))) + +(define-variable-per-buffer comint-get-old-input + "Procedure that submits old text in comint mode. +This procedure is called when return is typed while the point is in old text. +It returns the text to be submitted as process input. The default is +comint-get-old-input-default, which grabs the current line and strips off +leading text matching comint-prompt-regexp." + (lambda () + (let ((mark (comint-line-start (current-point)))) + (extract-string mark (line-end mark 0))))) + +(define-variable-per-buffer comint-input-sentinel + "Called on each input submitted to comint mode process by comint-send-input. +Thus it can, for instance, track cd/pushd/popd commands issued to the shell." + (lambda (string) + string + unspecific)) + +(define-variable-per-buffer comint-input-filter + "Predicate for filtering additions to input history. +Only inputs answering true to this procedure are saved on the input +history list. Default is to save anything that isn't all whitespace." + (lambda (string) + (not (re-string-match "\\`\\s *\\'" + string + #f + (ref-variable syntax-table))))) + +(define-command send-invisible + "Read a string without echoing, and send it to the process running +in the current buffer. A new-line is additionally sent. +String is not saved on comint input history list. +Security bug: your string can still be temporarily recovered with +\\[view-lossage]." + () + (lambda () + (call-with-pass-phrase "Non-echoed text" send-invisible))) + +(define (send-invisible string) + (process-send-string (current-process) string) + (process-send-string (current-process) "\n")) + +(define-command comint-send-char + "Send single character to process." + "p" + (lambda (prefix) + (let ((string (string (read-quoted-char "Send Character: ")))) + (do ((i 0 (+ i 1))) + ((= i prefix)) + (process-send-string (current-process) string))))) + +(define-command comint-previous-similar-input + "Reenter the last input that matches the string typed so far. +If repeated successively, older inputs are reentered. +With negative arg, newer inputs are reentered." + "p" + (lambda (argument) + (let ((tag '(COMINT-PREVIOUS-SIMILAR-INPUT)) + (mark (comint-process-mark)) + (point (current-point)) + (ring (ref-variable comint-input-ring))) + (if (mark< point mark) + (editor-error "Not after process mark")) + (let ((do-it + (lambda (index* prefix) + (let ((size (ring-size ring))) + (let loop ((index index*)) + (let ((index (+ index (if (negative? argument) -1 1)))) + (if (or (negative? index) + (>= index size)) + (begin + (editor-failure "Not found") + (if (not (= index* -1)) + (set-command-message! tag index* prefix))) + (let ((string (ring-ref ring index))) + (if (string-prefix? prefix string) + (begin + (delete-string mark point) + (insert-string string point) + (set-command-message! tag index prefix)) + (loop index)))))))))) + (command-message-receive tag + do-it + (lambda () (do-it -1 (extract-string mark point)))))))) + +(define-command comint-kill-input + "Kill all text from last stuff output by interpreter to point." + () + (lambda () + (let ((mark (comint-process-mark)) + (point (current-point))) + (if (mark>= point mark) + (kill-string mark point) + (editor-error "Nothing to kill"))))) + +(define-command comint-flush-output + "Kill all output from interpreter since last input." + () + (lambda () + (let ((start + (mark-left-inserting-copy + (let ((start (ref-variable comint-last-input-end))) + (if (eqv? #\newline (extract-right-char start)) + (mark1+ start) + start)))) + (end (line-start (comint-process-mark) 0))) + (if (< (mark-index start) (mark-index end)) + (begin + (delete-string start end) + (guarantee-newline start) + (insert-string "*** output flushed ***\n" start))) + (mark-temporary! start)))) + +(define (comint-process-mark) + (let ((buffer (selected-buffer))) + ((or (buffer-get buffer 'COMINT-PROCESS-MARK #f) + (lambda (buffer) + (let ((process (get-buffer-process buffer))) + (if (not process) + (editor-error "Buffer has no process:" buffer)) + (process-mark process)))) + buffer))) + +(define-command comint-show-output + "Start display of the current window at line preceding start of last output. +\"Last output\" is considered to start at the line following the last command +entered to the process." + () + (lambda () + (let ((mark (line-start (ref-variable comint-last-input-end) 0))) + (set-current-point! (comint-line-start mark)) + (set-window-start-mark! (current-window) mark true)))) + +(define-command comint-bol + "Goes to the beginning of line, then skips past the prompt, if any. +With argument, don't skip the prompt -- go straight to column 0. + +The prompt skip is done by skipping text matching the regular expression +comint-prompt-regexp." + "P" + (lambda (argument) + (set-current-point! + (if argument + (line-start (current-point) 0) + (comint-line-start (current-point)))))) + +(define (comint-line-start mark) + (let ((start (line-start mark 0))) + (let ((mark + (re-match-forward (ref-variable comint-prompt-regexp mark) + start + (line-end mark 0)))) + (if (and mark (mark<= mark (line-end start 0))) + mark + start)))) + +(define-command comint-delchar-or-maybe-eof + "If at end of buffer, send EOF to the current subprocess. +If not at end of buffer, just like \\[delete-char]." + "P" + (lambda (argument) + (if (group-end? (current-point)) + (process-send-eof (current-process)) + ((ref-command delete-char) argument)))) + +(define-command comint-interrupt-subjob + "Sent an interrupt signal to the current subprocess. +If the process-connection-type is via ptys, the signal is sent to the current +process group of the pseudoterminal which Edwin is using to communicate with +the subprocess. If the process is a job-control shell, this means the +shell's current subjob. If the process connection is via pipes, the signal is +sent to the immediate subprocess." + () + (lambda () (interrupt-process (current-process) true))) + +(define-command comint-kill-subjob + "Send a kill signal to the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\"." + () + (lambda () (kill-process (current-process) true))) + +(define-command comint-quit-subjob + "Send a quit signal to the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\"." + () + (lambda () (quit-process (current-process) true))) + +(define-command comint-stop-subjob + "Stop the current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\". + +WARNING: if there is no current subjob, you can end up suspending +the top-level process running in the buffer. If you accidentally do +this, use \\[comint-continue-subjob] to resume the process. (This is not a +problem with most shells, since they ignore this signal.)" + () + (lambda () (stop-process (current-process) true))) + +(define-command comint-continue-subjob + "Send a continue signal to current subprocess. +See comint-interrupt-subjob for a description of \"current subprocess\". +Useful if you accidentally suspend the top-level process." + () + (lambda () (continue-process (current-process) true))) + +;;;; Filename Completion + +(define-command comint-replace-by-expanded-filename + "Replace the filename at point with its expanded, canonicalised completion. +\"Expanded\" means environment variables (e.g., $HOME) and ~'s are +replaced with the corresponding directories. \"Canonicalised\" means .. +and . are removed, and the filename is made absolute instead of relative. +See also \\[comint-dynamic-complete]." + () + (lambda () + (let ((region (comint-current-filename-region))) + (let ((filename (region->string region))) + (set-current-point! (region-end region)) + (comint-filename-complete + (merge-pathnames filename (buffer-default-directory (current-buffer))) + filename + (lambda (filename*) + (region-delete! region) + (insert-string filename* (region-start region)))))))) + +(define (comint-dynamic-complete-filename) + "Complete the filename at point. +This function is similar to \\[comint-replace-by-expanded-filename], except +that it won't change parts of the filename already entered in the buffer; +it just adds completion characters to the end of the filename." + (let ((region (comint-current-filename-region))) + (let ((pathname + (merge-pathnames (region->string region) + (buffer-default-directory (current-buffer))))) + (let ((filename (->namestring pathname))) + (set-current-point! (region-end region)) + (comint-filename-complete + pathname + filename + (lambda (filename*) + (insert-substring filename* + (string-length filename) + (string-length filename*) + (region-end region))))))) + #t) + +(define-command comint-dynamic-list-completions + "List all possible completions of the filename at point." + () + (lambda () + (pop-up-generated-completions + (lambda () + (filename-completions-list + (merge-pathnames (region->string (comint-current-filename-region)) + (buffer-default-directory (current-buffer)))))))) + +(define (comint-current-filename-region) + (let ((point (current-point))) + (os/comint-filename-region (let ((line-start (comint-line-start point))) + (if (mark< point line-start) + point + line-start)) + point + (line-end point 0)))) + +(define (comint-filename-complete pathname filename insert-completion) + (standard-completion filename + (lambda (filename if-unique if-not-unique if-not-found) + filename + (filename-complete-string pathname if-unique if-not-unique if-not-found)) + insert-completion)) + +(define-variable comint-dynamic-complete-functions + "List of functions called to perform completion. +Functions should return true if completion was performed. +See also `comint-dynamic-complete'. + +This is a good thing to set in mode hooks." + (list comint-dynamic-complete-filename) + (lambda (object) + (and (list? object) + (every (lambda (object) + (and (procedure? object) + (procedure-arity-valid? object 0))) + object)))) + +(define-command comint-dynamic-complete + "Dynamically perform completion at point. +Calls the functions in `comint-dynamic-complete-functions' to perform +completion until a function returns true, at which point completion is +assumed to have occurred." + () + (lambda () + (let loop ((thunks (ref-variable comint-dynamic-complete-functions))) + (if (not (null? thunks)) + (if (not ((car thunks))) + (loop (cdr thunks))))))) \ No newline at end of file diff --git a/edwin/comman.scm b/edwin/comman.scm new file mode 100644 index 0000000..97ea436 --- /dev/null +++ b/edwin/comman.scm @@ -0,0 +1,206 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Commands and Variables + +(declare (usual-integrations)) + +(define-structure (command + (constructor %make-command ()) + (print-procedure + (standard-print-method 'COMMAND + (lambda (command) + (list (command-name command)))))) + name + %description + interactive-specification + procedure) + +(define (command-description command) + (let ((desc (command-%description command))) + (if (description? desc) + desc + (let ((new (->doc-string (symbol->string (command-name command)) desc))) + (if new + (set-command-%description! command new)) + new)))) + +(define (command-name-string command) + (editor-name/internal->external (symbol->string (command-name command)))) + +(define (editor-name/internal->external string) + string) + +(define (editor-name/external->internal string) + string) + +(define (make-command name description specification procedure) + (let* ((sname (symbol->string name)) + (command + (or (string-table-get editor-commands sname) + (let ((command (%make-command))) + (string-table-put! editor-commands sname command) + command)))) + (set-command-name! command name) + (set-command-%description! command (doc-string->posn sname description)) + (set-command-interactive-specification! command specification) + (set-command-procedure! command procedure) + command)) + +(define editor-commands + (make-string-table 500)) + +(define (name->command name #!optional if-undefined) + (or (string-table-get editor-commands (symbol->string name)) + (case (if (default-object? if-undefined) 'INTERN if-undefined) + ((#F) #f) + ((ERROR) (error "Undefined command:" name)) + ((INTERN) + (letrec ((command + (make-command + name + "undefined command" + '() + (lambda () (editor-error "Undefined command: " name))))) + command)) + (else + (error:bad-range-argument if-undefined 'NAME->COMMAND))))) + +(define (->command object) + (if (command? object) + object + (name->command object))) + +(define (copy-command new-name command) + (make-command new-name + (command-%description command) + (command-interactive-specification command) + (command-procedure command))) + +(define-structure (variable + (constructor %make-variable ()) + (print-procedure + (standard-print-method 'VARIABLE + (lambda (variable) + (list (variable-name variable)))))) + name + %description + %value + buffer-local? + initial-value + %default-value + assignment-daemons + value-validity-test + value-normalization) + +(define (variable-description variable) + (let ((desc (variable-%description variable))) + (if (description? desc) + desc + (let ((new + (->doc-string (symbol->string (variable-name variable)) desc))) + (if new + (set-variable-%description! variable new)) + new)))) + +(define-integrable variable-value variable-%value) +(define-integrable variable-default-value variable-%default-value) + +(define (variable-name-string variable) + (editor-name/internal->external (symbol->string (variable-name variable)))) + +(define (make-variable name description value buffer-local? + #!optional test normalization) + (let* ((sname (symbol->string name)) + (variable + (or (string-table-get editor-variables sname) + (let ((variable (%make-variable))) + (string-table-put! editor-variables sname variable) + variable)))) + (set-variable-name! variable name) + (set-variable-%description! variable (doc-string->posn sname description)) + (set-variable-%value! variable value) + (set-variable-buffer-local?! variable buffer-local?) + (set-variable-initial-value! variable value) + (set-variable-%default-value! variable value) + (set-variable-assignment-daemons! variable '()) + (set-variable-value-validity-test! variable + (if (default-object? test) + #f + test)) + (set-variable-value-normalization! variable + (if (default-object? normalization) + #f + normalization)) + variable)) + +(define (make-variable-buffer-local! variable) + (set-variable-buffer-local?! variable #t)) + +(define (normalize-variable-value variable value) + (if (and (variable-value-validity-test variable) + (not ((variable-value-validity-test variable) value))) + (editor-error "Invalid value for " (variable-name-string variable) + ": " value)) + (if (variable-value-normalization variable) + ((variable-value-normalization variable) value) + value)) + +(define (add-variable-assignment-daemon! variable daemon) + (let ((daemons (variable-assignment-daemons variable))) + (if (not (memq daemon daemons)) + (set-variable-assignment-daemons! variable (cons daemon daemons))))) + +(define (invoke-variable-assignment-daemons! buffer variable) + (if within-editor? + (do ((daemons (variable-assignment-daemons variable) (cdr daemons))) + ((null? daemons)) + ((car daemons) buffer variable)))) + +(define editor-variables + (make-string-table 50)) + +(define (name->variable name #!optional if-undefined) + (or (string-table-get editor-variables (symbol->string name)) + (case (if (default-object? if-undefined) 'INTERN if-undefined) + ((#F) #f) + ((ERROR) (error "Undefined variable:" name)) + ((INTERN) (make-variable name "" #f #f)) + (else (error:bad-range-argument if-undefined 'NAME->VARIABLE))))) + +(define (->variable object) + (if (variable? object) + object + (name->variable object))) + +(define (variable-permanent-local! variable) + (hash-table-set! permanent-local-variables variable #t)) + +(define (variable-permanent-local? variable) + (hash-table-ref/default permanent-local-variables variable #f)) + +(define permanent-local-variables + (make-key-weak-eq-hash-table)) \ No newline at end of file diff --git a/edwin/compile.scm b/edwin/compile.scm new file mode 100644 index 0000000..58272d5 --- /dev/null +++ b/edwin/compile.scm @@ -0,0 +1,139 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Compilation Subprocess + +(declare (usual-integrations)) + +(define-variable compile-command + "Initial contents of \\[compile] prompt." + "make -k" + string?) + +(define-command compile + "Compile the program including the current buffer. Default: run `make'. +Runs COMMAND, a shell command, in a separate process asynchronously +with output going to the buffer *compilation*." + (lambda () + (if (null? (prompt-history-strings 'COMPILE)) + (set-prompt-history-strings! 'COMPILE + (list (ref-variable compile-command)))) + (list (prompt-for-string "Compile command" #f + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'COMPILE + 'HISTORY-INDEX 0))) + (lambda (command) + (run-compilation command))) + +(define-command grep + "Run grep, with user-specified args, and collect output in a buffer." + (lambda () + (list (prompt-for-string "Run grep (with args): " #f + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'GREP + 'HISTORY-INDEX 0))) + (lambda (command) + (run-compilation (string-append "grep -n " command " /dev/null")))) + +(define-command fgrep + "Run fgrep, with user-specified args, and collect output in a buffer." + (lambda () + (list (prompt-for-string "Run fgrep (with args): " #f + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'FGREP + 'HISTORY-INDEX 0))) + (lambda (command) + (run-compilation (string-append "fgrep -n " command " /dev/null")))) + +(define-command kill-compilation + "Kill the process made by the \\[compile] command." + () + (lambda () + (let ((process compilation-process)) + (if (and process (eq? (process-status process) 'RUN)) + (interrupt-process process #t))))) + +(define (run-compilation command) + ((ref-command save-some-buffers) #f) + (let ((process compilation-process)) + (if process + (begin + (if (eq? (process-status process) 'RUN) + (begin + (if (not (prompt-for-yes-or-no? + "A compilation process is running; kill it")) + (editor-error "Cannot have two compilation processes")) + (interrupt-process process #t) + (sit-for 1000))) + (delete-process process)))) + (let ((buffer (temporary-buffer "*compilation*")) + (directory (buffer-default-directory (current-buffer)))) + (disable-group-undo! (buffer-group buffer)) + (set-buffer-default-directory! buffer directory) + (set-buffer-major-mode! buffer (ref-mode-object fundamental)) + (local-set-variable! mode-line-process '(": %s") buffer) + (let ((mark (mark-left-inserting-copy (buffer-start buffer)))) + (let ((window (get-buffer-window buffer))) + (if window + (set-window-start-mark! window mark #t))) + (insert-string "cd " mark) + (insert-string (->namestring directory) mark) + (insert-newline mark) + (insert-string command mark) + (insert-newline mark) + (mark-temporary! mark)) + (let ((process + (apply start-process + "compilation" + buffer + scheme-subprocess-environment + (ref-variable shell-file-name) + (os/form-shell-command command)))) + (set-process-sentinel! process compilation-process-sentinel) + (set! compilation-process process)) + (pop-up-buffer buffer #f))) + +(define (compilation-process-sentinel process status reason) + (let ((buffer (process-buffer process))) + (if buffer + (if (memq (process-status process) '(EXIT SIGNAL)) + (let ((mark (mark-left-inserting-copy (buffer-end buffer)))) + (insert-newline mark) + (insert-string "Process " mark) + (insert-string (process-name process) mark) + (insert-string " " mark) + (insert-string (process-status-message status reason) mark) + (insert-newline mark) + (mark-temporary! mark))))) + (without-interrupts + (lambda () + (if (eq? process compilation-process) + (begin + (set! compilation-process #f) + unspecific))))) + +(define compilation-process + #f) \ No newline at end of file diff --git a/edwin/comred.scm b/edwin/comred.scm new file mode 100644 index 0000000..496fceb --- /dev/null +++ b/edwin/comred.scm @@ -0,0 +1,522 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Command Reader + +(declare (usual-integrations)) + +(define *command-key*) ;Key read to find current command +(define *command*) ;The current command +(define *last-command*) ;The previous command, excluding arg commands +(define *command-argument*) ;Argument from last command +(define *next-argument*) ;Argument to next command +(define *command-message*) ;Message from last command +(define *next-message*) ;Message to next command +(define *non-undo-count*) ;# of self-inserts since last undo boundary +(define keyboard-keys-read) ;# of keys read from keyboard +(define command-history) +(define command-history-limit 30) +(define command-reader-override-queue) +(define *command-suffixes*) + +(add-event-receiver! editor-initializations + (lambda () + (set! keyboard-keys-read 0) + (set! command-history (make-circular-list command-history-limit #f)) + (set! command-reader-override-queue (make-queue)) + (set! *command-suffixes* #f) + unspecific)) + +(define (top-level-command-reader init) + (with-keyboard-macro-disabled + (lambda () + (bind-condition-handler (list condition-type:abort-current-command) + return-to-command-loop + (lambda () + (command-reader init)))))) + +(define (command-reader #!optional initialization) + (fluid-let ((*last-command* #f) + (*command* #f) + (*command-argument*) + (*next-argument* #f) + (*command-message*) + (*next-message* #f) + (*non-undo-count* 0) + (*command-key* #f)) + (bind-condition-handler (list condition-type:editor-error) + editor-error-handler + (lambda () + (bind-condition-handler (list condition-type:abort-current-command) + (lambda (condition) + (if (not (condition/^G? condition)) + (return-to-command-loop condition))) + (lambda () + (if (and (not (default-object? initialization)) initialization) + (bind-abort-editor-command + (lambda () + (reset-command-state!) + (initialization)))) + (do () (#f) + (bind-abort-editor-command + (lambda () + (do () (#f) + (reset-command-state!) + (if (queue-empty? command-reader-override-queue) + (let ((input (get-next-keyboard-char))) + (if (input-event? input) + (begin + (apply-input-event input) + (if (not (eq? 'BUTTON (input-event/type input))) + (preserve-command-state!))) + (begin + (set! *command-key* input) + (clear-message) + (set-command-prompt! + (if (not (command-argument)) + (key-name input) + (string-append-separated + (command-argument-prompt) + (key-name input)))) + (let ((window (current-window))) + (%dispatch-on-command + window + (local-comtab-entry (buffer-comtabs + (window-buffer window)) + input + (window-point window)) + #f))))) + ((dequeue! command-reader-override-queue))))))))))))) + +(define (bind-abort-editor-command thunk) + (call-with-current-continuation + (lambda (k) + (with-restart 'ABORT-EDITOR-COMMAND "Return to the editor command loop." + (lambda (#!optional input) + (keyboard-macro-disable) + (if (and (not (default-object? input)) (input-event? input)) + (within-continuation k + (lambda () + (reset-command-state!) + (apply-input-event input))) + (begin + (abort-keyboard-macro) + (k unspecific)))) + values + thunk)))) + +(define (return-to-command-loop condition) + (let ((restart (find-restart 'ABORT-EDITOR-COMMAND))) + (if (not restart) (error "Missing ABORT-EDITOR-COMMAND restart.")) + (invoke-restart restart + (and (condition/abort-current-command? condition) + (abort-current-command/input condition))))) + +(define (get-next-keyboard-char) + (if *executing-keyboard-macro?* + (begin + (set! keyboard-keys-read (+ keyboard-keys-read 1)) + (keyboard-macro-read-key)) + (with-editor-interrupts-disabled keyboard-read))) + +(define (reset-command-state!) + (unblock-thread-events) + (set! *last-command* *command*) + (set! *command* #f) + (set! *command-argument* *next-argument*) + (set! *next-argument* #f) + (set! *command-message* *next-message*) + (set! *next-message* #f) + (if (command-argument) + (set-command-prompt! (command-argument-prompt)) + (reset-command-prompt!)) + (if *defining-keyboard-macro?* + (keyboard-macro-finalize-keys))) + +(define (preserve-command-state!) + (set! *next-argument* *command-argument*) + (set! *next-message* *command-message*) + (set! *command* *last-command*) + unspecific) + +(define (override-next-command! override) + (enqueue! command-reader-override-queue override)) + +(define-integrable (current-command-key) + *command-key*) + +(define (last-command-key) + (if (key? *command-key*) + *command-key* + (car (last-pair *command-key*)))) + +(define (set-current-command! command) + (set! *command* command) + unspecific) + +(define-integrable (current-command) + *command*) + +(define-integrable (last-command) + *last-command*) + +(define (set-command-argument! argument mode) + (set! *next-argument* (cons argument mode)) + ;; Preserve message and last command. + (set! *next-message* *command-message*) + (set! *command* *last-command*) + unspecific) + +(define-integrable (command-argument) + (and *command-argument* (car *command-argument*))) + +(define (auto-argument-mode?) + (and *command-argument* (cdr *command-argument*))) + +(define (set-command-message! tag . arguments) + (set! *next-message* (cons tag arguments)) + unspecific) + +(define (command-message-receive tag if-received if-not-received) + (if (and *command-message* + (eq? (car *command-message*) tag)) + (apply if-received (cdr *command-message*)) + (if-not-received))) + +(define (command-history-list) + (let loop ((history command-history)) + (if (car history) + (let loop ((history (cdr history)) (result (list (car history)))) + (if (eq? history command-history) + result + (loop (cdr history) (cons (car history) result)))) + (let ((history (cdr history))) + (if (eq? history command-history) + '() + (loop history)))))) + +(define (add-command-suffix! procedure . arguments) + (if *command-suffixes* + (without-interrupts + (lambda () + (%add-command-suffix! procedure arguments))) + (apply procedure arguments))) + +(define (maybe-add-command-suffix! procedure . arguments) + (if *command-suffixes* + (without-interrupts + (lambda () + (let loop ((items (car *command-suffixes*))) + (cond ((not (pair? items)) + (%add-command-suffix! procedure arguments)) + ((not (and (eq? procedure (caar items)) + (equal? arguments (cdar items)))) + (loop (cdr items))))))) + (apply procedure arguments))) + +(define (%add-command-suffix! procedure arguments) + (let ((next (cons (cons procedure arguments) '()))) + (if (pair? (cdr *command-suffixes*)) + (set-cdr! (cdr *command-suffixes*) next) + (set-car! *command-suffixes* next)) + (set-cdr! *command-suffixes* next))) + +(define (run-command-suffixes) + (let loop () + (let ((item + (without-interrupts + (lambda () + (let ((next (car *command-suffixes*))) + (and (pair? next) + (begin + (if (pair? (cdr next)) + (set-car! *command-suffixes* (cdr next)) + (begin + (set-car! *command-suffixes* '()) + (set-cdr! *command-suffixes* '()))) + (car next)))))))) + (if item + (begin + (apply (car item) (cdr item)) + (loop)))))) + +;;; The procedures for executing commands come in two flavors. The +;;; difference is that the EXECUTE-foo procedures reset the command +;;; state first, while the DISPATCH-ON-foo procedures do not. The +;;; latter should only be used by "prefix" commands such as C-X or +;;; C-4, since they want arguments, messages, etc. to be passed on. + +(define-integrable (execute-key comtab key) + (reset-command-state!) + (dispatch-on-key comtab key)) + +(define-integrable (execute-command command) + (reset-command-state!) + (%dispatch-on-command (current-window) command #f)) + +(define (execute-button-command screen button x y) + (clear-message) + (reset-command-state!) + (send (screen-root-window screen) ':button-event! button x y)) + +(define (read-and-dispatch-on-key) + (dispatch-on-key (current-comtabs) + (with-editor-interrupts-disabled keyboard-read))) + +(define (dispatch-on-key comtab key) + (if (input-event? key) + (apply-input-event key) + (begin + (set! *command-key* key) + (set-command-prompt! + (string-append-separated (command-argument-prompt) (xkey->name key))) + (%dispatch-on-command (current-window) + (comtab-entry comtab key) + #f)))) + +(define (dispatch-on-command command #!optional record?) + (%dispatch-on-command (current-window) + command + (if (default-object? record?) #f record?))) + +(define (%dispatch-on-command window command record?) + (set! *command* command) + (guarantee-command-loaded command) + (define (char-image-string ch) + (window-char->image window ch)) + (let ((point (window-point window)) + (point-x (window-point-x window)) + (procedure (command-procedure command))) + (let ((normal + (lambda () + (set! *non-undo-count* 0) + (if (not *command-argument*) + (undo-boundary! point)) + (fluid-let ((*command-suffixes* (cons '() '()))) + (let ((v + (apply procedure + (interactive-arguments command record?)))) + (run-command-suffixes) + v))))) + (cond ((or *executing-keyboard-macro?* *command-argument*) + (normal)) + ((and (char? *command-key*) + (or (eq? command (ref-command-object self-insert-command)) + (command-argument-self-insert? command))) + (let ((non-undo-count *non-undo-count*)) + (if (or (fix:= non-undo-count 0) + (fix:>= non-undo-count 20)) + (begin + (set! *non-undo-count* 1) + (undo-boundary! point)) + (set! *non-undo-count* (fix:+ non-undo-count 1)))) + (let ((key *command-key*)) + (if (and (not (window-needs-redisplay? window)) + (let ((buffer (window-buffer window))) + (and (buffer-auto-save-modified? buffer) + (null? (cdr (buffer-windows buffer))))) + (line-end? point) + (not (char=? key #\newline)) + (not (char=? key #\tab)) + (let ((image (char-image-string key))) + (and (fix:= (string-length image) 1) + (char=? (string-ref image 0) key))) + (fix:< point-x (fix:- (window-x-size window) 1))) + (if (self-insert key 1 #t) + (begin + (set! *non-undo-count* 0) + (undo-boundary! point)) + (window-direct-output-insert-char! window key)) + (normal)))) + ((eq? command (ref-command-object forward-char)) + (if (and (not (window-needs-redisplay? window)) + (not (group-end? point)) + (let ((char (mark-right-char point))) + (and (not (char=? char #\newline)) + (not (char=? char #\tab)) + (fix:= (string-length (char-image-string char)) + 1))) + (fix:< point-x (fix:- (window-x-size window) 2))) + (window-direct-output-forward-char! window) + (normal))) + ((eq? command (ref-command-object backward-char)) + (if (and (not (window-needs-redisplay? window)) + (not (group-start? point)) + (let ((char (mark-left-char point))) + (and (not (char=? char #\newline)) + (not (char=? char #\tab)) + (fix:= (string-length (char-image-string char)) + 1))) + (fix:< 0 point-x) + (fix:< point-x (fix:- (window-x-size window) 1))) + (window-direct-output-backward-char! window) + (normal))) + (else + (normal)))))) + +(define (interactive-arguments command record?) + (let ((specification (command-interactive-specification command)) + (record-command-arguments + (lambda (arguments) + (let ((history command-history)) + (set-car! history (cons (command-name command) arguments)) + (set! command-history (cdr history)))))) + (cond ((string? specification) + (call-with-values + (lambda () + (let ((end (string-length specification))) + (let loop + ((index + (if (and (not (zero? end)) + (char=? #\* (string-ref specification 0))) + (begin + (if (buffer-read-only? (current-buffer)) + (barf-if-read-only)) + 1) + 0))) + (if (< index end) + (let ((newline + (substring-find-next-char specification + index + end + #\newline))) + (call-with-values + (lambda () + (interactive-argument + (string-ref specification index) + (substring specification + (+ index 1) + (or newline end)))) + (lambda (argument expression from-tty?) + (call-with-values + (lambda () + (if newline + (loop (+ newline 1)) + (values '() '() #f))) + (lambda (arguments expressions any-from-tty?) + (values (cons argument arguments) + (cons expression expressions) + (or from-tty? any-from-tty?))))))) + (values '() '() #f))))) + (lambda (arguments expressions any-from-tty?) + (if (or record? + (and any-from-tty? + (not (prefix-key-list? (current-comtabs) + (current-command-key))))) + (record-command-arguments expressions)) + arguments))) + ((null? specification) + (if record? (record-command-arguments '())) + '()) + (else + (let ((old-keys-read keyboard-keys-read)) + (let ((arguments (specification))) + (if (or record? (not (= keyboard-keys-read old-keys-read))) + (record-command-arguments (map quotify-sexp arguments))) + arguments)))))) + +(define (execute-command-history-entry entry) + (let ((history command-history)) + (if (not (equal? entry + (let loop ((entries (cdr history)) (tail history)) + (if (eq? entries history) + (car tail) + (loop (cdr entries) entries))))) + (begin + (set-car! history entry) + (set! command-history (cdr history))))) + (apply (command-procedure (name->command (car entry))) + (map (let ((environment (->environment '(EDWIN)))) + (lambda (expression) + (eval-with-history expression environment))) + (cdr entry)))) + +(define (interactive-argument key prompt) + (let ((prompting + (lambda (value) + (values value (quotify-sexp value) #t))) + (prefix + (lambda (prefix) + (values prefix (quotify-sexp prefix) #f))) + (varies + (lambda (value expression) + (values value expression #f)))) + (case key + ((#\b) + (prompting + (buffer-name (prompt-for-existing-buffer prompt (current-buffer))))) + ((#\B) + (prompting (buffer-name (prompt-for-buffer prompt (current-buffer))))) + ((#\c) + (prompting (prompt-for-char prompt))) + ((#\C) + (prompting (command-name (prompt-for-command prompt)))) + ((#\d) + (varies (current-point) '(CURRENT-POINT))) + ((#\D) + (prompting (prompt-for-directory prompt #f))) + ((#\f) + (prompting (prompt-for-existing-file prompt #f))) + ((#\F) + (prompting (prompt-for-file prompt #f))) + ((#\k) + (prompting (prompt-for-key prompt (current-comtabs)))) + ((#\m) + (varies (current-mark) '(CURRENT-MARK))) + ((#\n) + (prompting (prompt-for-number prompt #f))) + ((#\N) + (prefix + (or (command-argument-value (command-argument)) + (prompt-for-number prompt #f)))) + ((#\p) + (prefix (command-argument-numeric-value (command-argument)))) + ((#\P) + (prefix (command-argument))) + ((#\r) + (varies (current-region) '(CURRENT-REGION))) + ((#\s) + (prompting + (or (prompt-for-string prompt #f 'DEFAULT-TYPE 'NULL-DEFAULT) + ""))) + ((#\v) + (prompting (variable-name (prompt-for-variable prompt)))) + ((#\x) + (prompting (prompt-for-expression prompt))) + ((#\X) + (prompting (prompt-for-expression-value prompt))) + (else + (editor-error "Invalid control letter " + key + " in interactive calling string"))))) + +(define (quotify-sexp sexp) + (if (or (boolean? sexp) + (number? sexp) + (string? sexp) + (char? sexp)) + sexp + `(QUOTE ,sexp))) \ No newline at end of file diff --git a/edwin/comtab.scm b/edwin/comtab.scm new file mode 100644 index 0000000..edcaf8f --- /dev/null +++ b/edwin/comtab.scm @@ -0,0 +1,421 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Command Tables + +(declare (usual-integrations)) + +(define-structure (comtab (constructor make-comtab ())) + (vector 0) + (alist '())) + +(define (comtab-get comtab key) + (let ((vector (comtab-vector comtab))) + (let ((try + (lambda (key) + (if (and (vector? vector) + (char? key) + (< (char->integer key) (vector-length vector))) + (vector-ref vector (char->integer key)) + (let ((entry (assq key (comtab-alist comtab)))) + (and entry + (cdr entry))))))) + (if (and (char? key) (char-upper-case? (char-base key))) + (or (try key) (try (char-downcase key))) + (try key))))) + +(define (comtab-put! comtab key datum) + (cond ((not datum) + (comtab-remove! comtab key)) + ((and (char? key) (< (char->integer key) 256)) + (let ((vector (comtab-vector comtab))) + (if (vector? vector) + (vector-set! vector (char->integer key) datum) + (let ((alist (comtab-alist comtab))) + (let ((entry (assq key alist))) + (if entry + (set-cdr! entry datum) + (let ((vector (+ vector 1)) + (alist (cons (cons key datum) alist))) + (if (< vector 64) + (without-interrupts + (lambda () + (set-comtab-vector! comtab vector) + (set-comtab-alist! comtab alist))) + (let* ((vector (make-vector 256 false)) + (alist + (remove (lambda (entry) + (let ((key (car entry))) + (and (char? key) + (< (char->integer key) + 256) + (begin + (vector-set! + vector + (char->integer key) + (cdr entry)) + true)))) + alist))) + (without-interrupts + (lambda () + (set-comtab-vector! comtab vector) + (set-comtab-alist! comtab alist)))))))))))) + (else + (let ((alist (comtab-alist comtab))) + (let ((entry (assq key alist))) + (if entry + (set-cdr! entry datum) + (set-comtab-alist! comtab + (cons (cons key datum) alist)))))))) + +(define (comtab-remove! comtab key) + (if (and (char? key) (< (char->integer key) 256)) + (let ((vector (comtab-vector comtab))) + (if (vector? vector) + (vector-set! vector (char->integer key) false) + (let ((alist (comtab-alist comtab))) + (let ((entry (assq key alist))) + (if entry + (let ((vector (- vector 1)) + (alist (delq entry alist))) + (without-interrupts + (lambda () + (set-comtab-vector! comtab vector) + (set-comtab-alist! comtab alist))))))))) + (set-comtab-alist! comtab (del-assq key (comtab-alist comtab))))) + +(define (valid-comtabs? object) + (or (mode? object) + (symbol? object) + (comtab? object) + (list-of-comtabs? object))) + +(define (guarantee-comtabs object procedure) + (cond ((mode? object) + (mode-comtabs object)) + ((symbol? object) + (mode-comtabs (->mode object))) + ((comtab? object) + (list object)) + ((list-of-comtabs? object) + object) + (else + (error:wrong-type-argument object "list of comtabs" procedure)))) + +(define (mode-name? object) + (and (symbol? object) + (string-table-get editor-modes (symbol->string object)))) + +(define (list-of-comtabs? object) + (and (not (null? object)) + (list? object) + (every comtab? object))) + +(define (comtab-key? object) + (or (key? object) + (prefixed-key? object) + (button? object))) + +(define (prefixed-key? object) + (let loop ((object object)) + (and (pair? object) + (key? (car object)) + (or (null? (cdr object)) + (loop (cdr object)))))) + +(define (valid-datum? object) + (or (not object) + (command? object) + (comtab? object) + (command&comtab? object) + (comtab-alias? object))) + +(define (command&comtab? object) + (and (pair? object) + (command? (car object)) + (comtab? (cdr object)))) + +(define (comtab-alias? object) + (and (pair? object) + (valid-comtabs? (car object)) + (comtab-key? (cdr object)))) + +(define (comtab-alias/dereference datum) + (lookup-key (car datum) (cdr datum))) + +(define (lookup-key comtabs key) + (let ((comtabs (guarantee-comtabs comtabs 'LOOKUP-KEY))) + (let ((simple-lookup + (lambda (key) + (let loop ((comtabs* comtabs)) + (cond ((comtab-get (car comtabs*) key) + => handle-datum) + ((not (null? (cdr comtabs*))) + (loop (cdr comtabs*))) + (else + false)))))) + (cond ((key? key) + (simple-lookup (remap-alias-key key))) + ((button? key) + (simple-lookup key)) + ((prefixed-key? key) + (let ((prefix (except-last-pair key)) + (key (remap-alias-key (car (last-pair key))))) + (if (null? prefix) + (simple-lookup key) + (let loop ((comtabs* comtabs)) + (let ((comtab + (lookup-prefix (car comtabs*) prefix false))) + (cond ((and comtab (comtab-get comtab key)) + => handle-datum) + ((not (null? (cdr comtabs*))) + (loop (cdr comtabs*))) + (else + false))))))) + (else + (error:wrong-type-argument key "comtab key" 'LOOKUP-KEY)))))) + +(define (handle-datum datum) + (cond ((or (command? datum) + (comtab? datum) + (command&comtab? datum)) + datum) + ((comtab-alias? datum) + (comtab-alias/dereference datum)) + (else + (error "Illegal comtab datum:" datum)))) + +(define (lookup-prefix comtab prefix intern?) + (let loop ((comtab comtab) (prefix* prefix)) + (if (null? prefix*) + comtab + (let ((key (remap-alias-key (car prefix*))) + (prefix* (cdr prefix*))) + (let datum-loop ((datum (comtab-get comtab key))) + (cond ((not datum) + (and intern? + (let ((datum (make-comtab))) + ;; Note that this will clobber a comtab-alias + ;; that points to an undefined entry. + (comtab-put! comtab key datum) + (loop datum prefix*)))) + ((comtab? datum) + (loop datum prefix*)) + ((command&comtab? datum) + (loop (cdr datum) prefix*)) + ((comtab-alias? datum) + (datum-loop (comtab-alias/dereference datum))) + ((command? datum) + (error "Key sequence too long:" + prefix + (- (length prefix) (length prefix*)))) + (else + (error "Illegal comtab datum:" datum)))))))) + +(define (comtab-entry comtabs key) + (or (%comtab-entry comtabs key) + (and (not (button? key)) + (ref-command-object undefined)))) + +(define (local-comtab-entry comtabs key mark) + (or (and mark + (let ((local-comtabs (local-comtabs mark))) + (and local-comtabs + (%comtab-entry local-comtabs key)))) + (comtab-entry comtabs key))) + +(define (%comtab-entry comtabs key) + (let ((object (lookup-key comtabs key))) + (cond ((not object) + #f) + ((command? object) + object) + ((command&comtab? object) + (car object)) + ((comtab? object) + (ref-command-object prefix-key)) + (else + (error "Illegal result from lookup-key:" object))))) + +(define (prefix-key-list? comtabs key) + (let ((object (lookup-key comtabs key))) + (or (comtab? object) + (command&comtab? object)))) + +(define (define-key mode key datum) + (%define-key (guarantee-comtabs mode 'DEFINE-KEY) + key + (if (valid-datum? datum) datum (->command datum)) + 'DEFINE-KEY)) + +(define (define-prefix-key mode key #!optional command) + (%define-key (guarantee-comtabs mode 'DEFINE-PREFIX-KEY) + (begin + (if (button? key) + (error:wrong-type-argument key + "comtab prefix key" + 'DEFINE-PREFIX-KEY)) + key) + (let ((comtab (make-comtab))) + (if (default-object? command) + comtab + (let ((command (->command command))) + (if (eq? command (ref-command-object prefix-key)) + comtab + (cons command comtab))))) + 'DEFINE-PREFIX-KEY)) + +(define (%define-key comtabs key datum procedure) + (let* ((comtab (car comtabs)) + (put! + (lambda (key) + (comtab-put! comtab (remap-alias-key key) datum)))) + (cond ((or (key? key) (button? key)) + (put! key)) + ((char-set? key) + (char-set-for-each put! (char-set-intersection key char-set:ascii))) + ((prefixed-key? key) + (let ((prefix (except-last-pair key))) + (comtab-put! (if (null? prefix) + comtab + (lookup-prefix comtab prefix true)) + (remap-alias-key (car (last-pair key))) + datum))) + (else + (error:wrong-type-argument key "comtab key" procedure)))) + key) + +(define (comtab-alist* comtab) + (let ((vector (comtab-vector comtab)) + (alist (comtab-alist comtab))) + (if (vector? vector) + (let ((end (vector-length vector))) + (let loop ((index 0) (alist alist)) + (if (fix:< index end) + (loop (fix:+ index 1) + (let ((datum (vector-ref vector index))) + (if datum + (cons (cons (integer->char index) datum) + alist) + alist))) + alist))) + alist))) + +(define (comtab->alist comtab) + (let loop ((prefix '()) (comtab comtab)) + (append-map! + (lambda (entry) + (if (and (button? (car entry)) + (not (null? prefix))) + '() + (let ((prefix (append prefix (list (car entry))))) + (let ((key (if (null? (cdr prefix)) (car prefix) prefix))) + (let datum-loop ((datum (cdr entry))) + (cond ((not datum) + '()) + ((command? datum) + (list (cons key datum))) + ((comtab? datum) + (loop prefix datum)) + ((command&comtab? datum) + (cons (cons key (car datum)) + (loop prefix (cdr datum)))) + ((comtab-alias? datum) + (datum-loop (comtab-alias/dereference datum))) + (else + (error "Illegal comtab datum:" datum)))))))) + (comtab-alist* comtab)))) + +(define (comtab-key-bindings comtabs command) + (let ((comtabs (guarantee-comtabs comtabs 'COMTAB-KEY-BINDINGS)) + (command (->command command))) + ;; In addition to having a binding of COMMAND, every key in the + ;; result satisfies VALID-KEY?. This eliminates bindings that are + ;; shadowed by other bindings. + (let ((valid-key? + (lambda (key) + (let ((datum (lookup-key comtabs key))) + (cond ((command? datum) + (eq? command datum)) + ((comtab? datum) + (eq? command (ref-command-object prefix-key))) + ((command&comtab? datum) + (eq? command (car datum))) + (else + false)))))) + (sort (let loop ((comtabs comtabs)) + (if (null? comtabs) + '() + (%comtab-bindings (car comtabs) + (loop (cdr comtabs)) + command + valid-key?))) + (let ((v + (lambda (k) + (cond ((char? k) 0) + ((list-of-type? k char?) 1) + ((special-key? k) 2) + ((button? k) 3) + (else 4))))) + (lambda (k1 k2) + (< (v k1) (v k2)))))))) + +(define (%comtab-bindings comtab keys command valid-key?) + (let comtab-loop ((comtab comtab) (keys keys) (prefix '())) + (let alist-loop ((entries (comtab-alist* comtab))) + (if (null? entries) + keys + (let ((key + (if (pair? prefix) + (append prefix (list (caar entries))) + (caar entries)))) + (let datum-loop + ((datum (cdar entries)) + (keys (alist-loop (cdr entries)))) + (cond ((not datum) + keys) + ((command? datum) + (if (and (eq? datum command) + (valid-key? key)) + (cons key keys) + keys)) + ((comtab? datum) + (let ((keys + (comtab-loop datum keys + (if (pair? prefix) + key + (list key))))) + (if (and (eq? command (ref-command-object prefix-key)) + (valid-key? key)) + (cons key keys) + keys))) + ((command&comtab? datum) + (datum-loop (car datum) + (datum-loop (cdr datum) keys))) + ((comtab-alias? datum) + (datum-loop (comtab-alias/dereference datum) keys)) + (else + (error "Illegal comtab datum:" datum))))))))) \ No newline at end of file diff --git a/edwin/comwin.scm b/edwin/comwin.scm new file mode 100644 index 0000000..32c24e9 --- /dev/null +++ b/edwin/comwin.scm @@ -0,0 +1,690 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Combination Windows + +(declare (usual-integrations)) + +;;; Combination windows are used to split a window into vertically or +;;; horizontally divided areas. That window's initial superior must +;;; support the :NEW-ROOT-WINDOW! operation, but is otherwise not +;;; constrained. + +;;; (==> WINDOW :NEW-ROOT-WINDOW! WINDOW*) + +;;; This is called whenever the root is changed. It need not do +;;; anything at all, but it is useful to keep track of the root. + +;;; What happens is that the initial window may be split horizontally +;;; or vertically, as many times as desired. The combination windows +;;; organize those splits into a tree. The leaves of the tree are not +;;; combination windows, but are created from one of the other leaves +;;; by the :MAKE-LEAF operation. Of course, the initial window is a +;;; leaf window too. + +;;; If there is just one leaf window in the tree, then it is the root +;;; window also. Otherwise, the root is a combination window. + +;;; The leaf windows must be subclasses of COMBINATION-LEAF-WINDOW, +;;; and they must support these operations: + +;;; (==> WINDOW :MAKE-LEAF) + +;;; Make a new leaf which can be placed next to WINDOW. For example, +;;; if WINDOW is a buffer window, the new window should also be a +;;; buffer window, visiting the same buffer, and sharing the same +;;; superior. + +;;; (==> WINDOW :MINIMUM-X-SIZE) +;;; (==> WINDOW :MINIMUM-Y-SIZE) + +;;; These define how small the window is allowed to be. Since the +;;; combination window operations change the sizes of leaf windows, +;;; they need some idea of how small the leaves are allowed to get. +;;; So, no window will ever be set to a size that is below its minimum +;;; -- it will be deleted from the heirarchy instead. + +;;; The values of these operations may depend on the window's position +;;; in the heirarchy, i.e. the SUPERIOR, NEXT-WINDOW, and +;;; PREVIOUS-WINDOW. These are carefully arranged in the target +;;; configuration before the operations are invoked. This is intended +;;; to allow the leaves to have different minimums when there are +;;; optional borders which depend on their placement. + +;;; Under no circumstances should the :MINIMUM-SIZE depend on the +;;; current size of a leaf window. + +(define-class combination-leaf-window vanilla-window + (next-window previous-window)) + +(define-integrable (window-next window) + (with-instance-variables combination-leaf-window window () + next-window)) + +(define-integrable (set-window-next! window window*) + (with-instance-variables combination-leaf-window window (window*) + (set! next-window window*))) + +(define-integrable (window-previous window) + (with-instance-variables combination-leaf-window window () + previous-window)) + +(define-integrable (set-window-previous! window window*) + (with-instance-variables combination-leaf-window window (window*) + (set! previous-window window*))) + +(define (link-windows! previous next) + (set-window-previous! next previous) + (set-window-next! previous next)) + +(define-class combination-window combination-leaf-window + (vertical? child)) + +(define-integrable (combination-vertical? window) + (with-instance-variables combination-window window () + vertical?)) + +(define-integrable (set-combination-vertical! window v) + (with-instance-variables combination-window window (v) + (set! vertical? v))) + +(define-integrable (combination-child window) + (with-instance-variables combination-window window () + child)) + +(define (set-combination-child! window window*) + (with-instance-variables combination-window window (window*) + (set! child window*) + (set-window-previous! window* false))) + +(define-integrable (combination? window) + (object-of-class? combination-window window)) + +(define-integrable (leaf? window) + (and (object? window) + (subclass? (object-class window) combination-leaf-window) + (not (eq? (object-class window) combination-window)))) + +(define-integrable (check-leaf-window window name) + (if (not (leaf? window)) + (error:wrong-type-argument window "window" name))) + +;;;; Leaf Ordering + +(define (window+ leaf n) + (check-leaf-window leaf 'WINDOW+) + (cond ((positive? n) (%window+ leaf n)) + ((negative? n) (%window- leaf (- n))) + (else leaf))) + +(define (window- leaf n) + (check-leaf-window leaf 'WINDOW-) + (cond ((positive? n) (%window- leaf n)) + ((negative? n) (%window+ leaf (- n))) + (else leaf))) + +(define (%window+ leaf n) + (if (= n 1) + (%window1+ leaf) + (%window+ (%window1+ leaf) (-1+ n)))) + +(define (%window- leaf n) + (if (= n 1) + (%window-1+ leaf) + (%window- (%window-1+ leaf) (-1+ n)))) + +(define (window1+ leaf) + (check-leaf-window leaf 'WINDOW1+) + (%window1+ leaf)) + +(define (window-1+ leaf) + (check-leaf-window leaf 'WINDOW-1+) + (%window-1+ leaf)) + +(define (window0 window) + (if (not (and (object? window) + (subclass? (object-class window) combination-leaf-window))) + (error:wrong-type-argument window "window" 'WINDOW0)) + (window-leftmost-leaf (window-root window))) + +(define (%window1+ leaf) + (window-leftmost-leaf + (or (window-next leaf) + (if (combination? (window-superior leaf)) + (find-window-with-next (window-superior leaf)) + leaf)))) + +(define (%window-1+ leaf) + (window-rightmost-leaf + (or (window-previous leaf) + (if (combination? (window-superior leaf)) + (find-window-with-previous (window-superior leaf)) + leaf)))) + +(define (find-window-with-next combination) + (or (window-next combination) + (if (combination? (window-superior combination)) + (find-window-with-next (window-superior combination)) + combination))) + +(define (find-window-with-previous combination) + (or (window-previous combination) + (if (combination? (window-superior combination)) + (find-window-with-previous (window-superior combination)) + combination))) + +(define (window-first window) + (if (window-previous window) + (window-first (window-previous window)) + window)) + +(define (window-last window) + (if (window-next window) + (window-last (window-next window)) + window)) + +(define (window-root window) + (if (combination? (window-superior window)) + (window-root (window-superior window)) + window)) + +(define (window-leftmost-leaf window) + (if (combination? window) + (window-leftmost-leaf (combination-child window)) + window)) + +(define (window-rightmost-leaf window) + (if (combination? window) + (window-rightmost-leaf (window-last (combination-child window))) + window)) + +(define (window-has-no-neighbors? leaf) + (check-leaf-window leaf 'WINDOW-HAS-NO-NEIGHBORS?) + (not (combination? (window-superior leaf)))) + +(define (window-has-horizontal-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-HORIZONTAL-NEIGHBOR?) + (%window-has-horizontal-neighbor? leaf)) + +(define (%window-has-horizontal-neighbor? window) + (let ((superior (window-superior window))) + (and (combination? superior) + (or (not (combination-vertical? superior)) + (%window-has-horizontal-neighbor? superior))))) + +(define (window-has-vertical-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-VERTICAL-NEIGHBOR?) + (%window-has-vertical-neighbor? leaf)) + +(define (%window-has-vertical-neighbor? window) + (let ((superior (window-superior window))) + (and (combination? superior) + (or (combination-vertical? superior) + (%window-has-vertical-neighbor? superior))))) + +(define (window-has-right-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-RIGHT-NEIGHBOR?) + (%window-has-right-neighbor? leaf)) + +(define (%window-has-right-neighbor? window) + (and (combination? (window-superior window)) + (or (and (not (combination-vertical? (window-superior window))) + (window-next window)) + (%window-has-right-neighbor? (window-superior window))))) + +(define (window-has-left-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-LEFT-NEIGHBOR?) + (%window-has-left-neighbor? leaf)) + +(define (%window-has-left-neighbor? window) + (and (combination? (window-superior window)) + (or (and (not (combination-vertical? (window-superior window))) + (window-previous window)) + (%window-has-left-neighbor? (window-superior window))))) + +(define (window-has-up-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-UP-NEIGHBOR?) + (%window-has-up-neighbor? leaf)) + +(define (%window-has-up-neighbor? window) + (and (combination? (window-superior window)) + (or (and (combination-vertical? (window-superior window)) + (window-previous window)) + (%window-has-up-neighbor? (window-superior window))))) + +(define (window-has-down-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-DOWN-NEIGHBOR?) + (%window-has-down-neighbor? leaf)) + +(define (%window-has-down-neighbor? window) + (and (combination? (window-superior window)) + (or (and (combination-vertical? (window-superior window)) + (window-next window)) + (%window-has-down-neighbor? (window-superior window))))) + +;;;; Creation + +(define (window-split-horizontally! leaf #!optional n) + (check-leaf-window leaf 'WINDOW-SPLIT-HORIZONTALLY!) + (without-interrupts + (lambda () + (let ((n + (if (or (default-object? n) (not n)) + (quotient (window-x-size leaf) 2) + n)) + (x (window-x-size leaf)) + (y (window-y-size leaf))) + (let ((n* (- x n)) + (new (allocate-leaf! leaf false))) + (let ((combination (window-superior leaf))) + (inferior-start (window-inferior combination leaf) + (lambda (x y) + (set-inferior-start! (window-inferior combination new) + (+ x n) + y)))) + (if (or (< n (==> leaf :minimum-x-size)) + (< n* (==> new :minimum-x-size))) + (begin + (deallocate-leaf! new) + false) + (begin + (==> leaf :set-x-size! n) + (==> new :set-size! n* y) + new))))))) + +(define (window-split-vertically! leaf #!optional n) + (check-leaf-window leaf 'WINDOW-SPLIT-VERTICALLY!) + (without-interrupts + (lambda () + (let ((n + (if (or (default-object? n) (not n)) + (quotient (window-y-size leaf) 2) + n)) + (x (window-x-size leaf)) + (y (window-y-size leaf))) + (let ((n* (- y n)) + (new (allocate-leaf! leaf true))) + (let ((combination (window-superior leaf))) + (inferior-start (window-inferior combination leaf) + (lambda (x y) + (set-inferior-start! (window-inferior combination new) + x + (+ y n))))) + (if (or (< n (==> leaf :minimum-y-size)) + (< n* (==> new :minimum-y-size))) + (begin + (deallocate-leaf! new) + false) + (begin + (==> leaf :set-y-size! n) + (==> new :set-size! x n*) + new))))))) + +(define (allocate-leaf! leaf v) + (let ((superior (window-superior leaf))) + (if (or (not (combination? superior)) + (not (eq? v (combination-vertical? superior)))) + (let ((combination (==> superior :make-inferior combination-window))) + (==> superior :set-inferior-position! combination + (==> superior :inferior-position leaf)) + (set-combination-vertical! combination v) + (window-replace! leaf combination) + (set-combination-child! combination leaf) + (set-window-next! leaf false) + (==> superior :delete-inferior! leaf) + (add-inferior! combination leaf) + (set-inferior-start! (window-inferior combination leaf) 0 0) + (set-window-size! combination + (window-x-size leaf) + (window-y-size leaf))))) + (let ((new (==> leaf :make-leaf))) + (set-window-next! new (window-next leaf)) + (if (window-next leaf) (set-window-previous! (window-next leaf) new)) + (link-windows! leaf new) + new)) + +(define (deallocate-leaf! leaf) + (unlink-leaf! leaf) + (maybe-delete-combination! (window-superior leaf))) + +;;;; Deletion + +(define (window-delete! leaf #!optional merge-into) + (check-leaf-window leaf 'WINDOW-DELETE!) + (if (window-live? leaf) + (let ((screen (window-screen leaf))) + (without-interrupts + (lambda () + (let ((superior (window-superior leaf)) + (next (window-next leaf)) + (previous (window-previous leaf)) + (x-size (window-x-size leaf)) + (y-size (window-y-size leaf))) + (if (not (combination? superior)) + (editor-error "Window has no neighbors; can't delete")) + (let ((adjust-size! + (lambda (window) + (if (current-window? leaf) + (select-window + (let loop ((window window)) + (if (combination? window) + (loop (combination-child window)) + window)))) + (unlink-leaf! leaf) + (if (combination-vertical? superior) + (==> window :set-y-size! + (+ (window-y-size window) y-size)) + (==> window :set-x-size! + (+ (window-x-size window) x-size)))))) + (let ((do-next + (lambda () + (adjust-size! next) + (let ((inferior (window-inferior superior next))) + (if (combination-vertical? superior) + (set-inferior-y-start! + inferior + (- (inferior-y-start inferior) y-size)) + (set-inferior-x-start! + inferior + (- (inferior-x-start inferior) x-size)))))) + (do-previous + (lambda () + (adjust-size! previous)))) + (cond ((and (not (default-object? merge-into)) + merge-into + (or (eq? merge-into next) + (eq? merge-into previous))) + (if (eq? merge-into next) + (do-next) + (do-previous))) + (next (do-next)) + (previous (do-previous)) + (else + (error "Combination with single child:" superior))))) + (maybe-delete-combination! superior)))) + (maybe-deselect-buffer-layout screen)))) + +(define (unlink-leaf! leaf) + (let ((combination (window-superior leaf)) + (next (window-next leaf)) + (previous (window-previous leaf))) + (==> leaf :kill!) + (delete-inferior! combination leaf) + (if previous + (set-window-next! previous next) + (set-combination-child! combination next)) + (if next + (set-window-previous! next previous)))) + +(define (maybe-delete-combination! combination) + (let ((child (combination-child combination))) + (if (not (window-next child)) + (begin + (delete-inferior! combination child) + (==> (window-superior combination) :replace-inferior! + combination + child) + (window-replace! combination child))))) + +(define (window-replace! old new) + (with-instance-variables combination-leaf-window old (new) + (cond ((not (combination? superior)) + (==> superior :new-root-window! new)) + ((and (combination? new) + (eq? (combination-vertical? superior) + (combination-vertical? new))) + (let ((first (combination-child new))) + (inferior-start (window-inferior superior new) + (lambda (xs ys) + (define (loop window) + (add-inferior! superior window) + (inferior-start (window-inferior new window) + (lambda (x y) + (set-inferior-start! (window-inferior superior window) + (+ xs x) + (+ ys y)))) + (if (window-next window) + (loop (window-next window)))) + (delete-inferior! superior new) + (loop first))) + (if next-window + (link-windows! (window-last first) next-window)) + (if previous-window + (link-windows! previous-window first) + (set-combination-child! superior first)))) + (else + (if next-window + (link-windows! new next-window)) + (if previous-window + (link-windows! previous-window new) + (set-combination-child! superior new)))))) + +;;;; Sizing + +(define (window-grow! vertical? size min-size set-w-size! start set-start! + scale-combination-inferiors!) + (lambda (leaf delta) + (check-leaf-window leaf 'WINDOW-GROW!) + (without-interrupts + (lambda () + (let ((leaf + (let loop ((leaf leaf)) + (let ((combination (window-superior leaf))) + (if (not (combination? combination)) + (editor-error "Can't grow this window " + (if vertical? + "vertically" + "horizontally"))) + (if (boolean=? vertical? (combination-vertical? combination)) + leaf + (loop combination)))))) + (let ((new-size (+ (size leaf) delta)) + (combination (window-superior leaf)) + (next (window-next leaf)) + (previous (window-previous leaf))) + (if (> new-size (size combination)) + (begin + (set! new-size (size combination)) + (set! delta (- new-size (size leaf))))) + (cond ((< new-size (min-size leaf)) + (window-delete! leaf)) + ((and next (>= (- (size next) delta) (min-size next))) + (let ((inferior (window-inferior combination next))) + (set-start! inferior (+ (start inferior) delta))) + (set-w-size! next (- (size next) delta)) + (set-w-size! leaf new-size)) + ((and previous + (>= (- (size previous) delta) (min-size previous))) + (let ((inferior (window-inferior combination leaf))) + (set-start! inferior (- (start inferior) delta))) + (set-w-size! previous (- (size previous) delta)) + (set-w-size! leaf new-size)) + (else + (scale-combination-inferiors! combination + (- (size combination) new-size) + leaf) + ;; Scaling may have deleted all other inferiors. + ;; If so, leaf has replaced combination. + (set-w-size! leaf + (if (eq? combination (window-superior leaf)) + new-size + (size combination))))))))))) + +;;; (SCALE-COMBINATION-INFERIORS! COMBINATION NEW-ROOM EXCEPT) + +;;; Change all of the inferiors of COMBINATION (except EXCEPT) to use +;;; NEW-ROOM's worth of space. EXCEPT, if given, should not be +;;; changed in size, but should be moved if its neighbors change. It +;;; is assumed that EXCEPT is given only for case where the +;;; combination's VERTICAL? flag is the same as V. + +;;; General strategy: + +;;; If the window is growing, we can simply change the sizes of the +;;; inferiors. However, if it is shrinking, we must be more careful +;;; because some or all of the inferiors can be deleted. So in that +;;; case, before any sizes are changed, we find those inferiors that +;;; will be deleted and delete them. If we delete all of the +;;; inferiors, then we are done: this window has also been deleted. +;;; Otherwise, we can then perform all of the changes, knowing that no +;;; window will grow too small. + +(define (scale-combination-inferiors! v size min-size set-w-size! set-start!) + (lambda (combination new-room except) + (let ((kernel + (lambda (old-room collect-deletions change-inferiors) + (cond ((< old-room new-room) + (change-inferiors)) + ((> old-room new-room) + (for-each window-delete! (collect-deletions)) + (if (not (null? (window-inferiors combination))) + (change-inferiors)))))) + (child (combination-child combination)) + (c-size (size combination))) + (if (not (eq? (combination-vertical? combination) v)) + (kernel + c-size + (lambda () + (let loop ((window child)) + (let ((deletions + (if (window-next window) + (loop (window-next window)) + '()))) + (if (< new-room (min-size window)) + (cons window deletions) + deletions)))) + (lambda () + (let loop ((window child)) + (set-w-size! window new-room) + (if (window-next window) + (loop (window-next window)))))) + (let ((old-room (if except (- c-size (size except)) c-size))) + (kernel + old-room + (lambda () + (let loop + ((window child) (old-room old-room) (new-room new-room)) + (cond ((eq? window except) + (if (window-next window) + (loop (window-next window) old-room new-room) + '())) + ((not (window-next window)) + (if (< new-room (min-size window)) + (list window) + '())) + (else + (let* ((old-s (size window)) + (new-s (quotient (* old-s new-room) old-room)) + (deletions + (loop (window-next window) + (- old-room old-s) + (- new-room new-s)))) + (if (< new-s (min-size window)) + (cons window deletions) + deletions)))))) + (lambda () + (let loop + ((window child) + (start 0) + (old-room old-room) + (new-room new-room)) + (set-start! (window-inferior combination window) start) + (cond ((eq? window except) + (if (window-next window) + (loop (window-next window) + start + old-room + new-room))) + ((not (window-next window)) + (set-w-size! window new-room)) + (else + (let* ((old-s (size window)) + (new-s (quotient (* old-s new-room) old-room))) + (set-w-size! window new-s) + (loop (window-next window) + (+ start new-s) + (- old-room old-s) + (- new-room new-s))))))))))))) + +(define (window-min-x-size window) + (==> window :minimum-x-size)) + +(define (send-window-x-size! window x) + (==> window :set-x-size! x)) + +(define (window-min-y-size window) + (==> window :minimum-y-size)) + +(define (send-window-y-size! window y) + (==> window :set-y-size! y)) + +(define scale-combination-inferiors-x! + (scale-combination-inferiors! false window-x-size window-min-x-size + send-window-x-size! set-inferior-x-start!)) + +(define scale-combination-inferiors-y! + (scale-combination-inferiors! true window-y-size window-min-y-size + send-window-y-size! set-inferior-y-start!)) + +(define window-grow-horizontally! + (window-grow! false window-x-size window-min-x-size send-window-x-size! + inferior-x-start set-inferior-x-start! + scale-combination-inferiors-x!)) + +(define window-grow-vertically! + (window-grow! true window-y-size window-min-y-size send-window-y-size! + inferior-y-start set-inferior-y-start! + scale-combination-inferiors-y!)) + +(define-method combination-window (:minimum-x-size combination) + (==> (window-leftmost-leaf combination) :minimum-x-size)) + +(define-method combination-window (:minimum-y-size combination) + (==> (window-leftmost-leaf combination) :minimum-y-size)) + +(define (set-combination-x-size! combination x) + (scale-combination-inferiors-x! combination x false) + (set-window-x-size! combination x)) + +(define (set-combination-y-size! combination y) + (scale-combination-inferiors-y! combination y false) + (set-window-y-size! combination y)) + +(define (set-combination-size! combination x y) + (scale-combination-inferiors-x! combination x false) + (scale-combination-inferiors-y! combination y false) + (set-window-size! combination x y)) + +(define-method combination-window :set-x-size! set-combination-x-size!) +(define-method combination-window :set-y-size! set-combination-y-size!) +(define-method combination-window :set-size! set-combination-size!) + +(define-method combination-window + (:leaf-containing-coordinates combination x y) + (inferior-containing-coordinates combination x y leaf?)) + +(define-method combination-leaf-window (:leaf-containing-coordinates leaf x y) + (values leaf x y)) \ No newline at end of file diff --git a/edwin/curren.scm b/edwin/curren.scm new file mode 100644 index 0000000..fa1cc70 --- /dev/null +++ b/edwin/curren.scm @@ -0,0 +1,747 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Current State + +(declare (usual-integrations)) + +;;;; Screens + +(define (screen-list) + (editor-screens current-editor)) + +(define (selected-screen) + (editor-selected-screen current-editor)) + +(define (selected-screen? screen) + (eq? screen (selected-screen))) + +(define (multiple-screens?) + (display-type/multiple-screens? (current-display-type))) + +(define (make-screen buffer . make-screen-args) + (let ((display-type (current-display-type))) + (if (not (display-type/multiple-screens? display-type)) + (error "display doesn't support multiple screens" display-type)) + (let ((screen + (without-interrupts + (lambda () + (let ((screen + (display-type/make-screen display-type make-screen-args))) + (initialize-screen-root-window! + screen + (editor-bufferset current-editor) + buffer) + (set-editor-screens! current-editor + (append! (editor-screens current-editor) + (list screen))) + (event-distributor/invoke! + (ref-variable frame-creation-hook #f) + screen) + (update-screen! screen #f) + screen))))) + (maybe-select-buffer-layout (screen-window0 screen) buffer) + screen))) + +(define-variable frame-creation-hook + "An event distributor that is invoked when a frame is created. +The new frame passed as its argument. +The frame is guaranteed to be deselected at that time." + (make-event-distributor)) +(define edwin-variable$screen-creation-hook edwin-variable$frame-creation-hook) + +(define (delete-screen! screen #!optional allow-kill-scheme?) + (without-interrupts + (lambda () + (if (not (screen-deleted? screen)) + (let ((other (other-screen screen 1 #t))) + (if other + (begin + (if (selected-screen? screen) + (select-screen (or (other-screen screen) other))) + (screen-discard! screen) + (set-editor-screens! current-editor + (delq! screen + (editor-screens current-editor))) + #t) + (if (or (default-object? allow-kill-scheme?) allow-kill-scheme?) + ((ref-command save-buffers-kill-scheme) #t) + #f))))))) + +(define (select-screen screen) + (without-interrupts + (lambda () + (if (not (screen-deleted? screen)) + (let ((screen* (selected-screen))) + (if (not (eq? screen screen*)) + (let ((message (current-message))) + (clear-current-message!) + (screen-exit! screen*) + (undo-leave-window! (screen-selected-window screen*)) + (let ((window (screen-selected-window screen))) + (change-selected-buffer (window-buffer window) window #t + (lambda () + (set-editor-selected-screen! current-editor screen)))) + (set-current-message! message) + (screen-enter! screen) + (update-screen! screen #f)))))))) + +(define (update-screens! display-style) + (let loop ((screens (screen-list))) + (if (null? screens) + (begin + ;; All the buffer changes have been successfully written to + ;; the screens, so erase the change records. + (do ((buffers (buffer-list) (cdr buffers))) + ((null? buffers)) + (set-group-start-changes-index! (buffer-group (car buffers)) #f)) + #t) + (and (update-screen! (car screens) display-style) + (loop (cdr screens)))))) + +(define (update-selected-screen! display-style) + (update-screen! (selected-screen) display-style)) + +(define (screen0) + (car (screen-list))) + +(define (screen1+ screen) + (let ((screens (screen-list))) + (let ((s (memq screen screens))) + (if (not s) + (error "not a member of screen-list" screen)) + (if (null? (cdr s)) + (car screens) + (cadr s))))) + +(define (screen-1+ screen) + (let ((screens (screen-list))) + (if (eq? screen (car screens)) + (car (last-pair screens)) + (let loop ((previous screens) (screens (cdr screens))) + (if (null? screens) + (error "not a member of screen-list" screen)) + (if (eq? screen (car screens)) + (car previous) + (loop screens (cdr screens))))))) + +(define (screen+ screen n) + (cond ((positive? n) + (let loop ((n n) (screen screen)) + (if (= n 1) + (screen1+ screen) + (loop (-1+ n) (screen1+ screen))))) + ((negative? n) + (let loop ((n n) (screen screen)) + (if (= n -1) + (screen-1+ screen) + (loop (1+ n) (screen-1+ screen))))) + (else + screen))) + +(define (other-screen screen #!optional n invisible-ok?) + (let ((n (if (default-object? n) 1 n)) + (invisible-ok? (if (default-object? invisible-ok?) #f invisible-ok?))) + (let ((next-screen (if (> n 0) screen1+ screen-1+))) + (let loop ((screen* screen) (n (abs n))) + (if (= n 0) + screen* + (let ((screen* (next-screen screen*))) + (and (not (eq? screen* screen)) + (loop screen* + (if (or invisible-ok? (screen-visible? screen*)) + (- n 1) + n))))))))) + +;;;; Windows + +(define (window-list) + (append-map screen-window-list (screen-list))) + +(define (selected-window) + (screen-selected-window (selected-screen))) + +(define (selected-window? window) + (eq? window (selected-window))) + +(define current-window selected-window) +(define current-window? selected-window?) + +(define (window0) + (screen-window0 (selected-screen))) + +(define (select-window window) + (without-interrupts + (lambda () + (let* ((screen (window-screen window)) + (window* (screen-selected-window screen))) + (if (eq? window window*) + (if (not (selected-screen? screen)) + (select-screen screen)) + (begin + (undo-leave-window! window*) + (if (selected-screen? screen) + (change-selected-buffer (window-buffer window) window #t + (lambda () + (screen-select-window! screen window))) + (begin + (screen-select-window! screen window) + (select-screen screen))))))))) + +(define (select-cursor window) + (screen-select-cursor! (window-screen window) window)) + +(define (window-visible? window) + (and (window-live? window) + (screen-visible? (window-screen window)))) + +(define (window-live? window) + (let ((screen (window-screen window))) + (or (eq? window (screen-typein-window screen)) + (let ((window0 (screen-window0 screen))) + (let loop ((window* (window1+ window0))) + (or (eq? window window*) + (and (not (eq? window* window0)) + (loop (window1+ window*))))))))) + +(define (global-window-modeline-event! #!optional predicate) + (let ((predicate + (if (or (default-object? predicate) (not predicate)) + (lambda (window) window 'GLOBAL-MODELINE) + predicate))) + (for-each + (lambda (screen) + (let ((window0 (screen-window0 screen))) + (let loop ((window (window1+ window0))) + (let ((type (predicate window))) + (if type + (window-modeline-event! window type))) + (if (not (eq? window window0)) + (loop (window1+ window)))))) + (screen-list)))) + +(define (other-window #!optional n other-screens?) + (let ((n (if (or (default-object? n) (not n)) 1 n)) + (other-screens? + (if (default-object? other-screens?) #f other-screens?)) + (selected-window (selected-window)) + (typein-ok? (within-typein-edit?))) + (cond ((positive? n) + (let loop ((n n) (window selected-window)) + (if (zero? n) + window + (let ((window + (next-visible-window window + typein-ok? + other-screens?))) + (if window + (loop (-1+ n) window) + selected-window))))) + ((negative? n) + (let loop ((n n) (window selected-window)) + (if (zero? n) + window + (let ((window + (previous-visible-window window + typein-ok? + other-screens?))) + (if window + (loop (1+ n) window) + selected-window))))) + (else + selected-window)))) + +(define (next-visible-window first-window typein-ok? #!optional other-screens?) + (let ((other-screens? + (if (default-object? other-screens?) #f other-screens?)) + (first-screen (window-screen first-window))) + (letrec + ((next-screen + (lambda (screen) + (let ((screen (if other-screens? (screen1+ screen) screen))) + (let ((window (screen-window0 screen))) + (if (screen-visible? screen) + (and (not (and (eq? screen first-screen) + (eq? window first-window))) + window) + (and (not (eq? screen first-screen)) + (next-screen screen)))))))) + (if (or (not (screen-visible? first-screen)) + (eq? first-window (screen-typein-window first-screen))) + (next-screen first-screen) + (let ((window (window1+ first-window))) + (if (eq? window (screen-window0 first-screen)) + (or (and typein-ok? (screen-typein-window first-screen)) + (next-screen first-screen)) + window)))))) + +(define (previous-visible-window first-window typein-ok? + #!optional other-screens?) + (let ((other-screens? + (if (default-object? other-screens?) #f other-screens?)) + (first-screen (window-screen first-window))) + (letrec + ((previous-screen + (lambda (screen) + (let ((screen (if other-screens? (screen-1+ screen) screen))) + (let ((window + (or (and typein-ok? (screen-typein-window screen)) + (window-1+ (screen-window0 screen))))) + (if (screen-visible? screen) + (and (not (and (eq? screen first-screen) + (eq? window first-window))) + window) + (and (not (eq? screen first-screen)) + (previous-screen screen)))))))) + (if (or (not (screen-visible? first-screen)) + (eq? first-window (screen-window0 first-screen))) + (previous-screen first-screen) + (window-1+ first-window))))) + +(define (typein-window) + (screen-typein-window (selected-screen))) + +(define (typein-window? window) + (eq? window (screen-typein-window (window-screen window)))) + +(define (current-message) + (window-override-message (typein-window))) + +(define (set-current-message! message) + (let ((window (typein-window))) + (if (and message (not *suppress-messages?*)) + (window-set-override-message! window message) + (window-clear-override-message! window)) + (if (not *executing-keyboard-macro?*) + (window-direct-update! window #t)))) + +(define (clear-current-message!) + (let ((window (typein-window))) + (window-clear-override-message! window) + (if (not *executing-keyboard-macro?*) + (window-direct-update! window #t)))) + +(define (with-messages-suppressed thunk) + (fluid-let ((*suppress-messages?* #t)) + (clear-current-message!) + (thunk))) + +(define *suppress-messages?* #f) + +;;;; Buffers + +(define (buffer-list) + (bufferset-buffer-list (current-bufferset))) + +(define (buffer-alive? buffer) + (memq buffer (buffer-list))) + +(define (buffer-names) + (bufferset-names (current-bufferset))) + +(define (selected-buffer) + (window-buffer (selected-window))) + +(define (selected-buffer? buffer) + (eq? buffer (selected-buffer))) + +(define current-buffer selected-buffer) +(define current-buffer? selected-buffer?) + +(define (previous-buffer) + (other-buffer (selected-buffer))) + +(define (other-buffer buffer) + (let loop ((less-preferred #f) (buffers (buffer-list))) + (cond ((null? buffers) + less-preferred) + ((or (eq? buffer (car buffers)) + (minibuffer? (car buffers))) + (loop less-preferred (cdr buffers))) + ((buffer-visible? (car buffers)) + (loop (or less-preferred (car buffers)) (cdr buffers))) + (else + (car buffers))))) + +(define (bury-buffer buffer) + (bufferset-bury-buffer! (current-bufferset) buffer)) + +(define (find-buffer name #!optional error?) + (let ((buffer (bufferset-find-buffer (current-bufferset) name))) + (if (and (not buffer) + (not (default-object? error?)) + error?) + (editor-error "No buffer named " name)) + buffer)) + +(define (create-buffer name) + (bufferset-create-buffer (current-bufferset) name)) + +(define (find-or-create-buffer name) + (bufferset-find-or-create-buffer (current-bufferset) name)) + +(define (rename-buffer buffer new-name) + (without-interrupts + (lambda () + (run-buffer-hooks 'RENAME-BUFFER-HOOKS buffer new-name) + (bufferset-rename-buffer (current-bufferset) buffer new-name)))) + +(define (add-rename-buffer-hook buffer hook) + (add-buffer-hook buffer 'RENAME-BUFFER-HOOKS hook)) + +(define (remove-rename-buffer-hook buffer hook) + (remove-buffer-hook buffer 'RENAME-BUFFER-HOOKS hook)) + +(define (kill-buffer buffer) + (without-interrupts + (lambda () + (if (not (make-buffer-invisible buffer)) + (error "Buffer to be killed has no replacement" buffer)) + (for-each (lambda (process) + (hangup-process process #t) + (set-process-buffer! process #f)) + (buffer-processes buffer)) + (run-buffer-hooks 'KILL-BUFFER-HOOKS buffer) + (delete-buffer-layout buffer) + (bufferset-kill-buffer! (current-bufferset) buffer)))) + +(define (make-buffer-invisible buffer) + (let loop ((windows (buffer-windows buffer)) (last-buffer #f)) + (or (not (pair? windows)) + (let ((new-buffer (or (other-buffer buffer) last-buffer))) + (and new-buffer + (begin + (select-buffer-no-record new-buffer (car windows)) + (loop (cdr windows) new-buffer))))))) + +(define (add-kill-buffer-hook buffer hook) + (add-buffer-hook buffer 'KILL-BUFFER-HOOKS hook)) + +(define (remove-kill-buffer-hook buffer hook) + (remove-buffer-hook buffer 'KILL-BUFFER-HOOKS hook)) + +(define (add-buffer-hook buffer key hook) + (let ((hooks (buffer-get buffer key '()))) + (cond ((null? hooks) + (buffer-put! buffer key (list hook))) + ((not (memq hook hooks)) + (set-cdr! (last-pair hooks) (list hook)))))) + +(define (remove-buffer-hook buffer key hook) + (buffer-put! buffer key (delq! hook (buffer-get buffer key '())))) + +(define (run-buffer-hooks key buffer . arguments) + (for-each (lambda (hook) (apply hook buffer arguments)) + (list-copy (buffer-get buffer key '())))) + +(define (select-buffer buffer #!optional window) + (select-buffer-in-window buffer + (if (or (default-object? window) (not window)) + (selected-window) + window) + #t)) + +(define (select-buffer-no-record buffer #!optional window) + (select-buffer-in-window buffer + (if (or (default-object? window) (not window)) + (selected-window) + window) + #f)) + +(define (select-buffer-in-window buffer window record?) + (if (without-interrupts + (lambda () + (and (not (eq? buffer (window-buffer window))) + (begin + (undo-leave-window! window) + (if (selected-window? window) + (change-selected-buffer buffer window record? + (lambda () + (set-window-buffer! window buffer))) + (set-window-buffer! window buffer)) + #t)))) + (maybe-select-buffer-layout window buffer))) + +(define (change-selected-buffer buffer window record? selection-thunk) + (change-local-bindings! (selected-buffer) buffer selection-thunk) + (set-buffer-point! buffer (window-point window)) + (if record? (bufferset-select-buffer! (current-bufferset) buffer)) + (run-buffer-hooks 'SELECT-BUFFER-HOOKS buffer window) + (if (not (minibuffer? buffer)) + (event-distributor/invoke! (ref-variable select-buffer-hook #f) + buffer + window))) + +(define (add-select-buffer-hook buffer hook) + (add-buffer-hook buffer 'SELECT-BUFFER-HOOKS hook)) + +(define (remove-select-buffer-hook buffer hook) + (remove-buffer-hook buffer 'SELECT-BUFFER-HOOKS hook)) + +(define-variable select-buffer-hook + "An event distributor that is invoked when a buffer is selected. +The new buffer and the window in which it is selected are passed as arguments. +The buffer is guaranteed to be selected at that time." + (make-event-distributor)) + +(define (with-selected-buffer buffer thunk) + (let ((old-buffer)) + (dynamic-wind (lambda () + (let ((window (selected-window))) + (set! old-buffer (window-buffer window)) + (if (buffer-alive? buffer) + (select-buffer buffer window))) + (set! buffer) + unspecific) + thunk + (lambda () + (let ((window (selected-window))) + (set! buffer (window-buffer window)) + (if (buffer-alive? old-buffer) + (select-buffer old-buffer window))) + (set! old-buffer) + unspecific)))) + +(define (current-process) + (let ((process (get-buffer-process (selected-buffer)))) + (if (not process) + (editor-error "Selected buffer has no process")) + process)) + +;;;; Buffer Layouts + +(define (create-buffer-layout selector buffers) + (let ((layout (cons selector (list->weak-list buffers)))) + (without-interrupts + (lambda () + (for-each (lambda (buffer) + (if (buffer-get buffer buffer-layout-key #f) + (error "Can't add buffer to multiple layouts:" buffer))) + buffers) + (for-each (lambda (buffer) + (buffer-put! buffer buffer-layout-key layout)) + buffers))))) + +(define (maybe-select-buffer-layout window buffer) + (if (not (or setting-up-buffer-layout? (typein-window? window))) + (let ((layout + (without-interrupts + (lambda () + (maybe-select-buffer-layout-1 window buffer))))) + (if layout + (fluid-let ((setting-up-buffer-layout? #t)) + ((car layout) window (weak-list->list (cdr layout)))))))) + +(define (maybe-select-buffer-layout-1 window buffer) + (let ((screen (window-screen window))) + (let ((l1 (hash-table-ref/default screen-buffer-layouts screen #f)) + (l2 (buffer-get buffer buffer-layout-key #f))) + (and (or (not (eq? l1 l2)) + (and l1 (buffer-layout-visible? l1 screen))) + (begin + (if l1 + (begin + (hash-table-delete! screen-buffer-layouts screen) + (delete-other-windows window))) + (and l2 + (if (let loop ((buffers (cdr l2))) + (or (not (weak-pair? buffers)) + (and (let ((buffer (weak-car buffers))) + (and (buffer? buffer) + (buffer-alive? buffer))) + (loop (weak-cdr buffers))))) + (begin + (delete-other-windows window) + (hash-table-set! screen-buffer-layouts screen l2) + l2) + (begin + (delete-buffer-layout-1 l2) + #f)))))))) + +(define (maybe-deselect-buffer-layout screen) + (without-interrupts + (lambda () + (if (hash-table-ref/default screen-buffer-layouts screen #f) + (begin + (hash-table-delete! screen-buffer-layouts screen) + (delete-other-windows (screen-selected-window screen))))))) + +(define (delete-buffer-layout buffer) + ;; Caller disables interrupts. + (let ((layout (buffer-get buffer buffer-layout-key #f))) + (if layout + (delete-buffer-layout-1 layout)))) + +(define (delete-buffer-layout-1 layout) + (hash-table-walk screen-buffer-layouts + (lambda (screen layout*) + (if (eq? layout layout*) + (hash-table-delete! screen-buffer-layouts screen)))) + (do ((buffers (cdr layout) (weak-cdr buffers))) + ((not (weak-pair? buffers))) + (let ((buffer (weak-car buffers))) + (if (buffer? buffer) + (buffer-remove! buffer buffer-layout-key))))) + +(define (buffer-layout-visible? layout screen) + (let loop ((buffers (cdr layout))) + (and (weak-pair? buffers) + (or (not (let ((buffer (weak-car buffers))) + (and (buffer? buffer) + (any (lambda (window) + (eq? (window-screen window) screen)) + (buffer-windows buffer))))) + (loop (weak-cdr buffers)))))) + +(define setting-up-buffer-layout? #f) +(define buffer-layout-key (list 'BUFFER-LAYOUT)) +(define screen-buffer-layouts) + +(add-event-receiver! editor-initializations + (lambda () + (set! screen-buffer-layouts (make-key-weak-eq-hash-table)) + unspecific)) + +;;;; Point + +(define (current-point) + (window-point (selected-window))) + +(define (set-current-point! mark) + (set-window-point! (selected-window) mark)) + +(define (set-buffer-point! buffer mark) + (let ((window (selected-window))) + (if (eq? buffer (window-buffer window)) + (set-window-point! window mark) + (let ((windows (buffer-windows buffer))) + (if (pair? windows) + (set-window-point! (car windows) mark) + (%set-buffer-point! buffer mark)))))) + +(define (with-current-point point thunk) + (let ((old-point)) + (dynamic-wind (lambda () + (let ((window (selected-window))) + (set! old-point (window-point window)) + (set-window-point! window point)) + (set! point) + unspecific) + thunk + (lambda () + (let ((window (selected-window))) + (set! point (window-point window)) + (set-window-point! window old-point)) + (set! old-point) + unspecific)))) + +(define (current-column) + (mark-column (current-point))) + +(define (save-excursion thunk) + (let ((point (mark-right-inserting-copy (current-point))) + (mark (mark-right-inserting-copy (current-mark)))) + (thunk) + (let ((buffer (mark-buffer point))) + (if (buffer-alive? buffer) + (begin + (select-buffer buffer) + (set-current-point! point) + (set-current-mark! mark)))))) + +;;;; Mark and Region + +(define (current-mark) + (buffer-mark (selected-buffer))) + +(define (buffer-mark buffer) + (let ((ring (buffer-mark-ring buffer))) + (if (ring-empty? ring) + (editor-error) + (ring-ref ring 0)))) + +(define (set-current-mark! mark) + (set-buffer-mark! (selected-buffer) (guarantee-mark mark))) + +(define (set-buffer-mark! buffer mark) + (ring-set! (buffer-mark-ring buffer) 0 (mark-right-inserting-copy mark))) + +(define-variable auto-push-point-notification + "Message to display when point is pushed on the mark ring. +If false, don't display any message." + "Mark set" + string-or-false?) + +(define (push-current-mark! mark) + (push-buffer-mark! (selected-buffer) (guarantee-mark mark)) + (let ((notification (ref-variable auto-push-point-notification))) + (if (and notification + (not *executing-keyboard-macro?*) + (not (typein-window? (selected-window)))) + (temporary-message notification)))) + +(define (push-buffer-mark! buffer mark) + (ring-push! (buffer-mark-ring buffer) (mark-right-inserting-copy mark))) + +(define (pop-current-mark!) + (pop-buffer-mark! (selected-buffer))) + +(define (pop-buffer-mark! buffer) + (ring-pop! (buffer-mark-ring buffer))) + +(define (current-region) + (make-region (current-point) (current-mark))) + +(define (set-current-region! region) + (set-current-point! (region-start region)) + (push-current-mark! (region-end region))) + +(define (set-current-region-reversed! region) + (push-current-mark! (region-start region)) + (set-current-point! (region-end region))) + +;;;; Modes and Comtabs + +(define (current-major-mode) + (buffer-major-mode (selected-buffer))) + +(define (current-minor-modes) + (buffer-minor-modes (selected-buffer))) + +(define (current-comtabs) + (buffer-comtabs (selected-buffer))) + +(define (set-current-major-mode! mode) + (set-buffer-major-mode! (selected-buffer) mode)) + +(define (current-minor-mode? mode) + (buffer-minor-mode? (selected-buffer) mode)) + +(define (enable-current-minor-mode! mode) + (enable-buffer-minor-mode! (selected-buffer) mode)) + +(define (disable-current-minor-mode! mode) + (disable-buffer-minor-mode! (selected-buffer) mode)) \ No newline at end of file diff --git a/edwin/dabbrev.scm b/edwin/dabbrev.scm new file mode 100644 index 0000000..4207f9b --- /dev/null +++ b/edwin/dabbrev.scm @@ -0,0 +1,248 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Dynamic Abbrev + +(declare (usual-integrations)) + +(define-variable dabbrevs-backward-only + "If true, dabbrevs-expand only looks backwards." + false + boolean?) + +(define-variable-per-buffer dabbrevs-limit + "Limits region searched by dabbrevs-expand to that many chars away (local)." + false + (lambda (object) + (or (not object) + (exact-integer? object)))) + +(define-variable-per-buffer last-dabbrev-table + "Table of expansions seen so far (local)." + '()) + +(define-variable-per-buffer last-dabbrevs-abbreviation + "Last string we tried to expand (local)." + "" + string?) + +(define-variable-per-buffer last-dabbrevs-direction + "Direction of last dabbrevs search (local)." + 0 + exact-integer?) + +(define-variable-per-buffer last-dabbrevs-abbrev-location + "Location last abbreviation began (local)." + false) + +(define-variable-per-buffer last-dabbrevs-expansion + "Last expansion of an abbreviation (local)." + false) + +(define-variable-per-buffer last-dabbrevs-expansion-location + "Location the last expansion was found (local)." + false) + +(define dabbrev-tag "Dabbrev") + +(define-command dabbrev-expand + "Expand previous word \"dynamically\". +Expands to the most recent, preceding word for which this is a prefix. +If no suitable preceding word is found, words following point are considered. + +A positive prefix argument, N, says to take the Nth backward DISTINCT +possibility. A negative argument says search forward. The variable +dabbrev-backward-only may be used to limit the direction of search to +backward if set non-nil. + +If the cursor has not moved from the end of the previous expansion and +no argument is given, replace the previously-made expansion +with the next possible expansion not yet tried." + "*P" + (lambda (arg) + (define (do-abbrev loc abbrev old which) + (let ((do-case (and (ref-variable case-fold-search) + (ref-variable case-replace))) + (pattern (string-append "\\b" + (re-quote-string abbrev) + "\\(\\sw\\|\\s_\\)+"))) + + (define (search&setup-table count direction) + (let loop ((n count) + (expansion false) + (start + (or (ref-variable last-dabbrevs-expansion-location) + (current-point)))) + (if (zero? n) + (values (mark-permanent-copy start) expansion) + (call-with-values + (lambda () + (dabbrevs-search start pattern direction do-case)) + (lambda (loc expansion) + (if (not expansion) + (values false false) + (begin + (set-variable! + last-dabbrev-table + (cons expansion + (ref-variable last-dabbrev-table))) + (loop (-1+ n) expansion loc)))))))) + + (define (step3 loc expansion) + (if (not expansion) + (let ((first (string=? abbrev old))) + (set-variable! last-dabbrevs-abbrev-location false) + (if (not first) + (let* ((end (current-point)) + (start (mark- end (string-length old)))) + (delete-string start end) + (insert-string abbrev start))) + (editor-error (if first + "No dynamic expansion found for " + "No further dynamic expansions found for ") + abbrev)) + ;; Success: stick it in and return. + ;; Make case of replacement conform to case of abbreviation + ;; provided (1) that kind of thing is enabled in this buffer + ;; and (2) the replacement itself is all lower case + ;; except perhaps for the first character. + (let ((place (search-backward old + (current-point) + (buffer-start (current-buffer)))) + (do-case (and do-case + (substring-lower-case? + expansion + 1 + (string-length expansion))))) + ;; First put back the original abbreviation with its original + ;; case pattern. + (replace-match abbrev false true) + (search-forward abbrev + place + (buffer-end (current-buffer))) + (replace-match (if do-case + (string-downcase expansion) + expansion) + do-case + true) + ;; Save state for re-expand. + (set-variable! last-dabbrevs-abbreviation abbrev) + (set-variable! last-dabbrevs-expansion expansion) + (set-variable! last-dabbrevs-expansion-location loc) + ;; Chain invocations + (set-command-message! dabbrev-tag)))) + + (define (step2 loc expansion) + (if (or expansion (> which 0)) + (step3 loc expansion) + ;; Look forward + (call-with-values + (lambda () (search&setup-table (max 1 (- which)) false)) + (lambda (loc expansion) + (set-variable! last-dabbrevs-direction -1) + (step3 loc expansion))))) + + ;; Try looking backward unless inhibited. + (if (< which 0) + (step2 loc false) + (call-with-values + (lambda () (search&setup-table (max 1 which) true)) + (lambda (loc expansion) + (if (not expansion) + (set-variable! last-dabbrevs-expansion-location + false)) + (set-variable! last-dabbrevs-direction (min 1 which)) + (step2 loc expansion)))))) + + (define (do-from-scratch) + (let* ((loc (current-point)) + (start (backward-word loc 1 'ERROR)) + (abbrev (extract-string start loc))) + (set-variable! last-dabbrevs-abbrev-location start) + (set-variable! last-dabbrevs-expansion-location false) + (set-variable! last-dabbrev-table '()) + (do-abbrev loc + abbrev + abbrev + (cond (arg + (command-argument-value arg)) + ((ref-variable dabbrevs-backward-only) + 1) + (else + 0))))) + + (if (and (not arg) + (command-message-receive dabbrev-tag + (lambda () true) + (lambda () false)) + (ref-variable last-dabbrevs-abbrev-location)) + (do-abbrev false + (ref-variable last-dabbrevs-abbreviation) + (ref-variable last-dabbrevs-expansion) + (ref-variable last-dabbrevs-direction)) + (do-from-scratch)))) + +;; Search function used by dabbrevs library. +;; pattern is string to find as prefix of word. +;; reverse? is true for reverse search, false for forward. +;; Variable abbrevs-limit controls the maximum search region size. + +;; Table of expansions already seen is examined in buffer last-dabbrev-table, +;; so that only distinct possibilities are found by dabbrevs-re-expand. +;; Note that to prevent finding the abbrev itself it must have been +;; entered in the table. + +;; Values are false if no expansion found. +;; After a succesful search, values are a mark right after the expansion, +;; and the expansion itself. + +(define (dabbrevs-search start pattern reverse? do-case) + ;; (values loc expansion) + (let ((limit (let ((limit (ref-variable dabbrevs-limit))) + (if limit + ((if reverse? mark- mark+) + start + limit) + ((if reverse? buffer-start buffer-end) + (current-buffer)))))) + (let loop ((posn start)) + (if (not ((if reverse? re-search-backward re-search-forward) + pattern posn limit)) + (values false false) + (let ((start (re-match-start 0)) + (end (re-match-end 0))) + (let* ((result (extract-string start end)) + (test (if do-case + (string-downcase result) + result))) + (if (any (lambda (example) + (string=? test + (if do-case + (string-downcase example) + example))) + (ref-variable last-dabbrev-table)) + (loop (if reverse? start end)) + (values end result)))))))) \ No newline at end of file diff --git a/edwin/debian-changelog.scm b/edwin/debian-changelog.scm new file mode 100644 index 0000000..9ccfe0c --- /dev/null +++ b/edwin/debian-changelog.scm @@ -0,0 +1,273 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Debian changelog mode + +(declare (usual-integrations)) + +(define-command debian-changelog-mode + "Enter Debian changelog mode." + () + (lambda () (set-current-major-mode! (ref-mode-object debian-changelog)))) + +(define-major-mode debian-changelog text "Debian changelog" + "Major mode for editing Debian-style change logs. +Runs `debian-changelog-mode-hook' if it exists. + +Key bindings: + +\\{debian-changelog}" + (lambda (buffer) + (local-set-variable! fill-prefix " " buffer) + (local-set-variable! fill-column 74 buffer) + + ;; Let each entry behave as one paragraph: + (local-set-variable! paragraph-start "\\*" buffer) + (local-set-variable! paragraph-separate "\\*\\|\\s-*$|\\S-" buffer) + + ;; Let each version behave as one page. + ;; Match null string on the heading line so that the heading line + ;; is grouped with what follows. + (local-set-variable! page-delimiter "^\\<" buffer) + (local-set-variable! version-control 'NEVER buffer) + + (event-distributor/invoke! (ref-variable debian-changelog-mode-hook buffer) + buffer))) + +(define-key 'debian-changelog '(#\C-c #\C-a) 'debian-changelog-add-entry) +(define-key 'debian-changelog '(#\C-c #\C-f) + 'debian-changelog-finalize-last-version) +(define-key 'debian-changelog '(#\C-c #\C-c) + 'debian-changelog-finalize-and-save) +(define-key 'debian-changelog '(#\C-c #\C-v) 'debian-changelog-add-version) +(define-key 'debian-changelog '(#\C-c #\C-d) 'debian-changelog-distribution) +(define-key 'debian-changelog '(#\C-c #\C-u) 'debian-changelog-urgency) +(define-key 'debian-changelog '(#\C-c #\C-e) + 'debian-changelog-unfinalize-last-version) + +(define-command debian-changelog-add-version + "Add a new version section to a debian-style changelog file." + () + (lambda () + (let ((buffer (selected-buffer))) + (if (not (version-finalized? buffer)) + (error "Previous version not yet finalized.")) + (let* ((finish + (lambda (package version) + (let ((m (mark-left-inserting-copy (buffer-start buffer)))) + (insert-string package m) + (insert-string " (" m) + (insert-string version m) + (insert-string ") unstable; urgency=low" m) + (insert-newlines 2 m) + (insert-string " * " m) + (let ((p (mark-right-inserting-copy m))) + (insert-newlines 2 m) + (insert-string " --" m) + (insert-newlines 2 m) + (mark-temporary! m) + (mark-temporary! p) + (set-buffer-point! buffer p))))) + (prompt + (lambda () + (let ((package (prompt-for-string "Package name" #f))) + (finish package + (prompt-for-string + "New version (including any revision)" + #f)))))) + (if (match-title-line buffer #f) + (let ((package + (re-match-extract-string title-regexp-index:package-name)) + (version + (re-match-extract-string title-regexp-index:version))) + (let ((regs + (re-string-search-forward "\\([0-9]+\\)$" version))) + (if regs + (finish + package + (string-append + (string-head version (re-match-start-index 1 regs)) + (number->string + (+ (string->number (re-match-extract version regs 1)) + 1)))) + (prompt)))) + (prompt)))))) + +(define-command debian-changelog-add-entry + "Add a new change entry to a debian-style changelog." + () + (lambda () + (let ((buffer (selected-buffer))) + (if (version-finalized? buffer) + (error + (substitute-command-keys + (string-append + "Most recent version has been finalized - use " + "\\[debian-changelog-unfinalize-last-version] or " + "\\[debian-changelog-add-version]") + buffer))) + (let ((m (mark-left-inserting-copy (mark- (trailer-line buffer) 4)))) + (guarantee-newline m) + (insert-string " * " m) + (insert-newline m) + (mark-temporary! m) + (set-current-point! (mark-1+ m)))))) + +(define-command debian-changelog-distribution + "Delete the current distribution and prompt for a new one." + () + (lambda () + (set-title-distribution (selected-buffer) + (prompt-for-alist-value + "Select distribution" + (map (lambda (s) (cons s s)) + '("stable" + "frozen" + "unstable" + "stable frozen unstable" + "stable unstable frozen" + "unstable stable frozen" + "unstable frozen stable" + "frozen unstable stable" + "frozen stable unstable" + "frozen unstable" + "unstable frozen" + "stable frozen" + "frozen stable" + "stable unstable" + "unstable stable")))))) + +(define-command debian-changelog-urgency + "Delete the current urgency and prompt for a new one." + () + (lambda () + (set-title-urgency (selected-buffer) + (prompt-for-alist-value + "Select urgency" + (map (lambda (s) (cons s s)) + '("low" "medium" "high" )))))) + +(define-command debian-changelog-finalize-and-save + "Finalize, if necessary, and then save a debian-style changelog file." + () + (lambda () + (let ((buffer (selected-buffer))) + (if (not (version-finalized? buffer)) + (finalize-last-version buffer)) + (save-buffer buffer #f)))) + +(define-command debian-changelog-finalize-last-version + "Add the `finalization' information (maintainer's name and email +address and release date)." + () + (lambda () (finalize-last-version (selected-buffer)))) + +(define (finalize-last-version buffer) + (let ((m (mark-left-inserting-copy (trailer-line buffer)))) + (delete-string m (line-end m 0)) + (insert-string " " m) + (insert-string (or (ref-variable add-log-full-name buffer) + (mail-full-name buffer)) + m) + (insert-string " <" m) + (insert-string (or (ref-variable add-log-mailing-address buffer) + (user-mail-address buffer)) + m) + (insert-string "> " m) + (insert-string (universal-time->string (get-universal-time)) m) + (mark-temporary! m))) + +(define-command debian-changelog-unfinalize-last-version + "Remove the `finalization' information (maintainer's name and email +address and release date) so that new entries can be made." + () + (lambda () + (let ((buffer (selected-buffer))) + (if (not (version-finalized? buffer)) + (error "Most recent version is not finalized.")) + (let ((m (trailer-line buffer))) + (delete-string m (line-end m 0)))))) + +(define (version-finalized? buffer) + (let ((m (trailer-line buffer))) + (cond ((re-match-forward + "[ \t]+\\S [^\n\t]+\\S <[^ \t\n<>]+> \\S [^\t\n]+\\S [ \t]*$" + m) + #t) + ((re-match-forward "[ \t]*$" m) #f) + (else (error "Malformed finalization line."))))) + +(define (trailer-line buffer) + (let ((start (buffer-start buffer)) + (end (buffer-end buffer))) + (let ((m + (if (re-search-forward "\n\\S " start end) + (mark1+ (re-match-start 0)) + end))) + (if (re-search-backward "\n --" m) + (re-match-end 0) + (let ((m (mark-left-inserting-copy m))) + (insert-string " --" m) + (insert-newlines 2 m) + (mark-temporary! m) + (mark- m 2)))))) + +(define (set-title-distribution buffer distribution) + (set-title-value buffer title-regexp-index:distribution distribution)) + +(define (set-title-urgency buffer urgency) + (set-title-value buffer title-regexp-index:urgency urgency)) + +(define (set-title-value buffer index value) + (match-title-line buffer #t) + (let ((s (mark-left-inserting-copy (re-match-start index))) + (e (re-match-end index))) + (delete-string s e) + (insert-string value s) + (mark-temporary! s))) + +(define (match-title-line buffer error?) + (or (let ((start (buffer-start buffer))) + (re-match-forward title-regexp start (line-end start 0))) + (and error? (error "Unable to match title line.")))) + +(define title-regexp + (let ((package-name "[a-zA-Z0-9+.-]+") + (version "[a-zA-Z0-9+.:-]+")) + (string-append "^\\(" + package-name + "\\) +(\\(" + version + "\\)) \\( *" + package-name + "\\( +" + package-name + "\\)* *\\);.*" + " urgency=\\([a-zA-Z0-9]+\\)"))) +(define title-regexp-index:package-name 1) +(define title-regexp-index:version 2) +(define title-regexp-index:distribution 3) +(define title-regexp-index:urgency 5) \ No newline at end of file diff --git a/edwin/debug.scm b/edwin/debug.scm new file mode 100644 index 0000000..8964768 --- /dev/null +++ b/edwin/debug.scm @@ -0,0 +1,1788 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Browser-style Debug and Where +;;; Package: (edwin debugger) + +(declare (usual-integrations)) + +;;;; Text prop setup stuff + +(define (with-output-highlighted port thunk) + (let ((start (mark-temporary-copy (port/mark port)))) + (thunk) + (highlight-region (make-region start (port/mark port)) (highlight-face)))) + +(define (read-only-between start end) + (region-read-only (make-region start end))) + +(define (readable-between start end) + (region-writeable (make-region start end))) + +(define (dehigh-between start end) + (highlight-region (make-region start end) (default-face))) + +(define (debugger-pp-highlight-subexpression expression subexpression + indentation port) + (let ((start-mark #f) + (end-mark #f)) + (parameterize ((param:pp-no-highlights? #f)) + (debugger-pp + (unsyntax-with-substitutions + expression + (list (cons subexpression + (make-pretty-printer-highlight + (unsyntax subexpression) + (lambda (port) + (set! start-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific) + (lambda (port) + (set! end-mark + (mark-right-inserting-copy + (output-port->mark port))) + unspecific))))) + indentation + port)) + (if (and start-mark end-mark) + (highlight-region-excluding-indentation + (make-region start-mark end-mark) + (highlight-face))) + (if start-mark (mark-temporary! start-mark)) + (if end-mark (mark-temporary! end-mark)))) + +;;;; Browsers + +(define-record-type + (%make-browser buffer object name lines selected-line buffers properties) + browser? + + ;; The browser's buffer. + (buffer browser/buffer) + + ;; The object being browsed. + (object browser/object) + + ;; Name of this browser, a string. Not necessarily unique. + (name browser/name) + + ;; Vector of BLINE objects, sorted in order of increasing INDEX. + (lines browser/lines set-browser/lines!) + + ;; The current selected BLINE object. + (selected-line browser/selected-line set-browser/selected-line!) + + ;; List of buffers associated with this browser. + (buffers browser/buffers set-browser/buffers!) + + (properties browser/properties)) + +(define (make-browser name mode object) + (let ((buffer (new-buffer name))) + (buffer-reset! buffer) + (set-buffer-read-only! buffer) + (set-buffer-major-mode! buffer mode) + (add-kill-buffer-hook buffer kill-browser-buffer) + (let ((browser + (%make-browser buffer + object + name + (vector) + #f + '() + (make-1d-table)))) + (buffer-put! buffer 'BROWSER browser) + browser))) + +(define (kill-browser-buffer buffer) + (let ((browser (buffer-get buffer 'BROWSER))) + (if browser + (for-each kill-buffer (browser/buffers browser))))) + +(define (buffer-browser buffer) + (let ((browser (buffer-get buffer 'BROWSER))) + (if (not browser) + (error "This buffer has no associated browser:" buffer)) + browser)) + +(define (browser/new-buffer browser initializer) + (let ((buffer + (create-buffer + (let ((prefix (browser/name browser))) + (let loop ((index 1)) + (let ((name + (string-append " " + prefix + "-" + (number->string index)))) + (if (find-buffer name) + (loop (+ index 1)) + name))))))) + (if initializer + (initializer buffer)) + (enable-group-undo! (buffer-group buffer)) + (add-browser-buffer! browser buffer) + buffer)) + +(define (add-browser-buffer! browser buffer) + (add-rename-buffer-hook + buffer + (letrec + ((hook + (lambda (buffer name) + name + (set-browser/buffers! browser + (delq! buffer (browser/buffers browser))) + (remove-rename-buffer-hook buffer hook)))) + hook)) + (add-kill-buffer-hook + buffer + (lambda (buffer) + (set-browser/buffers! browser + (delq! buffer (browser/buffers browser))))) + (set-browser/buffers! browser (cons buffer (browser/buffers browser))) + (buffer-put! buffer 'ASSOCIATED-WITH-BROWSER browser)) + +(define (browser/new-screen browser) + (let ((pair (1d-table/get (browser/properties browser) 'NEW-SCREEN #f))) + (and pair + (let ((screen (weak-car pair))) + (and (screen? screen) + screen))))) + +(define (set-browser/new-screen! browser screen) + (1d-table/put! (browser/properties browser) + 'NEW-SCREEN + (weak-cons screen #f))) + +;;;; Browser Commands + +(define-command browser-select-line + "Select the current browser line." + "d" + (lambda (point) + (let ((bline (mark->bline point))) + (if (not bline) + (editor-error "Nothing to select on this line.")) + (select-bline bline)))) + +;;; If the mouse clicks on a bline, select it. +(define-command debugger-mouse-select-bline + "Select a bline when mouse clicked there." + () + (lambda () + ((ref-command mouse-set-point)) + (let ((bline (mark->bline (current-point)))) + (if bline + (select-bline bline))))) + +(define-command browser-next-line + "Move down to the next line." + "p" + (lambda (argument) + (let* ((browser (buffer-browser (current-buffer))) + (bline + (letrec + ((loop + (lambda (index argument) + (let ((bline (browser/line browser index))) + (cond ((bline/continuation? bline) + (replace-continuation-bline bline) + (loop index argument)) + ((= argument 0) + bline) + ((> argument 0) + (let ((index (+ index 1))) + (if (< index (browser/n-lines browser)) + (loop index (- argument 1)) + (begin + (select-bline bline) + #f)))) + (else + (let ((index (- index 1))) + (if (<= 0 index) + (loop index (+ argument 1)) + (begin + (select-bline bline) + #f))))))))) + (let ((point (current-point))) + (let ((index (mark->bline-index point))) + (cond (index + (loop index argument)) + ((= argument 0) + #f) + (else + (let ((n (if (< argument 0) -1 1))) + (let find-next ((mark point)) + (let ((mark (line-start mark n #f))) + (and mark + (let ((index (mark->bline-index mark))) + (if index + (loop index (- argument n)) + (find-next mark)))))))))))))) + (cond (bline + (select-bline bline)) + ((= argument 0) + (editor-failure "Nothing to select on this line.")) + (else + (editor-failure)))))) + +(define-command browser-previous-line + "Move up to the previous line." + "p" + (lambda (argument) + ((ref-command browser-next-line) (- argument)))) + +(define (select-bline bline) + (let ((bline + (if (bline/continuation? bline) + (replace-continuation-bline bline) + bline))) + (let ((browser (bline/browser bline))) + (unselect-bline browser) + (let ((mark (bline/start-mark bline))) + (with-buffer-open mark + (lambda () + (insert-char #\> (mark1+ mark)) + (delete-right-char mark) + (highlight-the-number mark))) + (set-browser/selected-line! browser bline) + (set-buffer-point! (mark-buffer mark) mark))) + (let ((buffer (bline/description-buffer bline))) + (if buffer + (pop-up-buffer buffer #f))))) + +(define (highlight-the-number mark) + (let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0)))) + (highlight-region (make-region mark + (if (mark? end) + (mark- end 1) + (line-end mark 0))) + (highlight-face)))) + +(define (unselect-bline browser) + (let ((bline (browser/selected-line browser))) + (if bline + (let ((mark (bline/start-mark bline))) + (with-buffer-open mark + (lambda () + (dehigh-between mark (line-end mark 0)) + (insert-char #\space (mark1+ mark)) + (delete-right-char mark))))))) + +;;; For any frame with an environment (excluding the mark frame) an +;;; inferior repl is started below the other descriptions. + +(define (bline/description-buffer bline) + (let* ((system? + (and (subproblem? (bline/object bline)) + (system-frame? (subproblem/stack-frame (bline/object bline))))) + (buffer + (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f)) + (get-environment + (1d-table/get (bline-type/properties (bline/type bline)) + 'GET-ENVIRONMENT + #f)) + (env-exists? (if (and get-environment (not system?)) + (let ((environment* (get-environment bline))) + (environment? environment*)) + #f)) + (environment (if env-exists? (get-environment bline) #f))) + (if (and buffer (buffer-alive? buffer)) + buffer + (let ((write-description + (bline-type/write-description (bline/type bline)))) + ((message-wrapper #t "Computing, please wait") + (lambda () + (and write-description + (let ((buffer (browser/new-buffer (bline/browser bline) #f))) + (call-with-output-mark (buffer-start buffer) + (lambda (port) + (write-description bline port) + (if env-exists? + (begin + (debugger-newline port) + (write-string evaluation-line-marker port) + (debugger-newline port))))) + (set-buffer-point! buffer (buffer-start buffer)) + (1d-table/put! (bline/properties bline) + 'DESCRIPTION-BUFFER + buffer) + (read-only-between (buffer-start buffer) + (buffer-end buffer)) + (buffer-not-modified! buffer) + (if env-exists? + (start-inferior-repl! buffer environment #f)) + buffer)))))))) + +(define evaluation-line-marker + ";EVALUATION may occur below in the environment of the selected frame.") + +(define-command browser-quit + "Exit the current browser, deleting its buffer." + () + (lambda () + (let ((buffer (current-buffer))) + (let ((browser (buffer-browser buffer)) + (screen (selected-screen))) + ;; Delete all windows that are currently showing buffers that + ;; are associated with this browser. + (let ((window (screen-selected-window screen)) + (buffers (browser/buffers browser))) + (for-each (lambda (window*) + (if (and (not (eq? window* window)) + (not (typein-window? window*)) + (memq (window-buffer window*) buffers)) + (window-delete! window*))) + (screen-window-list screen))) + ;; If the browser was popped up in a new screen, and that + ;; screen is the current screen, delete it too. + (let ((new-screen (browser/new-screen browser))) + (if (and (eq? new-screen screen) + (other-screen screen 1 #t)) + (delete-screen! screen)))) + ;; Kill the buffer, then maybe select another browser. + (let ((browser (get-buffer-browser buffer 'ASSOCIATED-WITH-BROWSER))) + (kill-buffer-interactive buffer) + (let ((browser + (or browser + (let ((buffer (current-buffer))) + (or (get-buffer-browser buffer 'BROWSER) + (get-buffer-browser buffer + 'ASSOCIATED-WITH-BROWSER)))))) + (if browser + (let ((buffer (browser/buffer browser))) + (select-buffer buffer) + ((ref-command browser-select-line) (buffer-point buffer)))))) + (clear-current-message!) + (maybe-restart-buffer-thread buffer)))) + +(define (get-buffer-browser buffer key) + (let ((browser (buffer-get buffer key))) + (and (browser? browser) + (buffer-alive? (browser/buffer browser)) + browser))) + +(define (maybe-restart-buffer-thread buffer) + (let ((cont (maybe-get-continuation buffer)) + (thread (buffer-get buffer 'THREAD))) + (if (and thread cont) + (if (eq? thread editor-thread) + (signal-thread-event editor-thread (lambda () (cont unspecific))) + (restart-thread thread #f #f))))) + +;;;addition for when debugger is called from a break +;;;should quit the debugger, and give the continuation +;;;a value to proceed with (restarting that thread) +;;;if in a normal error debug it will envoke the standard +;;;restarts +(define-command quit-with-restart-value + "Quit the breakpoint, exiting with a specified value." + () + (lambda () + (let* ((buffer (current-buffer)) + (thread (buffer-get buffer 'THREAD))) + (if (thread? thread) + (let ((value (prompt-for-expression-value + "Please enter a value to continue with")) + (cont (maybe-get-continuation buffer))) + (buffer-remove! buffer 'THREAD) + ((ref-command browser-quit)) + (cond ((eq? thread editor-thread) + (signal-thread-event editor-thread (lambda () + (cont value)))) + (else + (set! value? #t) + (restart-thread thread #t (lambda () + (cont value)))))) + (invoke-restarts #f))))) + +(define (maybe-get-continuation buffer) + (let ((object (browser/object (buffer-get buffer 'BROWSER)))) + (and (continuation? object) + object))) + +;;;Method for invoking the standard restarts from within the +;;;debugger. +(define (invoke-restarts avoid-deletion?) + (let* ((mark (current-point)) + (bline (mark->bline mark)) + (browser (bline/browser bline)) + (buffer + (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f)) + (condition + (browser/object browser))) + (if (condition? condition) + (fluid-let ((prompt-for-confirmation + (lambda (prompt #!optional port) + port + (call-with-interface-port (buffer-end buffer) + (lambda (port) + port + (prompt-for-yes-or-no? prompt))))) + (prompt-for-evaluated-expression + (lambda (prompt #!optional environment port) + port + (call-with-interface-port (buffer-end buffer) + (lambda (port) + port + (repl-eval (prompt-for-expression prompt) + environment))))) + (hook/invoke-restart + (lambda (continuation arguments) + (invoke-continuation continuation + arguments + avoid-deletion?)))) + (call-with-interface-port + (let ((buff (new-buffer " *debug*-RESTARTS"))) + (add-browser-buffer! browser buff) + (pop-up-buffer buff #f) + (buffer-start buff)) + (lambda (port) + (write-string " " port) + (write-condition-report condition port) + (debugger-newline port) + (command/condition-restart + (make-initial-dstate condition) + port)))) + (message "No condition to restart from.")))) + +(define (call-with-interface-port mark receiver) + (let ((mark (mark-left-inserting-copy mark))) + (let ((value (receiver (make-port interface-port-type mark)))) + (mark-temporary! mark) + value))) + +(define interface-port-type + (make-port-type + `((write-char + ,(lambda (port char) + (guarantee 8-bit-char? char) + (region-insert-char! (port/state port) char) + 1)) + (prompt-for-confirmation + ,(lambda (port prompt) + (declare (ignore port)) + (prompt-for-confirmation? prompt))) + (prompt-for-expression + ,(lambda (port prompt) + (declare (ignore port)) + (prompt-for-expression prompt)))) + #f)) + +(define (invoke-continuation continuation arguments avoid-deletion?) + (let ((buffer (current-buffer))) + (if (and (not avoid-deletion?) + (ref-variable debugger-quit-on-return?)) + ((ref-command browser-quit))) + ((or (buffer-get buffer 'INVOKE-CONTINUATION) apply) + continuation arguments))) + +;;;; Where + +(define-command browser-where + "Select an environment browser for this line's environment." + () + (lambda () + (select-buffer + (bline/environment-browser-buffer (current-selected-line))))) + +(define (bline/environment-browser-buffer bline) + (let ((environment (bline/evaluation-environment bline))) + (bline/attached-buffer bline 'ENVIRONMENT-BROWSER + (lambda () + (or (find (lambda (buffer) + (let ((browser (buffer-get buffer 'BROWSER))) + (and browser (eq? environment (browser/object browser))))) + (buffer-list)) + (environment-browser-buffer environment)))))) + +(define (bline/attached-buffer bline type make-buffer) + (let ((buffer (1d-table/get (bline/properties bline) type #f))) + (if (and buffer (buffer-alive? buffer)) + buffer + (let ((buffer (make-buffer))) + (1d-table/put! (bline/properties bline) type buffer) + (add-browser-buffer! (bline/browser bline) buffer) + buffer)))) + +(define (current-selected-line) + (let ((bline (browser/selected-line (buffer-browser (current-buffer))))) + (if (not bline) + (editor-error "There is no selected line; please select one.")) + bline)) + +(define (bline/evaluation-environment bline) + (let ((get-environment + (1d-table/get (bline-type/properties (bline/type bline)) + 'GET-ENVIRONMENT + #f)) + (lose + (lambda () (editor-error "The selected line has no environment.")))) + (if get-environment + (let ((environment (get-environment bline))) + (if (environment? environment) + environment + (lose))) + (lose)))) + +;;;; Browser Lines + +(define-record-type + (%make-bline start-mark object type parent depth next prev offset + properties) + bline? + + ;; Index of this bline within browser lines vector. #F if line is + ;; invisible. + (index bline/index set-bline/index!) + + ;; Line start within browser buffer. #F if line is invisible. + (start-mark bline/start-mark set-bline/start-mark!) + + ;; Object that this line represents. + (object bline/object) + + ;; Type of OBJECT. This type is specific to the browser; it tells + ;; the browser how to manipulate OBJECT. + (type bline/type) + + ;; BLINE representing the object that this object is a component of, + ;; or #F if none. + (parent bline/parent) + + ;; Nonnegative integer indicating the depth of this object in the + ;; component nesting. + (depth bline/depth) + + ;; BLINEs representing the objects that are adjacent to this one in + ;; the component ordering, or #F if none. + (next bline/next set-bline/next!) + (prev bline/prev) + + ;; Nonnegative integer indicating the position of this object in the + ;; component ordering. + (offset bline/offset) + + (properties bline/properties)) + +(define (make-bline object type parent prev) + (let ((bline + (%make-bline #f + object + type + parent + (if parent (+ (bline/depth parent) 1) 0) + #f + prev + (if prev (+ (bline/offset prev) 1) 0) + (make-1d-table)))) + (if prev + (set-bline/next! prev bline)) + bline)) + +(define (bline/browser bline) + (buffer-browser (mark-buffer (bline/start-mark bline)))) + +;;;; Browser Line Editing + +(define (browser/n-lines browser) + (vector-length (browser/lines browser))) + +(define (browser/line browser index) + (vector-ref (browser/lines browser) index)) + +(define (mark->bline mark) + (let ((blines (browser/lines (buffer-browser (mark-buffer mark)))) + (group (mark-group mark)) + (index (mark-index mark))) + (let loop ((low 0) (high (vector-length blines))) + (and (fix:< low high) + (let ((middle (fix:quotient (fix:+ low high) 2))) + (let ((bline (vector-ref blines middle))) + (let ((ls (mark-index (bline/start-mark bline)))) + (cond ((fix:< index ls) (loop low middle)) + ((fix:<= index (line-end-index group ls)) bline) + (else (loop (fix:+ middle 1) high)))))))))) + +(define (mark->bline-index mark) + (let ((bline (mark->bline mark))) + (and bline + (bline/index bline)))) + +(define (delete-blines browser start end) + (if (< start end) + (let ((bv (browser/lines browser))) + (if (subvector-find-next-element bv start end + (browser/selected-line browser)) + (unselect-bline browser)) + (let ((nbv (vector-length bv))) + (let ((bv* (make-vector (- nbv (- end start))))) + (do ((i 0 (+ i 1))) + ((= i start)) + (vector-set! bv* i (vector-ref bv i))) + (do ((i end (+ i 1)) + (j start (+ j 1))) + ((= i nbv)) + (let ((bline (vector-ref bv i))) + (set-bline/index! bline j) + (vector-set! bv* j bline))) + (let ((start-mark (bline/start-mark (vector-ref bv start)))) + (with-buffer-open start-mark + (lambda () + (delete-string + start-mark + (if (< end nbv) + (bline/start-mark (vector-ref bv end)) + (buffer-end (browser/buffer browser))))))) + (set-browser/lines! browser bv*)))))) + +(define (insert-blines browser index blines) + (if (not (null? blines)) + (let ((bv (browser/lines browser)) + (n-blines (length blines))) + (let ((nbv (vector-length bv))) + (let ((bv* (make-vector (+ nbv n-blines)))) + (do ((i 0 (+ i 1))) + ((= i index)) + (vector-set! bv* i (vector-ref bv i))) + (do ((blines blines (cdr blines)) + (i index (+ i 1))) + ((null? blines)) + (let ((bline (car blines))) + (set-bline/index! bline i) + (vector-set! bv* i bline))) + (do ((i index (+ i 1)) + (j (+ index n-blines) (+ j 1))) + ((= i nbv)) + (let ((bline (vector-ref bv i))) + (set-bline/index! bline j) + (vector-set! bv* j bline))) + (let ((start-mark + (if (< index nbv) + (bline/start-mark (vector-ref bv index)) + (buffer-end (browser/buffer browser))))) + (with-buffer-open start-mark + (lambda () + (let ((mark (mark-left-inserting-copy start-mark)) + (columns 79)) + (for-each + (lambda (bline) + (let ((index (mark-index mark)) + (indentation + (+ 1 + (* summary-indentation-increment + (bline/depth bline))))) + (insert-horizontal-space indentation mark) + (let ((summary + (call-with-truncated-output-string + (max summary-minimum-columns + (- columns indentation 4)) + (lambda (port) + (parameterize ((current-output-port port)) + ((bline-type/write-summary + (bline/type bline)) + bline + (current-output-port))))))) + (insert-string (cdr summary) mark) + (if (car summary) + (insert-string " ..." mark))) + (insert-newline mark) + (set-bline/start-mark! + bline + (make-permanent-mark (mark-group mark) index #t)))) + blines) + (mark-temporary! mark))))) + (set-browser/lines! browser bv*)))))) + +(define summary-indentation-increment 3) +(define summary-minimum-columns 10) + +;;;; Browser Line Types + +(define-record-type + (%make-bline-type write-summary write-description selection-mark + properties) + bline-type? + + ;; Procedure that is called to generate the browser line that + ;; represents this object. Two arguments: BLINE and PORT. The + ;; summary of BLINE is written to PORT. The summary should fit on + ;; one line; PORT will limit the number of characters that can be + ;; printed so that it fits. + (write-summary bline-type/write-summary) + + ;; Procedure that is called to generate a full description of the + ;; object. Two arguments: BLINE and PORT. This description may use + ;; multiple lines; it will be presented in its own buffer, so the + ;; presentation style is not very constrained. This component may + ;; be #F to indicate that the object is not normally viewed. + (write-description bline-type/write-description) + + ;; Procedure that generates the standard mark at which the point + ;; should be placed when this object is selected. One argument: + ;; BLINE. This component may be a nonnegative exact integer meaning + ;; an offset from the START-MARK of the bline. + (selection-mark bline-type/selection-mark) + + (properties bline-type/properties)) + +(define (make-bline-type write-summary write-description selection-mark) + (%make-bline-type write-summary + write-description + selection-mark + (make-1d-table))) + +(define (make-continuation-bline expander parent prev) + (make-bline expander bline-type:continuation-line parent prev)) + +(define (continuation-line/write-summary bline port) + bline + (write-string "--more--" port)) + +(define bline-type:continuation-line + (make-bline-type continuation-line/write-summary #f 0)) + +(define (bline/continuation? bline) + (eq? (bline/type bline) bline-type:continuation-line)) + +(define (replace-continuation-bline bline) + (let ((browser (bline/browser bline)) + (index (bline/index bline)) + (expansion ((bline/object bline)))) + (delete-blines browser index (+ index 1)) + (insert-blines browser index expansion) + (car expansion))) + +;;;; Control Variables + +(define (boolean-or-ask? object) + (or (boolean? object) + (eq? 'ASK object))) + +(define-variable debugger-one-at-a-time? + "Allow only one debugger buffer to exist at a given time. +#T means delete an existing debugger buffer before making a new one. +#F means leave existing buffers alone. +'ASK means ask user what to do each time." + 'ASK + boolean-or-ask?) + +(define-variable debugger-max-subproblems + "Maximum number of subproblems displayed when debugger starts. +Set this variable to #F to disable this limit." + 10 + (lambda (object) + (or (not object) + (and (exact-integer? object) + (> object 0))))) + +(define-variable debugger-confirm-return? + "True means prompt for confirmation in \"return\" commands. +The prompting occurs prior to returning the value." + #t + boolean?) + +(define-variable debugger-quit-on-return? + "True means quit debugger when executing a \"return\" command. +Quitting the debugger kills the debugger buffer and any associated buffers." + #t + boolean?) + +(define-variable debugger-quit-on-restart? + "True means quit debugger when executing a \"restart\" command. +Quitting the debugger kills the debugger buffer and any associated buffers." + #t + boolean?) + +;;; Limited this because the bindings are now pretty-printed. + +(define-variable environment-package-limit + "Packages with more than this number of bindings will be abbreviated. +Set this variable to #F to disable this abbreviation." + 10 + (lambda (object) + (or (not object) + (exact-nonnegative-integer? object)))) + +(define-variable debugger-show-help-message? + "True means show the help message, false means don't." + #T + boolean?) + +(define-variable debugger-start-new-frame? + "#T means create a new frame whenever the debugger is invoked. +#F means continue in same frame. +'ASK means ask user." + #T + boolean-or-ask?) +(define edwin-variable$debugger-start-new-screen? + edwin-variable$debugger-start-new-frame?) + +(define-variable debugger-hide-system-code? + "True means don't show subproblems created by the runtime system." + #T + boolean?) + +(define-variable debugger-show-frames? + "If true show the environment frames in the description buffer. +If false show the bindings without frames." + #T + boolean?) + +(define-variable debugger-show-inner-frame-topmost? + "Affects the debugger display when DEBUGGER-SHOW-FRAMES? is true. +If false, frames are displayed with the outer (most global) frame topmost, +like in a 6.001 style environment diagram. This is the default. +If true, frames are display innermost first." + #F + boolean?) + +(define-variable debugger-compact-display? + "If true, the debugger omits some blank lines. +If false, more blank lines are produced between display elements. +This variable is usually set to #F, but setting it to #T is useful +to get more information in a short window, for example, when using +a fixed size terminal." + #F + boolean?) + +;;; These bindings are included only because they are exported by the +;;; alternate debugger, artdebug, which also lives in this package. +;;; They appear to CREF to be needed yet not bound. + +(define edwin-variable$debugger-expand-reductions?) +(define edwin-variable$debugger-open-markers?) +(define edwin-variable$debugger-split-window?) +(define edwin-variable$debugger-verbose-mode?) + +;;;; Predicates + +;;; Determines if a frame is marked. + +(define (system-frame? stack-frame) + (stack-frame/repl-eval-boundary? stack-frame)) + +;;; Bad implementation to determine for breaks if a value to proceed +;;; with is desired. + +(define value? #f) + +(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))) + +;;;; Help Messages + +;;; The help messages for the debugger + +(define where-help-message +" COMMANDS: ? - Help q - Quit environment browser + +This is an environment-browser buffer. + +Lines identify environment frames. +The buffer below shows the bindings of the selected environment. +-----------") + +(define debugger-help-message +" COMMANDS: ? - Help q - Quit debugger e - Environment browser + +This is a debugger buffer. + +Lines identify stack frames, most recent first. + + Sx means frame is in subproblem number x. + Ry means frame is reduction number y. + +The buffer below shows the current subproblem or reduction. +-----------") + +;;;; Debugger entry point + +(define starting-debugger? #f) + +(define (debug-scheme-error error-type condition ask?) + (if starting-debugger? + (quit-editor-and-signal-error condition) + (begin + (let ((start-debugger + (lambda () + (fluid-let ((starting-debugger? #t)) + (select-continuation-browser-buffer condition))))) + (if ask? + (if (cleanup-pop-up-buffers + (lambda () + (standard-error-report error-type condition #t) + (editor-beep) + (prompt-for-confirmation? "Start debugger"))) + (start-debugger)) + (begin + (start-debugger) + (message (string-capitalize (symbol->string error-type)) + " error") + (editor-beep)))) + (return-to-command-loop condition)))) + +(define (select-continuation-browser-buffer object #!optional thread) + (set! value? #f) + (let ((buffers (find-debugger-buffers))) + (if (and (pair? buffers) + (null? (cdr buffers)) + (if (eq? 'ASK (ref-variable debugger-one-at-a-time? #f)) + (prompt-for-confirmation? + "Another debugger buffer exists. Delete it") + (ref-variable debugger-one-at-a-time? #f))) + (kill-buffer (car buffers)))) + (let ((buffer (continuation-browser-buffer object))) + (let ((thread (and (not (default-object? thread)) thread))) + (if thread + (buffer-put! buffer 'THREAD thread))) + (let ((screen (make-debug-screen buffer))) + (if screen + (select-screen screen) + (select-buffer buffer))) + ((ref-command browser-select-line) (buffer-point buffer)))) + +(define-command browse-continuation + "Invoke the continuation-browser on CONTINUATION." + "XBrowse Continuation" + select-continuation-browser-buffer) + +(define (make-debug-screen buffer) + (and (multiple-screens?) + (let ((new-screen? (ref-variable debugger-start-new-screen? buffer))) + (if (eq? new-screen? 'ASK) + (prompt-for-confirmation? "Start debugger in new screen") + new-screen?)) + (let ((screen (apply make-screen buffer (make-debug-screen-args)))) + (set-browser/new-screen! (buffer-browser buffer) screen) + screen))) + +(define (make-debug-screen-args) + (case (display-type/name (current-display-type)) + ((X) + (cond ((string? default-screen-geometry) + (list default-screen-geometry)) + ((eq? default-screen-geometry 'ASK) + (let ((geometry + (let loop ((default default-screen-geometry)) + (let ((geometry + (prompt-for-string "Please enter a geometry" + default))) + (if (geometry? geometry) + geometry + (loop geometry)))))) + (set! default-screen-geometry geometry) + geometry)) + (else '()))) + (else '()))) + +(define (geometry? geometry) + (let ((geometry-pattern + "[0-9]+x[0-9]+\\(-[0-9]+\\|+[0-9]+\\|\\)\\(-[0-9]+\\|+[0-9]+\\|\\)")) + (re-string-match (re-compile-pattern geometry-pattern #f) geometry))) + +(define default-screen-geometry #f) + +(define (continuation-browser-buffer object) + (let ((browser + (make-browser "*debug*" + (ref-mode-object continuation-browser) + object)) + (blines + (continuation->blines + (cond ((continuation? object) + object) + ((condition? object) + (condition/continuation object)) + (else + (error:wrong-type-argument object + "condition or continuation" + 'CONTINUATION-BROWSER-BUFFER))) + (ref-variable debugger-max-subproblems)))) + (let ((buffer (browser/buffer browser))) + (let ((mark (buffer-end buffer))) + (with-buffer-open mark + (lambda () + (call-with-output-mark mark + (lambda (port) + (if (ref-variable debugger-show-help-message?) + (write-string debugger-help-message port)) + (debugger-newline port) + (if (condition? object) + (begin + (write-string "The " port) + (write-string (if (condition/error? object) + "error" + "condition") + port) + (write-string " that started the debugger is:" port) + (debugger-newline port) + (debugger-newline port) + (write-string " " port) + (with-output-highlighted port + (lambda () + (write-condition-report object port))) + (debugger-newline port))) + (debugger-newline port)))))) + (insert-blines browser 0 blines) + (set-buffer-point! buffer + (if (null? blines) + (buffer-end buffer) + (bline/start-mark (car blines)))) + buffer))) + +(define (find-debugger-buffers) + (filter (let ((debugger-mode (ref-mode-object continuation-browser))) + (lambda (buffer) + (eq? (buffer-major-mode buffer) debugger-mode))) + (buffer-list))) + +;;;; Continuation Browser Mode + +(define-major-mode continuation-browser read-only "Debug" + " ******* Debugger Help ******* + +Commands: + +`mouse-button-1' + Select a subproblem or reduction and display information in the + description buffer. + +`C-n' +`down-arrow' + Move the cursor down the list of subproblems and reductions and + display info in the description buffer. + +`C-p' +`up-arrow' + Move the cursor up the list of subproblems and reductions and + display info in the description buffer. + +`e' Show the environment structure. + +`q' Quit the debugger, destroying its window. + +`p' Invoke the standard restarts. + +`SPC' + Display info on current item in the description buffer. + +`?' Display help information. + + Each line beginning with `S' represents either a subproblem or stack +frame. A subproblem line may be followed by one or more indented lines +\(beginning with the letter `R') which represent reductions associated +with that subproblem. The subproblems are indexed with the natural +numbers. To obtain a more complete description of a subproblem or +reduction, click the mouse on the desired line or move the cursor to the +line using the arrow keys (or `C-n' and `C-p'). The description buffer +will display the additional information. + + The description buffer contains three major regions. The first +region contains a pretty printed version of the current expression. The +current subproblem within the expression is highlighted. The second +region contains a representation of the frames of the environment of the +current expression. The bindings of each frame are listed below the +frame header. If there are no bindings in the frame, none will be +listed. The frame of the current expression is preceeded with ==>. + + The bottom of the description buffer contains a region for evaluating +expressions in the environment of the selected subproblem or reduction. +This is the only portion of the buffer where editing is possible. This +region can be used to find the values of variables in different +environments; you cannot, however, use mutators (set!, etc.) on compiled +code. + + Typing `e' creates a new buffer in which you may browse through the +current environment. In this new buffer, you can use the mouse, the +arrows, or `C-n' and `C-p' to select lines and view different +environments. The environments listed are the same as those in the +description buffer. If the selected environment structure is too large +to display (if there are more than `environment-package-limit' items in +the environment) an appropriate message is displayed. To display the +environment in this case, set the `environment-package-limit' variable +to `#f'. This process is initiated by the command `M-x set-variable'. +You can not use `set!' to set the variable because it is an editor +variable and does not exist in the current scheme environment. At the +bottom of the new buffer is a region for evaluating expressions similar +to that of the description buffer. + + The appearance of environment displays is controlled by the editor +variables `debugger-show-inner-frame-topmost?' and `debugger-compact-display?' +which affect the ordering of environment frames and the line spacing +respectively. + + Type `q' to quit the debugger, killing its primary buffer and any +others that it has created. + + NOTE: The debugger creates discription buffers in which debugging +information is presented. These buffers are given names beginning with +spaces so that they do not appear in the buffer list; they are +automatically deleted when you quit the debugger. If you wish to keep +one of these buffers, simply rename it using `M-x rename-buffer': once +it has been renamed, it will not be deleted automatically.") + +(define-key 'continuation-browser #\p 'quit-with-restart-value) +(define-key 'continuation-browser down 'browser-next-line) +(define-key 'continuation-browser up 'browser-previous-line) +(define-key 'continuation-browser button1-down 'debugger-mouse-select-bline) +(define-key 'continuation-browser #\c-n 'browser-next-line) +(define-key 'continuation-browser #\c-p 'browser-previous-line) +(define-key 'continuation-browser #\? 'describe-mode) +(define-key 'continuation-browser #\q 'browser-quit) +(define-key 'continuation-browser #\space 'browser-select-line) +(define-key 'continuation-browser #\e 'browser-where) + +;;;; Subproblems + +;; A continuation consists of subproblems. A subproblem has +;; expression information that identifies what the subproblem means. +;; It additionally has reductions and an environment. Similarly, +;; reductions have expression and environment information. +;; Environments consist of environment frames, and each frame consists +;; of bindings. Subproblems, reductions, and environment frames are +;; ordered; bindings are not. + +;;; Stops displaying subproblems past marked frame by default. + +(define (continuation->blines continuation limit) + (let ((beyond-system-code #f)) + (let loop ((frame (continuation/first-subproblem continuation)) + (prev #f) + (n 0)) + (if (not frame) + '() + (let* ((next-subproblem + (lambda (bline) + (loop (stack-frame/next-subproblem frame) + bline + (+ n 1)))) + (walk-reductions + (lambda (bline reductions) + (cons bline + (let loop ((reductions reductions) (prev #f)) + (if (null? reductions) + (next-subproblem bline) + (let ((bline + (make-bline (car reductions) + bline-type:reduction + bline + prev))) + (cons bline + (loop (cdr reductions) bline)))))))) + (continue + (lambda () + (let* ((subproblem (stack-frame->subproblem frame n))) + (if debugger:student-walk? + (let ((reductions + (subproblem/reductions subproblem))) + (if (null? reductions) + (let ((bline + (make-bline subproblem + bline-type:subproblem + #f + prev))) + (cons bline + (next-subproblem bline))) + (let ((bline + (make-bline (car reductions) + bline-type:reduction + #f + prev))) + (walk-reductions bline + (if (> n 0) + '() + (cdr reductions)))))) + (walk-reductions + (make-bline subproblem + bline-type:subproblem + #f + prev) + (subproblem/reductions subproblem))))))) + (cond ((and (not (ref-variable debugger-hide-system-code?)) + (system-frame? frame)) + (loop (stack-frame/next-subproblem frame) + prev + n)) + ((or (and limit (>= n limit)) + (if (system-frame? frame) + (begin (set! beyond-system-code #t) #t) + #f) + beyond-system-code) + (list (make-continuation-bline continue #f prev))) + (else (continue)))))))) + +(define-record-type + (make-subproblem stack-frame expression environment subexpression number) + subproblem? + (stack-frame subproblem/stack-frame) + (expression subproblem/expression) + (environment subproblem/environment) + (subexpression subproblem/subexpression) + (number subproblem/number)) + +(define (stack-frame->subproblem frame number) + (receive (expression environment subexpression) + (stack-frame/debugging-info frame) + (make-subproblem frame expression environment subexpression number))) + +(define-record-type + (make-reduction subproblem expression environment number) + reduction? + (subproblem reduction/subproblem) + (expression reduction/expression) + (environment reduction/environment) + (number reduction/number)) + +(define (subproblem/reductions subproblem) + (let ((frame (subproblem/stack-frame subproblem))) + (let loop ((reductions (stack-frame/reductions frame)) (n 0)) + (if (pair? reductions) + (cons (make-reduction subproblem + (caar reductions) + (cadar reductions) + n) + (loop (cdr reductions) (+ n 1))) + '())))) + +(define (subproblem/write-summary bline port) + (let* ((subproblem (bline/object bline)) + (frame (subproblem/stack-frame subproblem))) + (if (system-frame? frame) + (write-string "***************Internal System Code Follows***********" + port) + (begin + (write-string "S" port) + (write-string (bline/offset-string (subproblem/number subproblem)) + port) + (write-string " " port) + (let ((expression (subproblem/expression subproblem)) + (subexpression (subproblem/subexpression subproblem))) + (cond ((debugging-info/compiled-code? expression) + (write-string ";unknown compiled code" port)) + ((not (debugging-info/undefined-expression? expression)) + (parameterize ((param:print-primitives-by-name? #t)) + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression))))) + ((debugging-info/noise? expression) + (write-string ";" port) + (write-string ((debugging-info/noise expression) #f) + port)) + (else + (write-string ";undefined expression" port)))))))) + +(define (subproblem/write-description bline port) + (let* ((subproblem (bline/object bline)) + (frame (subproblem/stack-frame subproblem))) + (cond ((system-frame? frame) + (write-string "The subproblems which follow are part of the " port) + + (write-string "internal system workings." port)) + (else + (write-string " SUBPROBLEM LEVEL: " port) + (write (subproblem/number subproblem) port) + (debugger-newline port) + (debugger-newline port) + (let ((expression (subproblem/expression subproblem)) + (frame (subproblem/stack-frame subproblem))) + (cond ((not (invalid-expression? expression)) + (write-string (if (stack-frame/compiled-code? frame) + "COMPILED expression" + "Expression") + port) + (write-string " (from stack):" port) + (debugger-newline port) + (write-string + " Subproblem being executed is highlighted.\n" + port) + (debugger-newline port) + (let ((subexpression + (subproblem/subexpression subproblem))) + (if (invalid-subexpression? subexpression) + (debugger-pp expression expression-indentation port) + (debugger-pp-highlight-subexpression + expression + subexpression + expression-indentation + port)))) + ((debugging-info/noise? expression) + (write-string ((debugging-info/noise expression) #t) + port)) + (else + (write-string (if (stack-frame/compiled-code? frame) + "Compiled expression unknown" + "Expression unknown") + port) + (debugger-newline port) + (write (stack-frame/return-address frame) port)))) + (let ((environment (subproblem/environment subproblem))) + (if (not (debugging-info/undefined-environment? environment)) + (begin + (debugger-newline port) + (debugger-newline port) + (desc-show-environment-name-and-bindings environment + port)))))))) + +(define bline-type:subproblem + (make-bline-type subproblem/write-summary + subproblem/write-description + 1)) + +(1d-table/put! (bline-type/properties bline-type:subproblem) + 'GET-ENVIRONMENT + (lambda (bline) + (subproblem/environment (bline/object bline)))) + +;;;; Reductions + +(define (reduction/write-summary bline port) + (let ((reduction (bline/object bline))) + (if (bline/parent bline) + (begin + (write-string "R" port) + (write-string (bline/offset-string (reduction/number reduction)) + port)) + (begin + (write-string "S" port) + (write-string + (bline/offset-string + (subproblem/number (reduction/subproblem reduction))) + port))) + (write-string " " port) + (parameterize ((param:print-primitives-by-name? #t)) + (write (unsyntax (reduction/expression reduction)) port)))) + +(define (reduction/write-description bline port) + (let ((reduction (bline/object bline))) + (write-string " SUBPROBLEM LEVEL: " port) + (write (subproblem/number (reduction/subproblem reduction)) port) + (write-string " REDUCTION NUMBER: " port) + (write (reduction/number reduction) port) + (debugger-newline port) + (debugger-newline port) + (write-string "Expression (from execution history):" port) + (debugger-newline port) + (debugger-newline port) + (debugger-pp (reduction/expression reduction) expression-indentation port) + (debugger-newline port) + (debugger-newline port) + (desc-show-environment-name-and-bindings (reduction/environment reduction) + port))) + +(define bline-type:reduction + (make-bline-type reduction/write-summary + reduction/write-description + 1)) + +(1d-table/put! (bline-type/properties bline-type:reduction) + 'GET-ENVIRONMENT + (lambda (bline) + (reduction/environment (bline/object bline)))) + +;;;; Environments + +(define-command browse-environment + "Invoke the environment-browser on ENVIRONMENT." + "XBrowse Environment" + (lambda (environment) + (select-buffer (environment-browser-buffer environment)))) + +;;; Adds a help line. + +(define (environment-browser-buffer object) + (let ((environment (->environment object))) + (let ((browser + (make-browser "*where*" + (ref-mode-object environment-browser) + object)) + (blines (environment->blines environment))) + + (let ((buffer (browser/buffer browser))) + (let ((mark (buffer-end buffer))) + (with-buffer-open mark + (lambda () + (call-with-output-mark + mark + (lambda (port) + (if (ref-variable debugger-show-help-message?) + (write-string where-help-message port)) + (debugger-newline port)))))) + (insert-blines browser 0 blines) + (if (null? blines) + (set-buffer-point! buffer (buffer-end buffer)) + (select-bline (car blines))) + buffer)))) + +(define (environment->blines environment) + (let loop ((environment environment) (prev #f)) + (let ((bline (make-bline environment bline-type:environment #f prev))) + (cons bline + (if (eq? #t (environment-has-parent? environment)) + (loop (environment-parent environment) bline) + '()))))) + +(define-major-mode environment-browser read-only "Environment Browser" + " ********Environment Browser Help******** + +Commands: + +`mouse-button-1' + Select a subproblem or reduction and display information in the + description buffer. + +`C-n' +`down-arrow' + Move the cursor down the list of subproblems and reductions and + display info in the description buffer. + +`C-p' +`up-arrow' + Move the cursor up the list of subproblems and reductions and + display info in the description buffer. + +`q' + Quit the environment browser, destroying its window. + +`SPC' + Display info on current item in the description buffer. + +`?' + Display help information. + + In this buffer, you can use the mouse, the arrows, or `C-n' and +`C-p' to select lines and view different environments. +If the selected environment structure is too large to display (if +there are more than `environment-package-limit' items in the +environment) an appropriate message is displayed. To display the +environment in this case, set the `environment-package-limit' variable +to `#f'. This process is initiated by the command `M-x +set-variable'. You can not use `set!' to set the variable because it +is an editor variable and does not exist in the current scheme +environment. + + The bottom of the description buffer contains a region for evaluating +expressions in the environment of the selected subproblem or reduction. +This is the only portion of the buffer where editing is possible. This +region can be used to find the values of variables in different +environments; you cannot, however, use mutators (set!, etc.) on +compiled code. + + Type `q' to quit the environment browser, killing its primary buffer +and any others that it has created. + +NOTE: The environment browser creates discription buffers in which +debugging information is presented. These buffers are given names +beginning with spaces so that they do not appear in the buffer list; +they are automatically deleted when you quit the debugger. If you wish +to keep one of these buffers, simply rename it using `M-x rename-buffer': +once it has been renamed, it will not be deleted automatically.") + +(define-key 'environment-browser down 'browser-next-line) +(define-key 'environment-browser up 'browser-previous-line) +(define-key 'environment-browser button1-down 'debugger-mouse-select-bline) +(define-key 'environment-browser #\c-n 'browser-next-line) +(define-key 'environment-browser #\c-p 'browser-previous-line) +(define-key 'environment-browser #\? 'describe-mode) +(define-key 'environment-browser #\q 'browser-quit) +(define-key 'environment-browser #\space 'browser-select-line) + +(define (environment/write-summary bline port) + (write-string "E" port) + (write-string (bline/offset-string (bline/offset bline)) port) + (write-string " " port) + (show-environment-name (bline/object bline) port)) + +(define (environment/write-description bline port) + (let ((environment (bline/object bline))) + (show-environment-name-and-bindings environment port))) + +(define (show-environment-name-and-bindings environment port) + (show-environment-name environment port) + (debugger-newline port) + (debugger-newline port) + (let ((names (environment-bound-names environment)) + (package (environment->package environment)) + (finish + (lambda (names) + (debugger-newline port) + (for-each (lambda (name) + (myprint-binding name + (environment-safe-lookup environment + name) + port)) + names)))) + (cond ((null? names) + (write-string " has no bindings" port)) + ((and package + (let ((limit (ref-variable environment-package-limit))) + (and limit + (let ((n (length names))) + (and (>= n limit) + (begin + (write-string " has " port) + (write n port) + (write-string " bindings (first " port) + (write limit port) + (write-string " shown):" port) + (finish (take names limit)) + #t))))))) + (else + (write-string " BINDINGS:" port) + (finish (if package (sort names symbolstring number))) + (if (< (string-length string) offset-string-min) + (string-pad-right string offset-string-min) + string))) + +(define offset-string-min + 2) + +(define (with-buffer-open mark thunk) + (with-read-only-defeated mark thunk) + (buffer-not-modified! (mark-buffer mark))) + +(define (desc-show-environment-name-and-bindings environment port) + (write-string + "---------------------------------------------------------------------" + port) + (if (ref-variable debugger-show-frames?) + (show-frames-and-bindings environment port) + (print-the-local-bindings environment port)) + (debugger-newline port) + (write-string + "---------------------------------------------------------------------" + port)) + +(define (debugger-newline port) + (if (ref-variable debugger-compact-display?) + (fresh-line port) + (newline port))) + +(define (show-frames-and-bindings environment port) + + (define (envs environment) + (cons environment + (if (environment-has-parent? environment) + (envs (environment-parent environment)) + '()))) + + (define (show-frames envs indents) + (for-each (lambda (env indent) + (debugger-newline port) + (if (eq? env environment) + (let* ((pointer "==> ") + (pl (string-length pointer))) + (if (> (string-length indent) pl) + (write-string (string-tail indent pl) port)) + (write-string pointer port)) + (write-string indent port)) + (show-environment-name env port) + (debugger-newline port) + (show-environment-bindings-with-ind env indent port)) + envs indents)) + + (let ((env-list (envs environment))) + (cond ((ref-variable debugger-show-inner-frame-topmost?) + (show-frames env-list (make-list (length env-list) ""))) + (else + (show-frames (reverse env-list) + (make-initialized-list (length env-list) + (lambda (i) (make-string (* i 2) #\space)))))))) + +(define (print-the-local-bindings environment port) + (let ((names (get-all-local-bindings environment))) + (let ((n-bindings (length names)) + (finish + (lambda (names) + (for-each (lambda (name) + (let loop ((env environment)) + (if (environment-bound? env name) + (print-binding-with-ind + name + (environment-safe-lookup env name) + " " + port) + (loop (environment-parent env))))) + names)))) + (debugger-newline port) + (show-environment-name environment port) + (cond ((zero? n-bindings) + (debugger-newline port) + (write-string " has no bindings" port) + (debugger-newline port)) + ((> n-bindings (ref-variable environment-package-limit))) + (else + (debugger-newline port) + (debugger-newline port) + (write-string " Local Bindings:" port) + (debugger-newline port) + (finish names)))))) + +(define (show-environment-name environment port) + (write-string "ENVIRONMENT " port) + (let ((package (environment->package environment))) + (if package + (begin + (write-string "named: " port) + (write (package/name package) port)) + (begin + (write-string "created by " port) + (print-user-friendly-name environment port))))) + +(define (get-all-local-bindings environment) + (define (envs environment) + (if (environment-has-parent? environment) + (cons environment (envs (environment-parent environment))) ; + '())) + (let* ((env-list (envs environment)) + (names1 (map (lambda (envir) + (let ((names (environment-bound-names envir))) + (if (< (length names) + (ref-variable environment-package-limit)) + names + '()))) + env-list)) + (names2 (reduce-right append '() names1)) + (names3 (let loop ((l names2)) + (if (null? l) + l + (cons (car l) (loop (delete (car l) l)))))) + (names4 (sort names3 symbolpackage environment) + (write-string (string-append ind " has ") port) + (write n-bindings port) + (write-string + " bindings" + port) + (debugger-newline port)) + ((zero? n-bindings) + #|(write-string (string-append ind " has no bindings") port) + (debugger-newline port)|#) + ((> n-bindings (ref-variable environment-package-limit)) + (write-string (string-append ind " has ") port) + (write n-bindings port) + (write-string + " bindings (see editor variable environment-package-limit)" + port) + (debugger-newline port)) + (else + (finish names)))))) + +(define (print-binding-with-ind name value ind port) + (let* ((extra " ") + (x-size + (- (output-port/x-size port) + (+ (string-length ind) + (string-length extra))))) + (write-string ind port) + (write-string extra port) + (let ((name + (output-to-string (quotient x-size 2) + (lambda () + (write-dbg-name name (current-output-port)))))) + (write-string name port) + (cond ((unassigned-reference-trap? value) + (write-string " is unassigned" port)) + ((macro-reference-trap? value) + (write-string " is a syntactic keyword" port)) + (else + (let ((separator " = ")) + (write-string separator port) + (write-string + (output-to-string (max 0 + (- (- x-size 1) + (+ (string-length name) + (string-length separator)))) + (lambda () (write value))) + port))))) + (debugger-newline port))) \ No newline at end of file diff --git a/edwin/debuge.scm b/edwin/debuge.scm new file mode 100644 index 0000000..70141c2 --- /dev/null +++ b/edwin/debuge.scm @@ -0,0 +1,177 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Debugging Stuff + +(declare (usual-integrations)) + +(define (debug-save-files) + (for-each debug-save-buffer + (bufferset-buffer-list (editor-bufferset edwin-editor)))) + +(define (debug-save-buffer buffer) + (if (and (buffer-modified? buffer) + (buffer-writeable? buffer) + (not (minibuffer? buffer))) + (let ((pathname + (let ((pathname (buffer-pathname buffer))) + (cond ((not pathname) + (and (y-or-n? "Save buffer " + (buffer-name buffer) + " (Y or N)? ") + ((access prompt-for-expression + system-global-environment) + "Filename"))) + ((integer? (pathname-version pathname)) + (pathname-new-version pathname 'NEWEST)) + (else + pathname))))) + (if pathname + (let* ((pathname (merge-pathnames pathname)) + (filename (->namestring pathname))) + (if (or (not (file-exists? pathname)) + (y-or-n? "File '" + filename + "' exists. Write anyway (Y or N)? ")) + (begin + (newline) + (write-string "Writing file '") + (write-string filename) + (write-string "'") + (let ((region (buffer-unclipped-region buffer))) + (group-write-to-file + (ref-variable translate-file-data-on-output + (region-group region)) + (region-group region) + (region-start-index region) + (region-end-index region) + filename)) + (write-string " -- done") + (set-buffer-pathname! buffer pathname) + (set-buffer-truename! buffer (->truename pathname)) + (buffer-not-modified! buffer)))))))) + +(define-command debug-count-marks + "Show the number of in-use marks for the current buffer." + () + (lambda () + (message "In use: " + (write-to-string + (weak-list-set-size + (group-marks (buffer-group (current-buffer)))))))) + +(define-command debug-show-standard-marks + "" + () + (lambda () + (with-output-to-temporary-buffer "*standard-marks*" '() + (lambda () + (let ((buffer-frame (current-window))) + (let ((window + (vector-ref (instance-ref buffer-frame 'text-inferior) 1)) + (buffer (window-buffer buffer-frame))) + (let ((show-mark + (lambda (name mark) + (write-string + (string-pad-right (write-to-string name) 24)) + (write mark) + (newline)))) + (let ((show-instance + (lambda (name) + (show-mark name (instance-ref window name))))) + (show-instance 'point) + (show-instance 'current-start-mark) + (show-instance 'start-mark) + (show-instance 'start-line-mark) + (show-instance 'current-end-mark)) + (let ((group (buffer-group buffer))) + (show-mark 'group-start-mark (group-start-mark group)) + (show-mark 'group-end-mark (group-end-mark group)) + (show-mark 'group-display-start (group-display-start group)) + (show-mark 'group-display-end (group-display-end group))) + (let ((marks (ring-list (buffer-mark-ring buffer)))) + (if (not (null? marks)) + (begin + (write-string "mark-ring\t\t") + (write (car marks)) + (newline) + (for-each (lambda (mark) + (write-string "\t\t\t") + (write mark) + (newline)) + (cdr marks)))))))))))) + +;;;; Object System Debugging + +(define (instance-ref object name) + (let ((entry (assq name (class-instance-transforms (object-class object))))) + (if (not entry) + (error "Not a valid instance-variable name:" name)) + (vector-ref object (cdr entry)))) + +(define (instance-set! object name value) + (let ((entry (assq name (class-instance-transforms (object-class object))))) + (if (not entry) + (error "Not a valid instance-variable name:" name)) + (vector-set! object (cdr entry) value))) + +;;;; Screen Trace + +(define trace-output '()) + +(define (debug-tracer . args) + (set! trace-output (cons args trace-output)) + unspecific) + +(define (screen-trace #!optional screen) + (let ((screen + (if (default-object? screen) + (begin + (if (not edwin-editor) + (error "No screen to trace.")) + (editor-selected-screen edwin-editor)) + screen))) + (set! trace-output '()) + (for-each (lambda (window) + (set-window-debug-trace! window debug-tracer)) + (screen-window-list screen)) + (set-screen-debug-trace! screen debug-tracer))) + +(define (screen-untrace #!optional screen) + (let ((screen + (if (default-object? screen) + (begin + (if (not edwin-editor) + (error "No screen to trace.")) + (editor-selected-screen edwin-editor)) + screen))) + (for-each (lambda (window) + (set-window-debug-trace! window false)) + (screen-window-list screen)) + (set-screen-debug-trace! screen false) + (let ((result trace-output)) + (set! trace-output '()) + (map list->vector (reverse! result))))) \ No newline at end of file diff --git a/edwin/decls.scm b/edwin/decls.scm new file mode 100644 index 0000000..108127e --- /dev/null +++ b/edwin/decls.scm @@ -0,0 +1,245 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Edwin: Syntaxing Declarations + +(declare (usual-integrations)) + +(let* ((sf-names (lambda (file) (sf/pathname-defaulting file #f #f))) + (scm-file (lambda (file) (receive (scm bin spec) (sf-names file) scm))) + (bin-file (lambda (file) (receive (scm bin spec) (sf-names file) bin))) + (bin-time (lambda (file) (file-modification-time (bin-file file)))) + (sf-dependent + (lambda (environment) + (lambda (source . dependencies) + (let ((reasons + (let ((source-time (bin-time source))) + (append + (receive (scm bin spec) (sf-names source) + (if (file-modification-time<=? scm bin) + '() + (list scm))) + (map bin-file + (if source-time + (filter (lambda (dependency) + (let ((bin-time + (bin-time dependency))) + (or (not bin-time) + (< source-time bin-time)))) + dependencies) + dependencies)))))) + (if (not (null? reasons)) + (begin + #| + (let ((notify + (lambda (port) + (write-string "Processing " port) + (write source port) + (write-string " because of:" port) + (for-each (lambda (reason) + (write-char #\space port) + (write reason port)) + reasons)))) + (if (environment-bound? system-global-environment + 'write-notification-line) + (write-notification-line notify) + (notify (notification-output-port)))) + |# + (fluid-let ((sf/default-syntax-table environment) + (sf/default-declarations + (map (lambda (dependency) + `(integrate-external ,dependency)) + dependencies))) + (sf source)))))))) + (sf-edwin (sf-dependent (->environment '(EDWIN)))) + (sf-class (sf-dependent (->environment '(EDWIN WINDOW))))) + (for-each sf-edwin + '("ansi" + "bios" + "class" + "clscon" + "clsmac" + "comatch" + "display" + "key-w32" + "macros" + "make" + "nntp" + "nvector" + "paths" + "rcsparse" + "rfc822" + "ring" + "string" + "strpad" + "strtab" + "termcap" + "utils" + "win32" + "xform" + "xterm")) + (sf-edwin "tterm" "termcap") + (let ((includes '("struct" "comman" "modes" "buffer" "edtstr"))) + (let loop ((files includes) (includes '())) + (if (pair? files) + (begin + (apply sf-edwin (car files) includes) + (loop (cdr files) (cons (car files) includes))))) + (for-each (lambda (filename) + (apply sf-edwin filename includes)) + '("abbrev" + "adapters" + "argred" + "artdebug" + "autold" + "autosv" + "basic" + ;;"bochser" + ;;"bochsmod" + "bufcom" + "bufinp" + "bufmnu" + "bufout" + "bufset" + "c-mode" + "calias" + "cinden" + "comhst" + "comint" + "compile" + "comtab" + "comred" + "curren" + "dabbrev" + "debian-changelog" + "debug" + "debuge" + "diff" + "dired" + "dirunx" + "dirw32" + "docstr" + "dos" + "doscom" + "dosfile" + "dosproc" + "dosshell" + "ed-ffi" + "editor" + "evlcom" + "eystep" + "filcom" + "fileio" + "fill" + "grpops" + "hlpcom" + "htmlmode" + "image" + "info" + "input" + "intmod" + "iserch" + "javamode" + "keymap" + "keyparse" + "kilcom" + "kmacro" + "lincom" + "linden" + "loadef" + "lspcom" + "malias" + "manual" + "midas" + "modefs" + "modlin" + "motcom" + "motion" + "mousecom" + "notify" + "outline" + "occur" + "paredit" + "pasmod" + "print" + "process" + "prompt" + "pwedit" + "pwparse" + ;;"rcs" + "reccom" + "regcom" + "regexp" + "regops" + "replaz" + "rmail" + "rmailsrt" + "rmailsum" + "schmod" + "scrcom" + "screen" + "search" + "sendmail" + "sercom" + "shell" + "simple" + "snr" + "sort" + "syntax" + "tagutl" + "techinfo" + "telnet" + "texcom" + "things" + "tparse" + "tximod" + "txtprp" + "undo" + "unix" + "vc" + "vc-bzr" + "vc-cvs" + "vc-git" + "vc-rcs" + "vc-svn" + "verilog" + "vhdl" + "webster" + "wincom" + "winout" + "win32com" + "world-monitor"))) + (for-each sf-class + '("comwin" + "modwin" + "edtfrm")) + (sf-class "window" "class") + (sf-class "utlwin" "window" "class") + (sf-class "bufwin" "window" "class" "buffer" "struct") + (sf-class "bufwfs" "bufwin" "window" "class" "buffer" "struct") + (sf-class "bufwiu" "bufwin" "window" "class" "buffer" "struct") + (sf-class "bufwmc" "bufwin" "window" "class" "buffer" "struct") + (sf-class "buffrm" "bufwin" "window" "class" "struct")) \ No newline at end of file diff --git a/edwin/diff.scm b/edwin/diff.scm new file mode 100644 index 0000000..fe9a964 --- /dev/null +++ b/edwin/diff.scm @@ -0,0 +1,145 @@ +#| -*-Scheme-*- + +This code is written by Taylor R. Campbell and placed in the Public +Domain. All warranties are disclaimed. + +|# + +;;;; Unix diff(1) wrapper + +;;; There ought to be an accompanying diff major mode, with fancy +;;; bells & whistles for converting between unified and context diffs, +;;; like in GNU Emacs. Some day. + +(declare (usual-integrations)) + +(define-variable diff-program + "The name of the diff program." + "diff" + string?) + +(define-variable diff-switches + "A list of strings specifying switches to pass to the diff command." + '("-c") + (lambda (obj) + (list-of-type? obj string?))) + +(define-command diff + "Display differences between files." + "fOld file\nfNew file" ;Icky interactive specification + (lambda (old-filename new-filename) + (select-buffer (diff-to-buffer old-filename new-filename)))) + +(define-command diff-backup + "Display differences between a file and its latest backup." + (lambda () + (list (prompt-for-existing-file + "Diff with backup" + (cond ((buffer-pathname (selected-buffer)) + => list) + (else #f))))) + (lambda (filename) + (select-buffer + (diff-to-buffer (or (os/newest-backup filename) + (editor-error "No known backup for file: " + filename)) + filename)))) + +(define-command diff-buffer-with-file + "Display differences between a buffer and its original file." + "bBuffer" + (lambda (buffer-name) + (let* ((buffer (find-buffer buffer-name #t)) + (pathname (buffer-pathname buffer))) + (if (not (and pathname (file-exists? pathname))) + (editor-error "Buffer has no associated file.")) + (diff-buffer buffer + (lambda (temporary-pathname) + ;; PATHNAME is the buffer's usual storage on the + ;; disk; TEMPORARY-PATHNAME contains the buffer's + ;; current contents. + (diff-to-buffer pathname temporary-pathname)))))) + +(define-command diff-auto-save + "Display differences from a buffer to its auto-save file." + "bBuffer" + (lambda (buffer-name) + (let* ((buffer (find-buffer buffer-name #t)) + (pathname (buffer-pathname buffer)) + (auto-save (os/auto-save-pathname pathname buffer))) + (if (not (file-exists? auto-save)) + (editor-error "Buffer has no auto-save file.")) + (diff-buffer buffer + (lambda (temporary-pathname) + ;; PATHNAME is irrelevant; TEMPORARY-PATHNAME + ;; contains the buffer's current contents; and + ;; AUTO-SAVE contains the auto-saved contents. + (diff-to-buffer temporary-pathname auto-save)))))) + +(define (diff-buffer buffer receiver) + (select-buffer + (call-with-temporary-file-pathname + (lambda (temporary-pathname) + (write-region (buffer-region buffer) + temporary-pathname + #f ;No message + #f) ;No line ending translation + (receiver temporary-pathname))))) + +(define (diff-to-buffer old-filename new-filename #!optional buffer) + (let ((buffer (diff-to-buffer-argument buffer))) + (buffer-reset! buffer) + (set-buffer-major-mode! buffer (ref-mode-object fundamental)) + (buffer-put! buffer 'REVERT-BUFFER-METHOD + (lambda (buffer do-not-auto-save? do-not-confirm?) + do-not-auto-save? do-not-confirm? ;ignore + (diff-to-buffer old-filename new-filename buffer))) + (execute-diff old-filename new-filename buffer) + (set-buffer-point! buffer (buffer-start buffer)) + (set-buffer-read-only! buffer) + buffer)) + +(define (diff-to-buffer-argument buffer) + (cond ((default-object? buffer) (find-or-create-buffer "*Diff*")) + ((string? buffer) (find-or-create-buffer buffer)) + ((buffer? buffer) buffer) + (else (error:wrong-type-argument buffer "buffer or string" + 'DIFF-TO-BUFFER)))) + +(define (execute-diff old-filename new-filename buffer) + (let ((defaults (buffer-default-directory buffer))) + (let ((command + (make-diff-command old-filename new-filename defaults)) + (output-mark + (mark-left-inserting-copy (buffer-start buffer)))) + (insert-string (decorated-string-append "" " " "" command) + output-mark) + (insert-newline output-mark) + (let ((result (run-diff-process command defaults output-mark))) + (insert-diff-exit-remarks result output-mark))))) + +(define (make-diff-command old-filename new-filename defaults) + (cons (ref-variable diff-program) + (append (ref-variable diff-switches) + (list (enough-namestring old-filename defaults) + (enough-namestring new-filename defaults))))) + +(define (run-diff-process command defaults output-mark) + (apply run-synchronous-process + #f ; no input region + output-mark + defaults + #f ; not a pty + command)) + +(define (insert-diff-exit-remarks result output-mark) + (insert-newline output-mark) + (insert-string "Diff finished" output-mark) + (if (eqv? result 0) (insert-string " (no differences)" output-mark)) + (insert-char #\. output-mark) + (insert-newline output-mark) + (insert-chars #\space 2 output-mark) + (insert-string (universal-time->global-ctime-string + (get-universal-time)) + output-mark) + (insert-newline output-mark)) diff --git a/edwin/dired.scm b/edwin/dired.scm new file mode 100644 index 0000000..5bb4005 --- /dev/null +++ b/edwin/dired.scm @@ -0,0 +1,1064 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Directory Editor +;; package: (edwin dired) + +(declare (usual-integrations)) + +(define-variable dired-trivial-filenames + "Regexp of files to skip when finding first file of a directory. +A value of #f means move to the subdir line. +A value of #t means move to first file." + "^\\.\\.?$\\|^#" + (lambda (object) (or (string? object) (boolean? object)))) + +(define-variable dired-mode-hook + "An event distributor that is invoked when entering Dired mode." + (make-event-distributor)) + +(define-variable dired-kept-versions + "When cleaning directory, number of versions to keep." + 2 + exact-nonnegative-integer?) + +(define-variable dired-backup-overwrite + "True if Dired should ask about making backups before overwriting files. +Special value `always' suppresses confirmation." + #f + boolean?) + +(define-major-mode dired read-only "Dired" + "Mode for \"editing\" directory listings. +In dired, you are \"editing\" a list of the files in a directory. +You can move using the usual cursor motion commands. +Letters no longer insert themselves. Digits are prefix arguments. +Instead, type \\[dired-flag-file-deletion] to flag a file for Deletion. +Type \\[dired-mark] to Mark a file for later commands. + Most commands operate on the marked files and use the current file + if no files are marked. Use a numeric prefix argument to operate on + the next ARG (or previous -ARG if ARG<0) files, or just `1' + to operate on the current file only. Prefix arguments override marks. +Type \\[dired-unmark] to Unmark a file. +Type \\[dired-backup-unmark] to back up one line and unmark. +Type \\[dired-do-deletions] to eXecute the deletions requested. +Type f to Find the current line's file + (or dired it in another buffer, if it is a directory). +Type \\[dired-find-file-other-window] to find file or dired directory in Other window. +Type \\[dired-flag-auto-save-files] to flag temporary files (names beginning with #) for Deletion. +Type \\[dired-flag-backup-files] to flag backup files (names ending with ~) for Deletion. +Type \\[dired-clean-directory] to flag numerical backups for Deletion. + (Spares dired-kept-versions or its numeric argument.) +Type \\[dired-do-rename] to rename a file or move the marked files to another directory. +Type \\[dired-do-copy] to copy files. +Type \\[dired-sort-toggle-or-edit] to toggle sorting by name/date or change the listing switches. +Type \\[dired-revert] to read the directory again. This discards all deletion-flags. +Space and Rubout can be used to move down and up by lines. + +\\{dired}" + (lambda (buffer) + (event-distributor/invoke! (ref-variable dired-mode-hook buffer) buffer))) + +(define-key 'dired #\# 'dired-flag-auto-save-files) +(define-key 'dired #\+ 'dired-create-directory) +(define-key 'dired #\. 'dired-clean-directory) +(define-key 'dired #\? 'dired-summary) +(define-key 'dired #\d 'dired-flag-file-deletion) +(define-key 'dired #\e 'dired-find-file) +(define-key 'dired #\f 'dired-find-file) +(define-key 'dired #\return 'dired-find-file) +(define-key 'dired #\g 'dired-revert) +(define-key 'dired #\h 'describe-mode) +(define-key 'dired #\m 'dired-mark) +(define-key 'dired #\n 'dired-next-line) +(define-key 'dired #\o 'dired-find-file-other-window) +(define-key 'dired #\p 'dired-previous-line) +(define-key 'dired #\q 'dired-quit) +(define-key 'dired #\s 'dired-sort-toggle-or-edit) +(define-key 'dired #\u 'dired-unmark) +(define-key 'dired #\v 'dired-view-file) +(define-key 'dired #\x 'dired-do-deletions) +(define-key 'dired #\~ 'dired-flag-backup-files) + +(define-key 'dired #\C 'dired-do-copy) +(define-key 'dired #\K 'dired-encrypt/decrypt-file) +(define-key 'dired #\R 'dired-do-rename) + +(define-key 'dired #\c-d 'dired-flag-file-deletion) +(define-key 'dired #\c-n 'dired-next-line) +(define-key 'dired #\c-p 'dired-previous-line) +(define-key 'dired #\c-\] 'dired-abort) + +(define-key 'dired #\rubout 'dired-backup-unmark) +(define-key 'dired #\M-rubout 'dired-unmark-all-files) +(define-key 'dired #\space 'dired-next-line) + +(define-key 'dired down 'dired-next-line) +(define-key 'dired up 'dired-previous-line) + +(define-command dired + "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Dired displays a list of files in DIRNAME. +You can move around in it with the usual commands. +You can flag files for deletion with C-d +and then delete them by typing `x'. +Type `h' after entering dired for more info." + "DDired (directory)" + (lambda (directory) + (select-buffer (make-dired-buffer directory)))) + +(define-command dired-other-window + "\"Edit\" directory DIRNAME. Like \\[dired] but selects in another window." + "DDired in other window (directory)" + (lambda (directory) + (select-buffer-other-window (make-dired-buffer directory)))) + +(define-command dired-other-frame + "\"Edit\" directory DIRNAME. Like \\[dired] but selects in another frame." + "DDired in other frame (directory)" + (lambda (directory) + (select-buffer-other-screen (make-dired-buffer directory)))) + +(define (make-dired-buffer directory #!optional file-list) + (let ((directory (pathname-simplify directory)) + (file-list (if (default-object? file-list) 'ALL file-list))) + (let ((directory-spec (cons directory file-list))) + (or (find-dired-buffer directory-spec) + (let ((buffer (new-buffer (pathname->buffer-name directory)))) + (set-buffer-major-mode! buffer (ref-mode-object dired)) + (set-buffer-default-directory! buffer + (directory-pathname directory)) + (buffer-put! buffer 'DIRED-DIRECTORY-SPEC directory-spec) + (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer) + (fill-dired-buffer! buffer directory-spec) + (dired-initial-position! buffer) + buffer))))) + +(define (find-dired-buffer directory-spec) + (find (lambda (buffer) + (equal? directory-spec (buffer-get buffer 'DIRED-DIRECTORY-SPEC))) + (buffer-list))) + +(define (dired-buffer-directory-spec buffer) + (or (buffer-get buffer 'DIRED-DIRECTORY-SPEC) + (let ((directory-spec (cons (buffer-default-directory buffer) 'ALL))) + (buffer-put! buffer 'DIRED-DIRECTORY-SPEC directory-spec) + directory-spec))) + +(define (dired-buffer-directory buffer) + (car (dired-buffer-directory-spec buffer))) + +(define (revert-dired-buffer buffer dont-use-auto-save? dont-confirm?) + dont-use-auto-save? dont-confirm? ;ignore + (let ((lstart + (line-start (if (current-buffer? buffer) + (current-point) + (buffer-point buffer)) + 0))) + (let ((filename (dired-filename-string lstart))) + (fill-dired-buffer! buffer (dired-buffer-directory-spec buffer)) + (set-dired-point! + (or (and filename + (let loop ((lstart (buffer-start buffer))) + (if (eqv? filename (dired-filename-string lstart)) + lstart + (let ((lstart (line-start lstart 1 #f))) + (and lstart + (loop lstart)))))) + (line-start + (if (mark< lstart (buffer-end buffer)) + lstart + (buffer-end buffer)) + 0))))) + buffer) + +(define (fill-dired-buffer! buffer directory-spec) + (let ((pathname (car directory-spec)) + (file-list (cdr directory-spec))) + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + ((message-wrapper #t "Reading directory " (->namestring pathname)) + (lambda () + (read-directory pathname + file-list + (ref-variable dired-listing-switches buffer) + (buffer-point buffer)))) + (let ((point (mark-left-inserting-copy (buffer-point buffer))) + (group (buffer-group buffer))) + (let ((index (mark-index (buffer-start buffer)))) + (if (not (group-end-index? group index)) + (let loop ((index index)) + (set-mark-index! point index) + (group-insert-string! group index " ") + (let ((index (1+ (line-end-index group (mark-index point))))) + (if (not (group-end-index? group index)) + (loop index)))))) + (mark-temporary! point)) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (set-buffer-read-only! buffer))) + +(define (read-directory pathname file-list switches mark) + (if (eq? 'ALL file-list) + (insert-directory! (let ((dir (pathname-as-directory pathname))) + (if (and (not (dired-pathname-wild? pathname)) + (not (pathname=? pathname dir)) + (file-directory? pathname)) + dir + pathname)) + switches mark + (if (dired-pathname-wild? pathname) + 'WILDCARD + 'DIRECTORY)) + (let ((mark (mark-left-inserting-copy mark))) + (for-each (lambda (file) + (insert-directory! (merge-pathnames file pathname) + switches + mark + 'FILE)) + file-list) + (mark-temporary! mark)))) + +(define (insert-dired-entry! pathname mark) + (let ((mark (mark-left-inserting-copy mark))) + (insert-string " " mark) + (insert-directory! pathname + (ref-variable dired-listing-switches mark) + mark + 'FILE) + (mark-temporary! mark))) + +(define (dired-initial-position! buffer) + (let ((lstart (buffer-start buffer))) + (if (ref-variable dired-trivial-filenames lstart) + (let ((lstart (next-nontrivial-file-line lstart))) + (if lstart + (set-buffer-point! buffer (dired-filename-start lstart))))))) + +(define (next-nontrivial-file-line lstart) + (let ((dired-trivial-filenames + (ref-variable dired-trivial-filenames lstart)) + (syntax-table (group-syntax-table (mark-group lstart)))) + (let loop ((lstart lstart)) + (let ((filename (dired-filename-string lstart))) + (if (and filename + (or (not (string? dired-trivial-filenames)) + (not (re-string-match dired-trivial-filenames + filename #f syntax-table)))) + lstart + (let ((lstart (line-start lstart 1 #f))) + (and lstart + (loop lstart)))))))) + +(define-command dired-find-file + "Read the current file into a buffer." + () + (lambda () + (find-file (dired-current-pathname)))) + +(define-command dired-find-file-other-window + "Read the current file into a buffer in another window." + () + (lambda () + (find-file-other-window (dired-current-pathname)))) + +(define-command dired-revert + "Read the current buffer." + () + (lambda () + (revert-buffer (current-buffer) #t #t))) + +(define-command dired-flag-file-deletion + "Mark the current file to be killed." + "p" + (lambda (argument) + (dired-mark dired-flag-delete-char argument))) + +(define-command dired-mark + "Mark the current (or next ARG) files." + "p" + (lambda (argument) + (dired-mark dired-marker-char argument))) + +(define-command dired-unmark + "Unmark the current (or next ARG) files." + "p" + (lambda (argument) + (dired-mark #\space argument))) + +(define-command dired-backup-unmark + "Move up one line and remove deletion flag there. +Optional prefix ARG says how many lines to unflag; default is one line." + "p" + (lambda (argument) + (dired-mark-backward #\space argument))) + +(define-command dired-next-line + "Move down to the next line." + "p" + (lambda (argument) + (set-dired-point! (line-start (current-point) argument 'BEEP)))) + +(define-command dired-previous-line + "Move up to the previous line." + "p" + (lambda (argument) + (set-dired-point! (line-start (current-point) (- argument) 'BEEP)))) + +(define-command dired-do-deletions + "Kill all marked files." + () + (lambda () + (dired-kill-files))) + +(define-command dired-quit + "Exit Dired, offering to kill any files first." + () + (lambda () + (dired-kill-files) + (kill-buffer-interactive (current-buffer)))) + +(define-command dired-abort + "Exit Dired." + () + (lambda () + (kill-buffer-interactive (current-buffer)))) + +(define-command dired-summary + "Summarize the Dired commands in the typein window." + () + (lambda () + (message "d-elete, u-ndelete, x-ecute, q-uit, f-ind, o-ther window"))) + +(define-command dired-flag-auto-save-files + "Flag for deletion files whose names suggest they are auto save files." + () + (lambda () + (for-each-file-line (current-buffer) + (lambda (lstart) + (if (os/auto-save-filename? (dired-filename-string lstart)) + (dired-mark-1 lstart dired-flag-delete-char)))))) + +(define-command dired-flag-backup-files + "Flag all backup files for deletion." + () + (lambda () + (for-each-file-line (current-buffer) + (lambda (lstart) + (if (os/backup-filename? (dired-filename-string lstart)) + (dired-mark-1 lstart dired-flag-delete-char)))))) + +(define-command dired-clean-directory + "Flag numerical backups for deletion. +Spares dired-kept-versions latest versions, and kept-old-versions oldest. +Positive numeric arg overrides dired-kept-versions; +negative numeric arg overrides kept-old-versions with minus the arg." + "P" + (lambda (argument) + (let ((argument (command-argument-value argument)) + (old (ref-variable kept-old-versions)) + (new (ref-variable dired-kept-versions)) + (do-it + (lambda (old new) + (let ((total (+ old new))) + (for-each + (lambda (file) + (let ((nv (length (cdr file)))) + (if (> nv total) + (let () + (let ((end (- nv total))) + (do ((versions + (drop + (sort (cdr file) + (lambda (x y) + (< (car x) (car y)))) + old) + (cdr versions)) + (index 0 (fix:+ index 1))) + ((fix:= index end)) + (dired-mark-1 (cdar versions) + dired-flag-delete-char))))))) + (dired-numeric-backup-files)))))) + (cond ((and argument (> argument 0)) (do-it old argument)) + ((and argument (< argument 0)) (do-it (- argument) new)) + (else (do-it old new)))))) + +(define (dired-numeric-backup-files) + (let ((result '())) + (let loop ((start (line-start (buffer-start (current-buffer)) 0))) + (let ((next (line-start start 1 #f))) + (if next + (begin + (let ((filename (dired-filename-string start))) + (if filename + (let ((root.version + (os/numeric-backup-filename? filename))) + (if root.version + (let ((root (car root.version)) + (version.index + (cons (cdr root.version) start))) + (let ((entry (assoc root result))) + (if entry + (set-cdr! entry + (cons version.index (cdr entry))) + (set! result + (cons (list root version.index) + result))))))))) + (loop next))))) + result)) + +(define-command dired-unmark-all-files + "Remove a specific mark (or any mark) from every file. +After this command, type the mark character to remove, +or type RET to remove all marks. +With prefix arg, query for each marked file. +Type \\[help-command] at that time for help." + "cRemove marks (RET means all)\nP" + (lambda (mark arg) + (for-each (if arg + (let ((query-state (list #f))) + (lambda (pair) + (let ((pathname (car pair)) + (lstart (cdr pair))) + (if (with-current-point (dired-filename-start lstart) + (lambda () + (dired-query + query-state + (string-append "Unmark file `" + (file-namestring pathname) + "'")))) + (dired-mark-1 lstart #\space))))) + (lambda (pair) + (dired-mark-1 (cdr pair) #\space))) + (dired-marked-files #f (if (eqv? #\return mark) #t mark))))) + +(define (dired-query state prompt . args) + (case (car state) + ((YES) #t) + ((NO) #f) + (else + (let ((result + (let ((prompt (string-append prompt " [Type y, n, q or !]"))) + (let loop () + (apply message prompt args) + (let ((char (keyboard-read-char))) + (cond ((or (char-ci=? #\y char) + (char=? #\space char)) + #t) + ((or (char-ci=? #\n char) + (char=? #\rubout char)) + #f) + ((char-ci=? #\q char) + (set-car! state 'NO) + #f) + ((char=? #\! char) + (set-car! state 'YES) + #t) + (else + (editor-failure "Please answer y, n, q or !.") + (sit-for 1000) + (loop)))))))) + (clear-message) + result)))) + +(define-command dired-sort-toggle-or-edit + "Toggle between sort by date/name and refresh the dired buffer. +With a prefix argument you can edit the current listing switches instead." + "P" + (lambda (argument) + (if argument + (dired-change-listing-switches + (lambda (switches) + (prompt-for-string "Listing switches (must contain -l)" + switches + 'DEFAULT-TYPE 'INSERTED-DEFAULT))) + (dired-toggle-switch #\t)))) + +(define (dired-toggle-switch switch) + (dired-change-listing-switches + (lambda (switches) + (let loop ((switches (burst-string switches char-set:whitespace #t))) + (if (pair? switches) + (let ((index + (and (string-prefix? "-" (car switches)) + (not (string-prefix? "--" (car switches))) + (string-find-next-char (car switches) switch)))) + (if index + (let ((s1 + (string-append (string-head (car switches) index) + (string-tail (car switches) + (fix:+ index 1)))) + (s2 + (reduce-right string-append-separated + "" + (cdr switches)))) + (if (string=? "-" s1) + s2 + (string-append-separated s1 s2))) + (string-append-separated (car switches) + (loop (cdr switches))))) + (string #\- switch)))))) + +(define (dired-change-listing-switches procedure) + (local-set-variable! dired-listing-switches + (procedure (ref-variable dired-listing-switches))) + ((ref-command dired-revert))) + +;;;; File Operation Commands + +(define-command dired-create-directory + "Create a directory named DIRECTORY." + "DCreate directory" + (lambda (directory) + (let ((directory (directory-pathname-as-file directory))) + (make-directory directory) + (let ((lstart + (mark-right-inserting-copy (line-start (current-point) 0)))) + (with-read-only-defeated lstart + (lambda () + (insert-dired-entry! directory lstart))) + (set-dired-point! lstart) + (mark-temporary! lstart))))) + +(define-command dired-do-copy + "Copy all marked (or next ARG) files, or copy the current file. +This preserves the last-modified date when copying. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory, +and new copies of these files are made in that directory +with the same names that the files currently have." + "P" + (lambda (argument) + (dired-create-files argument "copy" "copies" + (dired-create-file-operation copy-file)))) + +(define-command dired-do-rename + "Rename current file or all marked (or next ARG) files. +When renaming just the current file, you specify the new name. +When renaming multiple or marked files, you specify a directory." + "P" + (lambda (argument) + (dired-create-files + argument "rename" "renames" + (let ((rename (dired-create-file-operation rename-file))) + (lambda (lstart from to) + (let ((condition (rename lstart from to))) + (if (not condition) + (dired-redisplay to lstart)) + condition)))))) + +(define (dired-create-file-operation operation) + (lambda (lstart from to) + lstart + (catch-file-errors (lambda (condition) condition) + (lambda () + (dired-handle-overwrite to) + (operation from to) + #f)))) + +(define (dired-handle-overwrite to) + (if (and (file-exists? to) + (ref-variable dired-backup-overwrite) + (or (eq? 'ALWAYS (ref-variable dired-backup-overwrite)) + (prompt-for-confirmation? + (string-append "Make backup for existing file `" + (->namestring to) + "'")))) + (call-with-values (lambda () (os/buffer-backup-pathname to #f)) + (lambda (backup-pathname targets) + targets + (rename-file to backup-pathname))))) + +(define (dired-create-files argument singular-verb plural-verb operation) + (let ((filenames + (if argument + (dired-next-files (command-argument-value argument)) + (let ((files (dired-marked-files))) + (if (null? files) + (dired-next-files 1) + files))))) + (cond ((null? filenames) + (message "No files to " (string-downcase singular-verb) ".")) + ((null? (cdr filenames)) + (dired-create-one-file (cdar filenames) (caar filenames) + singular-verb operation)) + (else + (dired-create-many-files filenames + singular-verb plural-verb operation))))) + +(define (dired-create-one-file lstart from singular-verb operation) + (let ((to + (prompt-for-pathname (string-append (string-capitalize singular-verb) + " " + (file-namestring from) + " to") + from))) + (let ((condition + (operation lstart from + (if (file-directory? to) + (merge-pathnames (file-pathname from) + (pathname-as-directory to)) + to)))) + (if condition + (editor-error (string-capitalize singular-verb) + " failed: " + (condition/report-string condition)))))) + +(define (dired-create-many-files filenames singular-verb plural-verb operation) + (let ((destination + (directory-pathname + (cleanup-pop-up-buffers + (lambda () + (dired-pop-up-files-window filenames) + (prompt-for-existing-directory + (string-append (string-capitalize singular-verb) + " these files to directory") + #f)))))) + (for-each (lambda (filename) + (set-cdr! filename (mark-right-inserting-copy (cdr filename)))) + filenames) + (let loop ((filenames filenames) (failures '())) + (cond ((not (null? filenames)) + (loop (cdr filenames) + (if (operation (cdar filenames) + (caar filenames) + (merge-pathnames + (file-pathname (caar filenames)) + destination)) + (cons (file-namestring (caar filenames)) failures) + failures))) + ((not (null? failures)) + (message (string-capitalize plural-verb) + " failed: " + (reverse! failures))))) + (for-each (lambda (filename) + (mark-temporary! (cdr filename))) + filenames))) + +;;;; Encrypt/Decrypt File + +(define-command dired-encrypt/decrypt-file + "Encrypt/Decrypt a file. +Decrypts if the file's suffix is recognized as a known encryption type. +Otherwise encrypts using Blowfish. +Prefix arg means treat the plaintext file as binary data (ignored on unix)." + "P" + (lambda (binary-plaintext?) + (let ((pathname (dired-current-pathname))) + (let ((type (pathname-type pathname))) + (cond ((equal? "bf" type) + (dired-blowfish-decrypt-file pathname binary-plaintext?)) + (else + (dired-blowfish-encrypt-file pathname binary-plaintext?))))))) + +(define (dired-blowfish-encrypt-file from binary-plaintext?) + (let ((to (string-append (->namestring from) ".bf"))) + (blowfish-encrypt-file from to binary-plaintext? #t) + (dired-redisplay to))) + +(define (dired-blowfish-decrypt-file from binary-plaintext?) + (let ((to (pathname-new-type from #f))) + (blowfish-decrypt-file from to binary-plaintext? #t) + (dired-redisplay to))) + +;;;; List Directory + +(define-command list-directory + "Display a list of files in or matching DIRNAME. +Prefix arg (second arg if noninteractive) means display a verbose listing. +Actions controlled by variables list-directory-brief-switches + and list-directory-verbose-switches." + (lambda () + (let ((argument (command-argument))) + (list (prompt-for-directory (if argument + "List directory (verbose)" + "List directory (brief)") + #f) + argument))) + (lambda (directory argument) + (let ((directory (->pathname directory)) + (buffer (temporary-buffer "*Directory*"))) + (disable-group-undo! (buffer-group buffer)) + (let ((point (buffer-end buffer))) + (insert-string "Directory " point) + (insert-string (->namestring directory) point) + (insert-newline point) + (read-directory directory + 'ALL + (if argument + (ref-variable list-directory-verbose-switches) + (ref-variable list-directory-brief-switches)) + point)) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (pop-up-buffer buffer #f)))) + +;;;; Utilities + +(define (dired-filename-start lstart) + (re-match-forward directory-listing-before-filename-regexp + lstart + (line-end lstart 0) + #f)) + +(define (dired-filename-string lstart) + (let ((start (dired-filename-start lstart))) + (and start + (extract-string start + (let ((end (line-end start 0))) + (if (search-forward " -> " start end) + (re-match-start 0) + end)))))) + +(define (set-dired-point! mark) + (set-current-point! + (let ((lstart (line-start mark 0))) + (or (dired-filename-start lstart) + lstart)))) + +(define (dired-current-pathname) + (let ((lstart (line-start (current-point) 0))) + (guarantee-dired-filename-line lstart) + (dired-pathname lstart))) + +(define (guarantee-dired-filename-line lstart) + (if (not (dired-filename-start lstart)) + (editor-error "No file on this line"))) + +(define (dired-pathname lstart) + (let ((filename (dired-filename-string lstart))) + (and filename + (merge-pathnames + (directory-pathname (dired-buffer-directory (mark-buffer lstart))) + filename)))) + +(define (dired-mark char n) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n) unspecific) + (let ((lstart (line-start (current-point) 0))) + (guarantee-dired-filename-line lstart) + (dired-mark-1 lstart char) + (set-dired-point! (line-start lstart 1))))) + +(define (dired-mark-backward char n) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n) unspecific) + (let ((lstart (line-start (current-point) -1 'ERROR))) + (set-dired-point! lstart) + (guarantee-dired-filename-line lstart) + (dired-mark-1 lstart char)))) + +(define (dired-mark-1 lstart char) + (with-read-only-defeated lstart + (lambda () + (delete-right-char lstart) + (insert-chars char 1 lstart)))) + +(define (dired-file-line? lstart) + (and (dired-filename-start lstart) + (not (re-match-forward ". d" lstart (mark+ lstart 3))))) + +(define (for-each-file-line buffer procedure) + (let ((point (mark-right-inserting-copy (buffer-start buffer)))) + (do () ((group-end? point)) + (if (dired-file-line? point) + (procedure point)) + (move-mark-to! point (line-start point 1))) + (mark-temporary! point))) + +;;; Regular expression to match up to the file name in a directory +;;; listing. The default value is designed to recognize dates and +;;; times regardless of the language. + +;;; Stolen from Emacs 22 and translated to REXP format. + +(define directory-listing-before-filename-regexp + (let* ((l + (char-set-union char-set:alphabetic + (ucs-range->char-set #x80 #x100))) + (l? (rexp-optional l)) + (l-or-quote (char-set-union l (char-set #\'))) + (digit (string->char-set "0123456789")) + ;; In some locales, month abbreviations are as short as 2 letters, + ;; and they can be followed by ".". + ;; In Breton, a month name can include a quote character. + (month + (rexp-sequence (rexp-n* 2 l-or-quote) + (rexp-optional "."))) + (s " ") + (s+ (rexp+ s)) + (yyyy (rexp-n*n 4 char-set:numeric)) + (dd (rexp-sequence (string->char-set " 0123") digit)) + (HH:MM (rexp-sequence (string->char-set " 012") + digit + (string->char-set ":.") + (string->char-set "012345") + digit)) + (seconds (rexp-sequence (string->char-set "0123456") + digit + (rexp-optional (string->char-set ".,") + (rexp+ digit)))) + (zone (rexp-sequence (string->char-set "-+") + (string->char-set "012") + digit + (string->char-set "012345") + digit)) + (iso-mm-dd (rexp-sequence (string->char-set "01") + digit + "-" + (string->char-set "0123") + digit)) + (iso-time + (rexp-sequence HH:MM + (rexp-optional ":" + seconds + (rexp-optional (rexp-optional s) + zone)))) + (iso + (rexp-alternatives (rexp-sequence (rexp-optional yyyy "-") + iso-mm-dd + (string->char-set " T") + iso-time) + (rexp-sequence yyyy + "-" + iso-mm-dd))) + (western + (rexp-sequence + (rexp-alternatives (rexp-sequence month s+ dd) + (rexp-sequence dd (rexp-optional ".") s month)) + s+ + (rexp-alternatives HH:MM yyyy))) + (western-comma + (rexp-sequence month s+ dd "," s+ yyyy)) + ;; Japanese MS-Windows ls-lisp has one-digit months, and + ;; omits the Kanji characters after month and day-of-month. + ;; On Mac OS X 10.3, the date format in East Asian locales is + ;; day-of-month digits followed by month digits. + (mm (rexp-sequence (rexp-optional (string->char-set " 01")) + digit)) + (east-asian + (rexp-sequence + (rexp-alternatives (rexp-sequence mm l? s dd l? s+) + (rexp-sequence dd s mm s+)) + (rexp-alternatives HH:MM + (rexp-sequence yyyy l?))))) + ;; The "[0-9]" below requires the previous column to end in a digit. + ;; This avoids recognizing `1 may 1997' as a date in the line: + ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README + + ;; The "[BkKMGTPEZY]?" below supports "ls -alh" output. + ;; The ".*" below finds the last match if there are multiple matches. + ;; This avoids recognizing `jservice 10 1024' as a date in the line: + ;; drwxr-xr-x 3 jservice 10 1024 Jul 2 1997 esg-host + + ;; vc dired listings provide the state or blanks between file + ;; permissions and date. The state is always surrounded by + ;; parentheses: + ;; -rw-r--r-- (modified) 2005-10-22 21:25 files.el + ;; Support for this was added to Edwin by cph. + (rexp-compile + (rexp-sequence (rexp* (rexp-any-char)) + (rexp-alternatives + (rexp-sequence digit + (rexp-optional + (string->char-set "BkKMGTPEZY"))) + ")") + s+ + (rexp-alternatives western + western-comma + east-asian + iso) + s+)))) + +(define (dired-redisplay pathname #!optional mark) + (let ((lstart + (mark-right-inserting-copy + (line-start (if (or (default-object? mark) (not mark)) + (current-point) + mark) + 0)))) + (let ((point-on-line? (mark= lstart (line-start (current-point) 0)))) + (with-read-only-defeated lstart + (lambda () + (let ((marker-char (mark-right-char lstart)) + (lstart* (mark-left-inserting-copy lstart))) + (if (pathname=? (buffer-default-directory (mark-buffer lstart)) + (directory-pathname pathname)) + (begin + (insert-dired-entry! pathname lstart) + (delete-right-char lstart) + (insert-chars marker-char 1 lstart))) + (delete-string lstart* (line-start lstart* 1)) + (mark-temporary! lstart*)))) + (if point-on-line? + (set-dired-point! lstart))) + (mark-temporary! lstart))) + +(define (dired-kill-files) + (let ((filenames (dired-marked-files #f dired-flag-delete-char))) + (if (and (not (null? filenames)) + (cleanup-pop-up-buffers + (lambda () + (dired-pop-up-files-window filenames) + (prompt-for-yes-or-no? "Delete these files")))) + ;; Must delete the files in reverse order so that the + ;; non-permanent marks remain valid as lines are deleted. + (let loop ((filenames (reverse! filenames)) (failures '())) + (cond ((not (null? filenames)) + (loop (cdr filenames) + (if (dired-kill-file! (caar filenames) (cdar filenames)) + failures + (cons (file-namestring (caar filenames)) + failures)))) + ((not (null? failures)) + (message "Deletions failed: " failures))))))) + +(define (dired-pop-up-files-window filenames) + (pop-up-temporary-buffer " *dired-files*" '(READ-ONLY SHRINK-WINDOW) + (lambda (buffer window) + (local-set-variable! truncate-partial-width-windows #f buffer) + (write-strings-densely (map (lambda (filename) + (file-namestring (car filename))) + filenames) + (mark->output-port (buffer-point buffer)) + (window-x-size + (or window (car (buffer-windows buffer)))))))) + +(define (dired-kill-file! filename lstart) + (let ((deleted? + (if (let ((attributes (file-attributes-direct filename))) + (and attributes + (eq? #t (file-attributes/type attributes)))) + (delete-directory-no-errors filename) + (delete-file-no-errors filename)))) + (if deleted? + (with-read-only-defeated lstart + (lambda () + (delete-string lstart (line-start lstart 1))))) + deleted?)) + +(define dired-flag-delete-char #\D) +(define dired-marker-char #\*) + +(define (dired-mark-files! buffer predicate) + (for-each-file-line buffer + (lambda (lstart) + (if (predicate (dired-pathname lstart)) + (dired-mark-1 lstart dired-marker-char))))) + +(define (dired-marked-files #!optional mark marker-char) + (let ((mark + (cond ((or (default-object? mark) (not mark)) + (buffer-start (current-buffer))) + ((buffer? mark) + (buffer-start mark)) + (else + mark))) + (marker-char + (if (or (default-object? marker-char) (not marker-char)) + dired-marker-char + marker-char))) + (let loop ((start (line-start mark 0))) + (let ((continue + (lambda () + (let ((next (line-start start 1 #f))) + (if next + (loop next) + '()))))) + (if (and (let ((char (mark-right-char start))) + (and char + (if (eq? #t marker-char) + (not (char=? #\space char)) + (char-ci=? marker-char char)))) + (dired-filename-start start)) + (cons (cons (dired-pathname start) start) + (continue)) + (continue)))))) + +(define (dired-next-files n #!optional mark) + (let ((mark + (cond ((or (default-object? mark) (not mark)) + (current-point)) + ((buffer? mark) + (if (selected-buffer? mark) + (current-point) + (buffer-point mark))) + (else mark)))) + (let loop ((start (line-start mark 0)) (n n)) + (if (<= n 0) + '() + (let ((continue + (lambda () + (let ((next (line-start start 1 #f))) + (if next + (loop next (- n 1)) + '()))))) + (if (dired-filename-start start) + (cons (cons (dired-pathname start) start) + (continue)) + (continue))))))) + +(define (dired-this-file #!optional mark error?) + (let ((mark + (cond ((or (default-object? mark) (not mark)) + (current-point)) + ((buffer? mark) + (if (selected-buffer? mark) + (current-point) + (buffer-point mark))) + (else mark)))) + (let ((start (line-start mark 0))) + (if (dired-filename-start start) + (dired-pathname start) + (and error? (editor-error "No file on this line")))))) + +(define (for-each-dired-mark buffer procedure) + (for-each (lambda (file) + (procedure (car file)) + (dired-mark-1 (cdr file) #\space) + (update-screens! #f)) + (dired-marked-files buffer))) + +(define (dired-change-files verb argument procedure) + (let ((filenames + (if argument + (dired-next-files (command-argument-value argument)) + (let ((files (dired-marked-files))) + (if (null? files) + (dired-next-files 1) + files))))) + (if (null? filenames) + (message "No files to " verb ".") + (begin + (for-each (lambda (filename) + (set-cdr! filename + (mark-right-inserting-copy (cdr filename)))) + filenames) + (for-each (lambda (filename) + (procedure (car filename) (cdr filename)) + (mark-temporary! (cdr filename))) + filenames))) + (length filenames))) \ No newline at end of file diff --git a/edwin/dirunx.scm b/edwin/dirunx.scm new file mode 100644 index 0000000..c2ed697 --- /dev/null +++ b/edwin/dirunx.scm @@ -0,0 +1,111 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Directory Editor (Unix Customizations) +;;; package: (edwin dired) + +(declare (usual-integrations)) + +(define (dired-change-inode program) + (lambda (attribute argument) + (dired-change-files (string-append "change" attribute "of") argument + (let ((program (os/find-program program #f (ref-variable exec-path))) + (directory (buffer-default-directory (current-buffer)))) + (lambda (pathname lstart) + (run-synchronous-process #f #f directory #f + program attribute (->namestring pathname)) + (dired-redisplay pathname lstart)))))) + +(define-key 'dired #\M 'dired-chmod) +(define-command dired-chmod + "Change mode of this file." + "sChange to Mode\nP" + (dired-change-inode "chmod")) + +(define-key 'dired #\G 'dired-chgrp) +(define-command dired-chgrp + "Change group of this file." + "sChange to Group\nP" + (dired-change-inode "chgrp")) + +(define-key 'dired #\O 'dired-chown) +(define-command dired-chown + "Change owner of this file." + "sChange to Owner\nP" + (dired-change-inode "chown")) + +(define-key 'dired #\Z 'dired-do-compress) +(define-command dired-do-compress + "Compress or uncompress marked (or next ARG) files. +The files are compressed or uncompressed using gzip." + "P" + (lambda (argument) + (let ((n + (dired-change-files "compress" argument + (let ((gzip (os/find-program "gzip" #f (ref-variable exec-path))) + (directory (buffer-default-directory (current-buffer)))) + (lambda (pathname lstart) + (let ((type (pathname-type pathname)) + (namestring (->namestring pathname))) + (let ((decompress? (member type '("gz" "z" "Z")))) + (message (if decompress? "Unc" "C") + "ompressing file `" namestring "'...") + (run-synchronous-process #f #f directory #f + gzip + (if decompress? "-d" "") + namestring) + (dired-redisplay + (pathname-new-type + pathname + (and (not decompress?) + (if (string? type) + (string-append type ".gz") + "gz"))) + lstart)))))))) + (if (positive? n) + (message "Compressed or uncompressed " n " files."))))) + +#| +(define-command dired-do-symlink + "Make symbolic links to current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new symbolic links are made in that directory +with the same names that the files currently have." + "P" + (lambda (argument) + )) + +(define-command dired-do-hardlink + "Add names (hard links) current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new hard links are made in that directory +with the same names that the files currently have." + "P" + (lambda (argument) + )) +|# \ No newline at end of file diff --git a/edwin/dirw32.scm b/edwin/dirw32.scm new file mode 100644 index 0000000..bd5453b --- /dev/null +++ b/edwin/dirw32.scm @@ -0,0 +1,126 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Directory Editor (Win32 Customizations) +;;; package: (edwin dired) + +(declare (usual-integrations)) + +(define-key 'dired #\Z 'dired-do-compress) +(define-key 'dired #\S 'dired-hidden-toggle) +(define-key 'dired #\M 'dired-chmod) + +(define-command dired-do-compress + "Compress or uncompress marked (or next ARG) files. +The files are compressed or uncompressed using gzip." + "P" + (lambda (argument) + (let ((n + (dired-change-files "compress" argument + (let ((gzip (os/find-program "gzip" #f (ref-variable exec-path))) + (directory (buffer-default-directory (current-buffer)))) + (lambda (pathname lstart) + (let ((type (pathname-type pathname)) + (namestring (->namestring pathname))) + (let ((decompress? (equal? type "gz"))) + (message (if decompress? "Unc" "C") + "ompressing file `" namestring "'...") + (run-synchronous-process #f #f directory #f + gzip + (if decompress? "-d" "") + namestring) + (dired-redisplay + (pathname-new-type + pathname + (and (not decompress?) + (if (string? type) + (string-append type ".gz") + "gz"))) + lstart)))))))) + (if (positive? n) + (message "Compressed or uncompressed " n " files."))))) + +(define-command dired-hidden-toggle + "Toggle display of hidden/system files on and off." + () + (lambda () (dired-toggle-switch #\a))) + +(define-command dired-chmod + "Change mode of this file." + "sChange to Mode\nP" + (lambda (spec argument) + (call-with-values (lambda () (win32/parse-attributes-spec spec)) + (lambda (plus minus) + (dired-change-files "change attributes of" argument + (lambda (pathname lstart) + (set-file-modes! pathname + (fix:or (fix:andc (file-modes pathname) + minus) + plus)) + (dired-redisplay pathname lstart))))))) + +(define (win32/parse-attributes-spec spec) + (let ((end (string-length spec)) + (plus '()) + (minus '())) + (let loop ((index 0) (state #f)) + (if (< index end) + (let ((char (char-downcase (string-ref spec index))) + (index (+ index 1))) + (case char + ((#\+ #\-) + (loop index char)) + ((#\a #\c #\h #\r #\s) + (set! plus (delv! char plus)) + (set! minus (delv! char minus)) + (case state + ((#\+) + (set! plus (cons char plus)) + (loop index state)) + ((#\-) + (set! minus (cons char minus)) + (loop index state)) + (else #f))) + (else #f))) + (values (win32/attribute-letters-to-mask plus) + (win32/attribute-letters-to-mask minus)))))) + +(define (win32/attribute-letters-to-mask letters) + (let ((mask 0)) + (for-each (lambda (letter) + (set! mask + (fix:or (case letter + ((#\a) nt-file-mode/archive) + ((#\c) nt-file-mode/compressed) + ((#\d) nt-file-mode/directory) + ((#\h) nt-file-mode/hidden) + ((#\r) nt-file-mode/read-only) + ((#\s) nt-file-mode/system) + (else (error "Unknown mode letter:" letter))) + mask)) + unspecific) + letters) + mask)) \ No newline at end of file diff --git a/edwin/display.scm b/edwin/display.scm new file mode 100644 index 0000000..b630edb --- /dev/null +++ b/edwin/display.scm @@ -0,0 +1,96 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Display-Type Abstraction +;;; package: (edwin display-type) + +(declare (usual-integrations)) + +(define-structure (display-type + (conc-name display-type/) + (constructor %make-display-type) + (print-procedure + (standard-print-method 'DISPLAY-TYPE + (lambda (display-type) + (list (display-type/name display-type)))))) + (name false read-only true) + (multiple-screens? false read-only true) + (operation/available? false read-only true) + (operation/make-screen false read-only true) + (operation/get-input-operations false read-only true) + (operation/with-display-grabbed false read-only true) + (operation/with-interrupts-enabled false read-only true) + (operation/with-interrupts-disabled false read-only true)) + +(define (make-display-type name + multiple-screens? + available? + make-screen + get-input-operations + with-display-grabbed + with-interrupts-enabled + with-interrupts-disabled) + (let ((display-type + (%make-display-type name + multiple-screens? + available? + make-screen + get-input-operations + with-display-grabbed + with-interrupts-enabled + with-interrupts-disabled))) + (set! display-types (cons display-type display-types)) + display-type)) + +(define display-types '()) + +(define (display-type/available? display-type) + ((display-type/operation/available? display-type))) + +(define (display-type/make-screen display-type args) + (apply (display-type/operation/make-screen display-type) args)) + +(define (display-type/get-input-operations display-type screen) + ((display-type/operation/get-input-operations display-type) screen)) + +(define (display-type/with-display-grabbed display-type thunk) + ((display-type/operation/with-display-grabbed display-type) thunk)) + +(define (display-type/with-interrupts-enabled display-type thunk) + ((display-type/operation/with-interrupts-enabled display-type) thunk)) + +(define (display-type/with-interrupts-disabled display-type thunk) + ((display-type/operation/with-interrupts-disabled display-type) thunk)) + +(define (editor-display-types) + (filter display-type/available? display-types)) + +(define (name->display-type name) + (let ((display-type + (find (lambda (display-type) + (eq? name (display-type/name display-type))) + display-types))) + display-type)) \ No newline at end of file diff --git a/edwin/docstr.scm b/edwin/docstr.scm new file mode 100644 index 0000000..e91a9cb --- /dev/null +++ b/edwin/docstr.scm @@ -0,0 +1,202 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Documentation Strings + +(declare (usual-integrations)) + +(define *external-doc-strings?* #t) +(define *external-doc-strings-file* #f) +(define *doc-strings* #f) +(define *doc-string-posn* 0) +(define *doc-string-channel* #f) +(define *doc-string-buffer* #f) + +(define (doc-string->posn name str) + (if (and *external-doc-strings?* (string? str)) + (let ((nlen (string-length name)) + (dslen (string-length str)) + (slen (if (not *doc-strings*) + 0 + (string-length *doc-strings*))) + (posn *doc-string-posn*)) + (let* ((next (fix:+ posn nlen)) + (end (fix:+ next (fix:+ dslen 6)))) + (if (> end slen) + (let ((new (string-allocate + (max end + (if (fix:zero? slen) + 4096 + (fix:+ slen (fix:quotient slen 2))))))) + (if *doc-strings* + (substring-move-right! *doc-strings* 0 posn new 0)) + (set! *doc-strings* new))) + (let ((doc-strings *doc-strings*)) + (vector-8b-set! doc-strings posn (fix:remainder dslen 256)) + (vector-8b-set! doc-strings + (fix:+ posn 1) + (fix:quotient dslen 256)) + (string-set! doc-strings (fix:+ posn 2) #\Newline) + (substring-move-right! name 0 nlen doc-strings (fix:+ posn 3)) + (string-set! doc-strings (fix:+ next 3) #\Newline) + (substring-move-right! str 0 dslen doc-strings (fix:+ next 4)) + (string-set! doc-strings (fix:- end 2) #\Newline) + (string-set! doc-strings (fix:- end 1) #\Newline) + (set! *doc-string-posn* end) + posn))) + str)) + +(define-integrable doc-string-buffer-length 512) + +(define (->doc-string name posn) + (define (out-of-range) + (editor-error "->doc-string: Out of range argument" posn)) + + (define (fill-buffer channel buffer posn blen) + (let fill-loop ((posn posn)) + (if (fix:< posn blen) + (let ((n (channel-read-block channel buffer posn blen))) + (fill-loop (fix:+ posn n)))))) + + (define (verify-and-extract buffer nlen dslen nposn) + (let ((nend (fix:+ nposn nlen))) + (if (not (string=? (substring buffer nposn nend) name)) + (editor-error "->doc-string: Inconsistency" posn) + (let ((dstart (fix:+ nend 1))) + (substring buffer dstart (fix:+ dstart dslen)))))) + + (cond ((string? posn) + posn) + ((not (fix:fixnum? posn)) + (editor-error "->doc-string: Wrong type argument" posn)) + ((fix:< posn 0) + (out-of-range)) + (*doc-strings* + (let ((slen (string-length *doc-strings*)) + (nlen (string-length name))) + (if (fix:> (fix:+ posn 2) slen) + (out-of-range)) + (let ((dslen + (fix:+ (vector-8b-ref *doc-strings* posn) + (fix:lsh (vector-8b-ref *doc-strings* (fix:+ posn 1)) + 8)))) + (if (fix:> (fix:+ (fix:+ posn 6) (fix:+ nlen dslen)) slen) + (out-of-range) + (verify-and-extract *doc-strings* nlen dslen + (fix:+ posn 3)))))) + (else + (guarantee-doc-string-state) + (let* ((channel *doc-string-channel*) + (buffer *doc-string-buffer*) + (flen (channel-file-length channel)) + (nlen (string-length name)) + (delta (fix:- flen (fix:+ posn 2)))) + (if (fix:< delta 0) + (out-of-range)) + (channel-file-set-position channel posn) + (let ((blen (min doc-string-buffer-length delta))) + (fill-buffer channel buffer 0 blen) + (let* ((dslen (fix:+ (vector-8b-ref buffer 0) + (fix:lsh (vector-8b-ref buffer 1) + 8))) + (end (fix:+ (fix:+ dslen nlen) 6))) + (cond ((not (fix:> end blen)) + (verify-and-extract buffer nlen dslen 3)) + ((fix:> (fix:+ end posn) flen) + (out-of-range)) + (else + (let* ((rlen (fix:+ (fix:+ nlen dslen) 1)) + (result (string-allocate rlen))) + (substring-move-right! buffer 3 blen result 0) + (fill-buffer channel result (fix:- blen 3) rlen) + (verify-and-extract result nlen dslen 0)))))))))) + +(define (dump-doc-strings output #!optional permanent) + (if (not *doc-strings*) + (error "dump-doc-strings: No doc strings to dump!")) + (set! *external-doc-strings-file* + (if (or (default-object? permanent) + (not permanent)) + output + permanent)) + (set-string-length! *doc-strings* *doc-string-posn*) + (call-with-binary-output-file output + (lambda (port) + (write-bytevector (string->bytevector *doc-strings*) port))) + (set! *external-doc-strings?* #f) + (set! *doc-string-posn* 0) + (set! *doc-strings* #f) + unspecific) + +(define (guarantee-doc-string-state) + (if (not *doc-string-buffer*) + (set! *doc-string-buffer* (string-allocate doc-string-buffer-length))) + (cond (*doc-string-channel*) + ((not *external-doc-strings-file*) + (editor-error + "guarantee-doc-string-channel: Undeclared doc-string file")) + (else + (let ((doc-strings + (if (or (pathname-absolute? *external-doc-strings-file*) + (file-exists? *external-doc-strings-file*)) + *external-doc-strings-file* + (merge-pathnames *external-doc-strings-file* + (edwin-etc-directory))))) + (if (not (file-exists? doc-strings)) + (editor-error + "guarantee-doc-string-channel: Non-existent doc-string file") + (begin + (set! *doc-string-channel* + (file-open-input-channel + (->namestring doc-strings))) + unspecific)))))) + +(add-event-receiver! event:after-restart + (lambda () (set! *doc-string-channel* #f))) + +;;;; Abstraction of help descriptions + +(define (description? description) + (or (string? description) + (and (procedure? description) + (procedure-arity-valid? description 0)))) + +(define (description->string description) + (cond ((string? description) description) + ((procedure? description) (description)) + (else + (error:wrong-type-argument description "description" + 'DESCRIPTION->STRING)))) + +(define (description-first-line description) + (let ((string (description->string description))) + (let ((index (string-find-next-char string #\newline))) + (if index + (substring string 0 index) + string)))) + +(define (description-append . descriptions) + (lambda () (apply string-append (map description->string descriptions)))) \ No newline at end of file diff --git a/edwin/dos.scm b/edwin/dos.scm new file mode 100644 index 0000000..afa2a75 --- /dev/null +++ b/edwin/dos.scm @@ -0,0 +1,158 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Win32 Customizations for Edwin + +(declare (usual-integrations)) + +(define (os/set-file-modes-writeable! pathname) + (set-file-modes! pathname + (fix:andc (file-modes pathname) nt-file-mode/read-only))) + +(define (os/restore-modes-to-updated-file! pathname modes) + (set-file-modes! pathname (fix:or modes nt-file-mode/archive))) + +(define (os/scheme-can-suspend?) + #t) + +(define (os/quit dir) + (with-real-working-directory-pathname dir suspend)) + +(define (with-real-working-directory-pathname dir thunk) + (let ((inside (->namestring (directory-pathname-as-file dir))) + (outside false)) + (dynamic-wind + (lambda () + (stop-thread-timer) + (set! outside + (->namestring + (directory-pathname-as-file (working-directory-pathname)))) + (set-working-directory-pathname! inside) + ((ucode-primitive set-working-directory-pathname! 1) + (string-for-primitive inside))) + thunk + (lambda () + (set! inside + (->namestring + (directory-pathname-as-file (working-directory-pathname)))) + ((ucode-primitive set-working-directory-pathname! 1) + (string-for-primitive outside)) + (set-working-directory-pathname! outside) + (start-thread-timer))))) + +(define (dos/read-dired-files file all-files?) + (map (lambda (entry) (cons (file-namestring (car entry)) (cdr entry))) + (let ((entries (directory-read file #f #t))) + (if all-files? + entries + (filter (let ((mask + (fix:or nt-file-mode/hidden nt-file-mode/system))) + (lambda (entry) + (fix:= (fix:and (file-attributes/modes (cdr entry)) + mask) + 0))) + entries))))) + +;;;; Win32 Clipboard Interface + +(define cut-and-paste-active? + #t) + +(define (os/interprogram-cut string context) + context + (if cut-and-paste-active? + (win32-clipboard-write-text + (let ((string (convert-newline-to-crlf string))) + ;; Some programs can't handle strings over 64k. + (if (fix:< (string-length string) #x10000) string ""))))) + +(define (os/interprogram-paste context) + context + (if cut-and-paste-active? + (let ((text (win32-clipboard-read-text))) + (and text + (convert-crlf-to-newline text))))) + +(define (convert-newline-to-crlf string) + (let ((end (string-length string))) + (let ((n-newlines + (let loop ((start 0) (n-newlines 0)) + (let ((newline + (substring-find-next-char string start end #\newline))) + (if newline + (loop (fix:+ newline 1) (fix:+ n-newlines 1)) + n-newlines))))) + (if (fix:= n-newlines 0) + string + (let ((copy (make-string (fix:+ end n-newlines)))) + (let loop ((start 0) (cindex 0)) + (let ((newline + (substring-find-next-char string start end #\newline))) + (if newline + (begin + (%substring-move! string start newline copy cindex) + (let ((cindex (fix:+ cindex (fix:- newline start)))) + (string-set! copy cindex #\return) + (string-set! copy (fix:+ cindex 1) #\newline) + (loop (fix:+ newline 1) (fix:+ cindex 2)))) + (%substring-move! string start end copy cindex)))) + copy))))) + +(define (convert-crlf-to-newline string) + (let ((end (string-length string))) + (let ((n-crlfs + (let loop ((start 0) (n-crlfs 0)) + (let ((cr + (substring-find-next-char string start end #\return))) + (if (and cr + (not (fix:= (fix:+ cr 1) end)) + (char=? (string-ref string (fix:+ cr 1)) #\linefeed)) + (loop (fix:+ cr 2) (fix:+ n-crlfs 1)) + n-crlfs))))) + (if (fix:= n-crlfs 0) + string + (let ((copy (make-string (fix:- end n-crlfs)))) + (let loop ((start 0) (cindex 0)) + (let ((cr + (substring-find-next-char string start end #\return))) + (if (not cr) + (%substring-move! string start end copy cindex) + (let ((cr + (if (and (not (fix:= (fix:+ cr 1) end)) + (char=? (string-ref string (fix:+ cr 1)) + #\linefeed)) + cr + (fix:+ cr 1)))) + (%substring-move! string start cr copy cindex) + (loop (fix:+ cr 1) (fix:+ cindex (fix:- cr start))))))) + copy))))) + +;;;; Mail Customization + +(define (os/rmail-spool-directory) #f) +(define (os/rmail-primary-inbox-list system-mailboxes) system-mailboxes '()) +(define (os/sendmail-program) "sendmail.exe") +(define (os/rmail-pop-procedure) #f) \ No newline at end of file diff --git a/edwin/doscom.scm b/edwin/doscom.scm new file mode 100644 index 0000000..f18b2a1 --- /dev/null +++ b/edwin/doscom.scm @@ -0,0 +1,108 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Shell commands for DOS + +(declare (usual-integrations)) + +(load-option 'DOSPROCESS) + +(define-command shell-command + "Execute string COMMAND in inferior shell; display output, if any. +Optional second arg true (prefix arg, if interactive) means +insert output in current buffer after point (leave mark after it)." + "sShell command\nP" + (lambda (command insert-at-point?) + (let ((directory (buffer-default-directory (current-buffer)))) + (if insert-at-point? + (begin + (if (buffer-read-only? (current-buffer)) + (barf-if-read-only)) + (let ((point (current-point))) + (push-current-mark! point) + (shell-command false point directory command)) + ((ref-command exchange-point-and-mark))) + (shell-command-pop-up-output + (lambda (output-mark) + (shell-command false output-mark directory command))))))) + +(define-command shell-command-on-region + "Execute string COMMAND in inferior shell with region as input. +Normally display output (if any) in temp buffer; +Prefix arg means replace the region with it." + "r\nsShell command on region\nP" + (lambda (region command replace-region?) + (let ((directory (buffer-default-directory (current-buffer)))) + (if replace-region? + (let ((point (current-point)) + (mark (current-mark))) + (let ((swap? (mark< point mark)) + (temp)) + (dynamic-wind + (lambda () + (set! temp (temporary-buffer " *shell-output*")) + unspecific) + (lambda () + (shell-command (make-region point mark) + (buffer-start temp) + directory + command) + (without-interrupts + (lambda () + (delete-string point mark) + (insert-region (buffer-start temp) + (buffer-end temp) + (current-point))))) + (lambda () + (kill-buffer temp) + (set! temp) + unspecific)) + (if swap? ((ref-command exchange-point-and-mark))))) + (shell-command-pop-up-output + (lambda (output-mark) + (shell-command region output-mark directory command))))))) + +(define (shell-command-pop-up-output generate-output) + (let ((buffer (temporary-buffer "*Shell Command Output*"))) + (let ((start (buffer-start buffer))) + (generate-output start) + (set-buffer-point! buffer start) + (if (mark< start (buffer-end buffer)) + (pop-up-buffer buffer false) + (message "(Shell Command completed with no output)"))))) + +(define (shell-command input-region output-mark directory command) + (with-real-working-directory-pathname directory + (lambda () + (let ((core + (lambda (input-port) + (run-subprocess command + input-port + (mark->output-port output-mark))))) + (if input-region + (core (make-buffer-input-port (region-start input-region) + (region-end input-region))) + (call-with-input-file "\\dev\\nul" core)))))) \ No newline at end of file diff --git a/edwin/dosfile.scm b/edwin/dosfile.scm new file mode 100644 index 0000000..5d2b0dd --- /dev/null +++ b/edwin/dosfile.scm @@ -0,0 +1,568 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; DOS-Syntax File Customizations + +(declare (usual-integrations)) + +(define-variable version-control + "Control use of version numbers for backup files. +#T means make numeric backup versions unconditionally. +#F means make them for files that have some already. +'NEVER means do not make them." + #f + (lambda (object) (or (eq? object 'NEVER) (boolean? object)))) + +(define-variable kept-old-versions + "Number of oldest versions to keep when a new numbered backup is made." + 2 + exact-nonnegative-integer?) + +(define-variable kept-new-versions + "Number of newest versions to keep when a new numbered backup is made. +Includes the new backup. Must be > 0." + 2 + (lambda (n) (and (exact-integer? n) (> n 0)))) + +(define os/encoding-pathname-types + '("gz" "bf" "ky")) + +(define dos/backup-suffixes + (cons "~" + (map (lambda (type) (string-append "~." type)) + os/encoding-pathname-types))) + +(define-variable completion-ignored-extensions + "Completion ignores filenames ending in any string in this list." + (append (list ".bin" ".com" ".ext" + ".inf" ".bif" ".bsm" ".bci" ".bcs" + ".psb" ".moc" ".fni" + ".bco" ".bld" ".bad" ".glo" ".fre" + ".obj" ".exe" ".pif" ".grp" + ".dvi" ".toc" ".log" ".aux") + (list-copy dos/backup-suffixes)) + (lambda (extensions) + (and (list? extensions) + (every (lambda (extension) + (and (string? extension) + (not (string-null? extension)))) + extensions)))) + +;;;; Filename I/O + +(define (os/trim-pathname-string string prefix) + (let ((index (string-match-forward prefix string))) + (if (and index + (or (fix:= index (string-length prefix)) + (and (fix:> index 0) + (or (char=? (string-ref prefix (fix:- index 1)) #\/) + (char=? (string-ref prefix (fix:- index 1)) #\\)))) + (re-substring-match "[\\/$~]\\|[a-zA-Z]:" + string index (string-length string))) + (string-tail string index) + string))) + +(define (os/pathname->display-string pathname) + (or (let ((relative (enough-pathname pathname (user-homedir-pathname)))) + (and (not (pathname-device relative)) + (not (pathname-absolute? relative)) + (string-append "~\\" (->namestring relative)))) + (->namestring pathname))) + +(define (os/truncate-filename-for-modeline filename width) + (let ((length (string-length filename))) + (if (< 0 width length) + (let ((result + (substring + filename + (let ((index (- length width))) + (if (char=? #\\ (string-ref filename index)) + index + (or (substring-find-next-char filename index length #\\) + (fix:+ index 1)))) + length))) + (string-set! result 0 #\$) + result) + filename))) + +(define (os/directory-list directory) + (let ((channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read channel))) + (if name + (loop (cons (string-downcase name) result)) + (begin + (directory-channel-close channel) + result)))))) + +(define (os/directory-list-completions directory prefix) + (let ((channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read-matching channel prefix))) + (if name + (loop (cons (string-downcase name) result)) + (begin + (directory-channel-close channel) + result)))))) + +;;;; Dired customization + +(define-variable dired-listing-switches + "Dired listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "-l" + string?) + +(define-variable list-directory-brief-switches + "list-directory brief listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "" + string?) + +(define-variable list-directory-verbose-switches + "list-directory verbose listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." + "-l" + string?) + +(define (insert-directory! file switches mark type) + ;; Insert directory listing for FILE at MARK. + ;; SWITCHES are examined for the presence of "a" and "t". + ;; TYPE can have one of three values: + ;; 'WILDCARD means treat FILE as shell wildcard. + ;; 'DIRECTORY means FILE is a directory and a full listing is expected. + ;; 'FILE means FILE itself should be listed, and not its contents. + (let ((mark (mark-left-inserting-copy mark)) + (now (get-universal-time))) + (catch-file-errors (lambda (c) + (insert-string (condition/report-string c) mark) + (insert-newline mark)) + (lambda () + (for-each + (lambda (entry) + (insert-string (dos/dired-line-string (car entry) (cdr entry) now) + mark) + (insert-newline mark)) + (if (eq? 'FILE type) + (let ((attributes (file-attributes file))) + (if attributes + (list (cons (file-namestring file) attributes)) + '())) + (sort (dos/read-dired-files file + (string-find-next-char switches #\a)) + (if (string-find-next-char switches #\t) + (lambda (x y) + (> (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y)))) + (lambda (x y) + (string-cistring (file-attributes/length attr)) 10 #\space) + " " + (file-time->ls-string (file-attributes/modification-time attr) now) + " " + name)) + +(define dired-pathname-wild? + pathname-wild?) + +;;;; Backup and Auto-Save Filenames + +(define (os/buffer-backup-pathname truename buffer) + (call-with-values + (lambda () + (if (dos/fs-long-filenames? truename) + (let ((type (pathname-type truename))) + (if (member type os/encoding-pathname-types) + (values (pathname-new-type truename #f) + (string-append "~." type)) + (values truename "~"))) + (values truename ""))) + (lambda (truename suffix) + (if (eq? 'NEVER (ref-variable version-control buffer)) + (values (dos/make-backup-pathname truename #f suffix) '()) + (let ((prefix + (if (dos/fs-long-filenames? truename) + (string-append (file-namestring truename) ".~") + (string-append (pathname-name truename) ".")))) + (let ((backups + (let loop + ((filenames + (os/directory-list-completions + (directory-namestring truename) + prefix)) + (backups '())) + (if (null? filenames) + (sort backups (lambda (x y) (< (cdr x) (cdr y)))) + (loop (cdr filenames) + (let ((root.version + (os/numeric-backup-filename? + (car filenames)))) + (if root.version + (cons (cons (car filenames) + (cdr root.version)) + backups) + backups))))))) + (if (null? backups) + (values (dos/make-backup-pathname + truename + (and (ref-variable version-control buffer) 1) + suffix) + '()) + (values (dos/make-backup-pathname + truename + (+ (apply max (map cdr backups)) 1) + suffix) + (let ((start (ref-variable kept-old-versions buffer)) + (end + (- (length backups) + (- (ref-variable kept-new-versions buffer) + 1)))) + (if (< start end) + (map (let ((dir (directory-pathname truename))) + (lambda (entry) + (merge-pathnames (car entry) dir))) + (sublist backups start end)) + '())))))))))) + +(define (dos/make-backup-pathname pathname version suffix) + (if (dos/fs-long-filenames? pathname) + (string-append (->namestring pathname) + (if version + (string-append ".~" (number->string version) suffix) + suffix)) + (pathname-new-type pathname + (if (and version (< version 1000)) + (let ((type (pathname-type pathname)) + (vs (number->string version))) + (if (and (< version 100) + (string? type) + (not (string-null? type))) + (string-append (substring type 0 1) + (string-pad-left vs 2 #\0)) + (string-pad-left vs 3 #\0))) + "bak")))) + +(define (os/default-backup-filename) + "$TMP\\edwin.bak") + +(define (os/backup-filename? filename) + (or (any (lambda (suffix) + (string-suffix? suffix filename)) + dos/backup-suffixes) + (let ((type (pathname-type filename))) + (and (string? type) + (or (string-ci=? "bak" type) + (re-string-match ".[0-9][0-9]" type)))))) + +(define (os/numeric-backup-filename? filename) + (let ((r + (let ((try + (lambda (pattern) + (re-string-search-forward pattern filename)))) + (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$") + (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$") + (let loop ((suffixes dos/backup-suffixes)) + (and (pair? suffixes) + (or (try (string-append "^\\(.+\\)\\.~\\([0-9]+\\)" + (re-quote-string (car suffixes)) + "$")) + (loop (cdr suffixes))))))))) + (and r + (let ((root-start (re-match-start-index 1 r)) + (root-end (re-match-end-index 1 r)) + (version-start (re-match-start-index 2 r)) + (version-end (re-match-end-index 2 r))) + (let ((version + (substring->number filename version-start version-end))) + (and (> version 0) + (cons (substring filename root-start root-end) + version))))))) + +(define (os/auto-save-filename? filename) + (if (dos/fs-long-filenames? filename) + (re-string-match "^#.+#$" (file-namestring filename)) + (let ((type (pathname-type filename))) + (and (string? type) + (string-ci=? "sav" type))))) + +(define (os/precious-backup-pathname pathname) + (let ((directory (directory-pathname pathname))) + (let loop ((i 0)) + (let ((pathname + (merge-pathnames (string-append "#tmp#" (number->string i)) + directory))) + (if (allocate-temporary-file pathname) + (begin + (deallocate-temporary-file pathname) + pathname) + (loop (+ i 1))))))) + +(define (os/auto-save-pathname pathname buffer) + (let ((pathname + (or pathname + (merge-pathnames (dos/buffer-auto-save-name buffer) + (buffer-default-directory buffer))))) + (if (dos/fs-long-filenames? pathname) + (merge-pathnames (string-append "#" (file-namestring pathname) "#") + (directory-pathname pathname)) + (pathname-new-type pathname "sav")))) + +(define (dos/buffer-auto-save-name buffer) + (string-append + "%" + (let ((directory (buffer-default-directory buffer))) + (cond ((not (dos/fs-long-filenames? directory)) + (let ((name (dos/buffer-short-name buffer char-set:valid-fat))) + (if (string-null? name) + "buffer%" + name))) + ((string-ci=? "hpfs" (car (dos/fs-drive-type directory))) + (dos/buffer-long-name buffer char-set:valid-hpfs)) + (else + (dos/buffer-long-name buffer char-set:valid-windows-long)))))) + +(define (dos/buffer-long-name buffer valid-chars) + (let ((name (buffer-name buffer))) + (let ((length (string-length name))) + (let ((copy (make-string length))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i length)) + (string-set! + copy i + (let ((char (string-ref name i))) + (if (char-in-set? char valid-chars) + char + #\_)))) + copy)))) + +(define (dos/buffer-short-name buffer valid-chars) + (let ((name + (list->string + (let loop ((chars (string->list (buffer-name buffer)))) + (cond ((null? chars) + '()) + ((char-in-set? (car chars) valid-chars) + (cons (car chars) (loop (cdr chars)))) + (else + (loop (cdr chars)))))))) + (let ((n (string-length name))) + (if (fix:<= n 7) + name + (string-head name 7))))) + +(define char-set:valid-hpfs) +(define char-set:valid-windows-long) +(let ((reserved-chars + (char-set-union (string->char-set "\"/:<>\\|") + (string->char-set "*?")))) + (set! char-set:valid-hpfs + (char-set-difference (ucs-range->char-set #x21 #x7F) + reserved-chars)) + (set! char-set:valid-windows-long + (char-set-difference (ucs-range->char-set #x20 #x100) + reserved-chars))) + +(define char-set:valid-fat + (char-set-union char-set:alphanumeric + (string->char-set "!#$%'()-@^_`{}~"))) + +;;;; Miscellaneous + +(define (os/backup-buffer? truename) + (let ((attrs (file-attributes truename))) + (and attrs + (eq? #f (file-attributes/type attrs))))) + +(define (os/backup-by-copying? truename buffer) + truename buffer + #f) + +(define (os/completion-ignore-filename? filename) + (or (os/backup-filename? filename) + (os/auto-save-filename? filename) + (and (not (file-directory? filename)) + (any (lambda (extension) + (string-suffix? extension filename)) + (ref-variable completion-ignored-extensions))))) + +(define (os/init-file-name) "~/edwin.ini") +(define (os/abbrev-file-name) "~/abbrevs.scm") + +(define (os/find-file-initialization-filename pathname) + (or (and (equal? "scm" (pathname-type pathname)) + (let ((pathname (pathname-new-type pathname "ffi"))) + (and (file-exists? pathname) + pathname))) + (let ((pathname + (merge-pathnames "edwin.ffi" (directory-pathname pathname)))) + (and (file-exists? pathname) + pathname)))) + +(define (os/newsrc-file-name server) + (let ((homedir (user-homedir-pathname))) + (if (dos/fs-long-filenames? homedir) + (let ((specific + (merge-pathnames (string-append ".newsrc-" server) homedir))) + (if (file-exists? specific) + specific + (merge-pathnames ".newsrc" homedir))) + (merge-pathnames "newsrc.ini" homedir)))) + +(define (os/info-default-directory-list) + '()) + +;;;; Subprocess/Shell Support + +(define (os/shell-name pathname) + (if (member (pathname-type pathname) (os/executable-pathname-types)) + (pathname-name pathname) + (file-namestring pathname))) + +(define (os/default-shell-args) + '()) + +(define (os/default-shell-prompt-pattern) + "^[^]$]*[]>] *") + +(define (os/comint-filename-region start point end) + (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---")) + (let ((start (skip-chars-backward chars point start))) + (make-region start (skip-chars-forward chars start end))))) + +(define (os/shell-command-separators) + "&|") + +(define (os/shell-command-regexp) + (string-append "[^" (os/shell-command-separators) "\n]+")) + +;;;; File-Encoding Methods + +(define (os/read-file-methods) + `((,read/write-compressed-file? + . ,(lambda (pathname mark visit?) + visit? + (read-compressed-file "gzip" '("-d") pathname mark))) + ,@(os-independent/read-file-methods))) + +(define (os/write-file-methods) + `((,read/write-compressed-file? + . ,(lambda (region pathname visit?) + visit? + (write-compressed-file "gzip" '() region pathname))) + ,@(os-independent/write-file-methods))) + +(define (os/alternate-pathnames group pathname) + (if (dos/fs-long-filenames? pathname) + (append (if (and (ref-variable enable-compressed-files group) + (not (equal? "gz" (pathname-type pathname)))) + (list (string-append (->namestring pathname) ".gz")) + '()) + (os-independent/alternate-pathnames group pathname)) + '())) + +;;;; Compressed Files + +(define-variable enable-compressed-files + "If true, compressed files are automatically uncompressed when read, +and recompressed when written. A compressed file is identified by the +filename suffix \".gz\"." + #t + boolean?) + +(define (read/write-compressed-file? group pathname) + (and (ref-variable enable-compressed-files group) + (equal? "gz" (pathname-type pathname)))) + +(define (read-compressed-file program arguments pathname mark) + ((message-wrapper #f "Uncompressing file " (->namestring pathname)) + (lambda () + (call-with-temporary-file-pathname + (lambda (temporary) + (if (not (equal? '(EXITED . 0) + (shell-command #f #f + (directory-pathname pathname) + #f + (string-append + (quote-program program arguments) + " < " + (file-namestring pathname) + " > " + (->namestring temporary))))) + (error:file-operation 0 + program + "file" + "[unknown]" + read-compressed-file + (list pathname mark))) + (group-insert-file! (mark-group mark) + (mark-index mark) + temporary)))))) + +(define (write-compressed-file program arguments region pathname) + ((message-wrapper #f "Compressing file " (->namestring pathname)) + (lambda () + (if (not (equal? + '(EXITED . 0) + (shell-command region + #f + (directory-pathname pathname) + #f + (string-append (quote-program program arguments) + " > " + (file-namestring pathname))))) + (error:file-operation 1 + program + "file" + "[unknown]" + write-compressed-file + (list region pathname)))))) + +(define (quote-program program arguments) + (string-append (if (eq? 'NT microcode-id/operating-system) + (string-append "\"" (os/find-program program #f) "\"") + program) + (apply string-append + (map (lambda (argument) + (string-append " " argument)) + arguments)))) \ No newline at end of file diff --git a/edwin/dosproc.scm b/edwin/dosproc.scm new file mode 100644 index 0000000..082910f --- /dev/null +++ b/edwin/dosproc.scm @@ -0,0 +1,57 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Dummy subprocess support +;; package: (edwin process) + +(declare (usual-integrations)) + +(define subprocesses-available? + #f) + +(define (process-list) + '()) + +(define (get-buffer-process buffer) + buffer + #f) + +(define (buffer-processes buffer) + buffer + '()) + +(define (process-operation name) + (lambda (process) + (editor-error "Processes not implemented" name process))) + +(define delete-process + (process-operation 'DELETE-PROCESS)) + +(define (process-status-changes?) + #f) + +(define (process-output-available?) + #f) \ No newline at end of file diff --git a/edwin/dosshell.scm b/edwin/dosshell.scm new file mode 100644 index 0000000..b40cbe9 --- /dev/null +++ b/edwin/dosshell.scm @@ -0,0 +1,329 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Pseudo Shell subprocess in a buffer +;;; Inspired by "cmushell.el", by Olin Shivers. + +(declare (usual-integrations)) + +(load-option 'DOSPROCESS) + +(define-major-mode pseudo-shell fundamental "Pseudo Shell" + "Major mode for executing DOS commands. +Return executes the current line as a DOS command. +Output is inserted into the buffer after the command. +There is currently no way to send input interactively to the command. +Use \\[shell-command-on-region] to feed input to the command. + +cd, pushd, and popd commands are not executed as commands (they would have +no effect) but emulated directly by Edwin. + +Customization: Entry to this mode runs the hook pseudo-shell-mode-hook." + (lambda (buffer) + (define-variable-local-value! buffer + (ref-variable-object pseudo-shell-dirstack) + '()) + (define-variable-local-value! buffer + (ref-variable-object pseudo-shell-dirtrack?) + true) + (define-variable-local-value! buffer + (ref-variable-object comint-input-ring) + (make-ring (ref-variable comint-input-ring-size))) + (define-variable-local-value! buffer + (ref-variable-object comint-last-input-match) + false) + (define-variable-local-value! buffer + (ref-variable-object pseudo-shell-active?) + true) + (event-distributor/invoke! (ref-variable pseudo-shell-mode-hook) + buffer))) + +(define-variable pseudo-shell-mode-hook + "An event distributor that is invoked when entering Pseudo Shell mode." + (make-event-distributor)) + +(define-variable pseudo-shell-active? + "Is this shell buffer active?" + false + boolean?) + +(define-key 'pseudo-shell #\C-a 'pseudo-shell-bol) +(define-key 'pseudo-shell #\C-m 'pseudo-shell-execute-command) + +(define-key 'pseudo-shell #\M-p 'comint-previous-input) +(define-key 'pseudo-shell #\M-n 'comint-next-input) +(define-key 'pseudo-shell '(#\C-c #\C-r) 'comint-history-search-backward) +(define-key 'pseudo-shell '(#\C-c #\C-s) 'comint-history-search-forward) +(define-key 'pseudo-shell '(#\C-c #\C-w) 'backward-kill-word) + +;; (define-key 'pseudo-shell #\tab 'comint-dynamic-complete) +;; (define-key 'pseudo-shell #\M-? 'comint-dynamic-list-completions) + +(define-command shell + "Run an inferior pseudo shell, with I/O through buffer *shell*. +With prefix argument, unconditionally create a new buffer. +If buffer exists, just switch to buffer *shell*. + +The buffer is put in Pseudo Shell mode, giving commands for sending input +and tracking directories." + "P" + (lambda (new-buffer?) + (let ((buffer + (cond ((and (not new-buffer?) + (find-buffer "*shell*")) + => (lambda (buffer) + (let ((end (buffer-end buffer))) + (if (or (mark= end (line-start end 0)) + (not (mark= end + (pseudo-shell-line-start end)))) + (begin + (buffer-freshline buffer) + (insert-pseudo-shell-prompt! + (buffer-end buffer))))) + buffer)) + (else + (let ((buffer (create-buffer "*shell*"))) + (insert-pseudo-shell-prompt! (buffer-start buffer)) + (set-buffer-major-mode! buffer + (ref-mode-object pseudo-shell)) + (set-buffer-default-directory! + buffer + (buffer-default-directory (current-buffer))) + buffer))))) + + (set-buffer-point! buffer (buffer-end buffer)) + (define-variable-local-value! buffer + (ref-variable-object pseudo-shell-active?) + true) + (select-buffer buffer)))) + +(define (insert-pseudo-shell-prompt! #!optional point) + ;; This corresponds to the $p$g prompt pattern. + (insert-string (string-append + (pseudo-directory-namestring + (buffer-default-directory (current-buffer))) + ">") + (if (default-object? point) + (current-point) + point))) + +(define (pseudo-directory-namestring dir) + (string-upcase + (->namestring + (directory-pathname-as-file dir)))) + +(define-command pseudo-shell-bol + "Goes to the beginning of line, then skips past the prompt, if any. +With argument, don't skip the prompt -- go straight to column 0." + "P" + (lambda (argument) + (set-current-point! + (if argument + (line-start (current-point) 0) + (pseudo-shell-line-start (current-point)))))) + +(define (pseudo-shell-line-start mark) + (let ((start (line-start mark 0))) + (let ((mark (search-forward ">" start (line-end start 0)))) + (if (and mark (mark<= mark (line-end start 0))) + mark + start)))) + +(define-command pseudo-shell-execute-command + "Execute the command on the current line." + () + (lambda () + (let ((point (current-point)) + (buffer (current-buffer))) + (let ((start (pseudo-shell-line-start point)) + (end (line-end point 0))) + (let ((command (extract-string start end))) + (ring-push! (ref-variable comint-input-ring) + command) + (if (not (mark= end (buffer-end buffer))) + (begin + (buffer-freshline buffer) + (insert-region (line-start start 0) end + (buffer-end buffer)))) + (buffer-freshline buffer) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (pseudo-execute command + (buffer-default-directory buffer) + (buffer-end buffer)) + (insert-newline (buffer-end buffer))) + (lambda () + (if (ref-variable pseudo-shell-active? buffer) + (begin + (buffer-freshline buffer) + (insert-pseudo-shell-prompt! (buffer-end buffer)) + (set-buffer-point! buffer (buffer-end buffer))))))))))) + +(define (buffer-freshline buffer) + (let* ((end (buffer-end buffer)) + (start (line-start end 0))) + (if (not (mark= start end)) + (insert-newline end)))) + +(define (pseudo-execute command dir output-mark) + (let* ((command (string-trim command)) + (next (string-find-next-char-in-set command char-set:whitespace)) + (prog (if (not next) + command + (substring command 0 next)))) + (let ((handler (assoc (string-downcase prog) pseudo-shell-builtins))) + (if (not handler) + (shell-command false output-mark dir command) + ((cdr handler) prog + (if (not next) + "" + (string-trim-left + (substring command (1+ next) + (string-length command)))) + dir + output-mark))))) + +(define-variable pseudo-shell-dirstack + "List of directories saved by pushd in this buffer's shell." + '()) + +(define-variable pseudo-shell-dirtrack? "" false) + +(define (pseudo-parse-directory dir prog args) + (cond ((string-null? args) + false) + ((string-find-next-char-in-set args char-set:whitespace) + (pseudo-error "Too many arguments" prog args)) + (else + (let ((dir (merge-pathnames args dir))) + (if (not (file-directory? dir)) + (pseudo-error "Not a directory" prog args)) + (pathname-simplify (pathname-as-directory dir)))))) + +(define (pseudo-error string . strings) + (apply editor-error string + (map (lambda (string) + (string-append " " string)) + strings))) + +(define pseudo-shell-builtins + (let ((cd (lambda (prog args dir output-mark) + (if (not (ref-variable pseudo-shell-dirtrack?)) + (editor-error "Not tracking directories")) + (let ((dir + (or (pseudo-parse-directory dir prog args) + (let ((home (get-environment-variable "HOME"))) + (if (not home) + (pseudo-error "Unknown home:" prog) + (pathname-simplify + (pathname-as-directory + (merge-pathnames home dir)))))))) + (set-default-directory dir) + (insert-string + (string-append (pseudo-directory-namestring dir) + "\n") + output-mark)))) + + (show-dirs + (lambda (dir output-mark) + (with-output-to-mark output-mark + (lambda () + (write-char #\() + (write-string (pseudo-directory-namestring dir)) + (let loop ((dirs (ref-variable pseudo-shell-dirstack))) + (if (null? dirs) + (begin + (write-char #\)) + (write-char #\Newline)) + (begin + (write-char #\Space) + (write-string (pseudo-directory-namestring (car dirs))) + (loop (cdr dirs)))))))))) + + `(("" + . ,(lambda (prog args dir output-mark) + prog args dir output-mark ; ignored + (message "Empty command line") + (editor-beep))) + + ("cd" . ,cd) + + ("pushd" + . ,(lambda (prog args dir output-mark) + (if (not (ref-variable pseudo-shell-dirtrack?)) + (editor-error "Not tracking directories")) + (let ((dir* (pseudo-parse-directory dir prog args)) + (stack (ref-variable pseudo-shell-dirstack))) + (cond (dir* + (set-variable! pseudo-shell-dirstack (cons dir stack)) + (set-default-directory dir*) + (show-dirs dir* output-mark)) + ((null? stack) + (pseudo-error "Empty directory stack:" prog)) + (else + (let ((dir* (car stack))) + (set-variable! pseudo-shell-dirstack + (cons dir (cdr stack))) + (set-default-directory dir*) + (show-dirs dir* output-mark))))))) + + ("popd" + . ,(lambda (prog args dir output-mark) + dir ; ignored + (if (not (ref-variable pseudo-shell-dirtrack?)) + (editor-error "Not tracking directories")) + (if (not (string-null? args)) + (pseudo-error "Too many arguments:" prog) + (let ((stack (ref-variable pseudo-shell-dirstack))) + (if (null? stack) + (pseudo-error "Directory stack is empty:" prog) + (let ((dir (car stack))) + (set-variable! pseudo-shell-dirstack (cdr stack)) + (set-default-directory dir) + (insert-string + (string-append (pseudo-directory-namestring dir) + "\n") + output-mark))))))) + + ("dirs" + . ,(lambda (prog args dir output-mark) + (if (not (ref-variable pseudo-shell-dirtrack?)) + (editor-error "Not tracking directories")) + (if (not (string-null? args)) + (pseudo-error "Too many arguments:" prog)) + (show-dirs dir output-mark))) + + ("cwd" . ,cd) + + ("exit" + . ,(lambda (prog args dir output-mark) + prog args dir ; ignored + (define-variable-local-value! (mark-buffer output-mark) + (ref-variable-object pseudo-shell-active?) + false) + (message "Pseudo exitted")))))) \ No newline at end of file diff --git a/edwin/ed-ffi.scm b/edwin/ed-ffi.scm new file mode 100644 index 0000000..7bb1555 --- /dev/null +++ b/edwin/ed-ffi.scm @@ -0,0 +1,188 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +(declare (usual-integrations)) + +;; This list must be kept in alphabetical order by filename. + +(standard-scheme-find-file-initialization + '#(("abbrev" (edwin)) + ("adapters" (edwin adapters)) + ("ansi" (edwin screen console-screen)) + ("argred" (edwin command-argument)) + ("artdebug" (edwin debugger)) + ("autold" (edwin)) + ("autosv" (edwin)) + ("basic" (edwin)) + ("bios" (edwin screen console-screen)) + ("bufcom" (edwin)) + ("buffer" (edwin)) + ("buffrm" (edwin window)) + ("bufinp" (edwin buffer-input-port)) + ("bufmnu" (edwin buffer-menu)) + ("bufout" (edwin buffer-output-port)) + ("bufset" (edwin)) + ("bufwfs" (edwin window)) + ("bufwin" (edwin window)) + ("bufwiu" (edwin window)) + ("bufwmc" (edwin window)) + ("c-mode" (edwin)) + ("calias" (edwin)) + ("cinden" (edwin c-indentation)) + ("class" (edwin)) + ("clscon" (edwin class-constructor)) + ("clsmac" (edwin class-macros)) + ("comhst" (edwin)) + ("comint" (edwin)) + ("comatch" (edwin)) + ("comman" (edwin)) + ("compile" (edwin)) + ("comred" (edwin command-reader)) + ("comtab" (edwin comtab)) + ("comwin" (edwin window combination)) + ("curren" (edwin)) + ("dabbrev" (edwin)) + ("debian-changelog" (edwin debian-changelog)) + ("debug" (edwin debugger)) + ("debuge" (edwin)) + ("diff" (edwin diff)) + ("dired" (edwin dired)) + ("dirunx" (edwin dired)) + ("dirw32" (edwin dired)) + ("display" (edwin display-type)) + ("docstr" (edwin)) + ("dos" (edwin)) + ("doscom" (edwin dosjob)) + ("dosfile" (edwin)) + ("dosproc" (edwin process)) + ("dosshell" (edwin dosjob)) + ("editor" (edwin)) + ("edtfrm" (edwin window)) + ("edtstr" (edwin)) + ("evlcom" (edwin)) + ("eystep" (edwin stepper)) + ("filcom" (edwin)) + ("fileio" (edwin)) + ("fill" (edwin)) + ("grpops" (edwin group-operations)) + ("hlpcom" (edwin)) + ("htmlmode" (edwin)) + ("image" (edwin)) + ("info" (edwin info)) + ("input" (edwin keyboard)) + ("intmod" (edwin inferior-repl)) + ("iserch" (edwin incremental-search)) + ("javamode" (edwin)) + ("key-w32" (edwin win32-keys)) + ("keymap" (edwin command-summary)) + ("keyparse" (edwin keyparser)) + ("kilcom" (edwin)) + ("kmacro" (edwin)) + ("lincom" (edwin)) + ("linden" (edwin lisp-indentation)) + ("loadef" (edwin)) + ("lspcom" (edwin)) + ("macros" (edwin macros)) + ("make" ()) + ("malias" (edwin mail-alias)) + ("manual" (edwin)) + ("midas" (edwin)) + ("modefs" (edwin)) + ("modes" (edwin)) + ("modlin" (edwin modeline-string)) + ("modwin" (edwin window)) + ("motcom" (edwin)) + ("motion" (edwin)) + ("mousecom" (edwin)) + ("nntp" (edwin nntp)) + ("notify" (edwin)) + ("nvector" (edwin)) + ("occur" (edwin occurrence)) + ("outline" (edwin)) + ("paredit" (edwin paredit)) + ("pasmod" (edwin)) + ("paths" (edwin)) + ("print" (edwin)) + ("process" (edwin process)) + ("prompt" (edwin prompt)) + ("pwedit" (edwin password-edit)) + ("pwparse" (edwin password-edit)) + ("rcsparse" (edwin rcs-parse)) + ("reccom" (edwin rectangle)) + ("regcom" (edwin register-command)) + ("regexp" (edwin regular-expression)) + ("regops" (edwin)) + ("replaz" (edwin)) + ("rfc822" (edwin rfc822)) + ("ring" (edwin)) + ("rmail" (edwin rmail)) + ("rmailsrt" (edwin rmail)) + ("rmailsum" (edwin rmail)) + ("schmod" (edwin)) + ("scrcom" (edwin)) + ("screen" (edwin screen)) + ("search" (edwin)) + ("sendmail" (edwin sendmail)) + ("sercom" (edwin)) + ("shell" (edwin)) + ("simple" (edwin)) + ("snr" (edwin news-reader)) + ("sort" (edwin)) + ("string" (edwin string)) + ("strpad" (edwin)) + ("strtab" (edwin)) + ("struct" (edwin)) + ("syntax" (edwin)) + ("tagutl" (edwin tags)) + ("techinfo" (edwin)) + ("telnet" (edwin)) + ("termcap" (edwin screen console-screen)) + ("texcom" (edwin)) + ("things" (edwin)) + ("tparse" (edwin)) + ("tterm" (edwin screen console-screen)) + ("tximod" (edwin)) + ("txtprp" (edwin text-properties)) + ("undo" (edwin undo)) + ("unix" (edwin)) + ("utils" (edwin)) + ("utlwin" (edwin window)) + ("vc" (edwin vc)) + ("vc-bzr" (edwin vc)) + ("vc-cvs" (edwin vc)) + ("vc-git" (edwin vc)) + ("vc-rcs" (edwin vc)) + ("vc-svn" (edwin vc)) + ("verilog" (edwin verilog)) + ("vhdl" (edwin vhdl)) + ("webster" (edwin)) + ("win32" (edwin screen win32)) + ("win32com" (edwin win-commands)) + ("wincom" (edwin)) + ("window" (edwin window)) + ("winout" (edwin window-output-port)) + ("xform" (edwin class-macros transform-instance-variables)) + ("xterm" (edwin screen x-screen)))) \ No newline at end of file diff --git a/edwin/editor.scm b/edwin/editor.scm new file mode 100644 index 0000000..51888bd --- /dev/null +++ b/edwin/editor.scm @@ -0,0 +1,663 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Editor Top Level + +(declare (usual-integrations)) + +(define (edit . args) + (call-with-current-continuation + (lambda (continuation) + (cond (within-editor? + (error "edwin: Editor already running")) + ((not edwin-editor) + (apply create-editor args)) + ((not (null? args)) + (error "edwin: Arguments ignored when re-entering editor" args)) + (edwin-continuation + => (lambda (restart) + (set! edwin-continuation #f) + (within-continuation restart + (lambda () + (set! editor-abort continuation) + unspecific))))) + (fluid-let ((editor-abort continuation) + (current-editor edwin-editor) + (within-editor? #t) + (editor-thread (current-thread)) + (editor-thread-root-continuation) + (editor-initial-threads '()) + (inferior-thread-changes? #f) + (inferior-threads '()) + (recursive-edit-continuation #f) + (recursive-edit-level 0)) + (thread-put! editor-thread 'name edwin-editor) + (editor-grab-display edwin-editor + (lambda (with-editor-ungrabbed operations) + (let ((message (cmdl-message/null))) + (cmdl/start + (make-cmdl + (nearest-cmdl) + dummy-i/o-port + (lambda (cmdl) + cmdl ;ignore + (bind-condition-handler (list condition-type:error) + internal-error-handler + (lambda () + (call-with-current-continuation + (lambda (root-continuation) + (set! editor-thread-root-continuation + root-continuation) + (parameterize ((notification-output-port + null-output-port)) + (do ((thunks (let ((thunks editor-initial-threads)) + (set! editor-initial-threads '()) + thunks) + (cdr thunks))) + ((null? thunks)) + (create-thread root-continuation + (car thunks) + (car thunks))) + (top-level-command-reader edwin-initialization)))))) + message) + #f + `((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed)) + (CHILD-PORT ,(editor-child-cmdl-port (nearest-cmdl/port))) + ,@operations)) + message)))))))) + +(define edwin-editor #f) +(define editor-abort) +(define current-editor) +(define within-editor? #f) +(define editor-thread) +(define editor-thread-root-continuation) +(define editor-initial-threads) +(define edwin-continuation) + +;; Set this before entering the editor to get something done after the +;; editor's dynamic environment is initialized, but before the command +;; loop is started. +(define edwin-initialization #f) + +(define (queue-initial-thread thunk) + (set! editor-initial-threads (cons thunk editor-initial-threads)) + unspecific) + +(define create-editor-args + '()) + +(define (create-editor . args) + (let ((args + (if (null? args) + create-editor-args + (begin + (set! create-editor-args args) + args)))) + (reset-editor) + (event-distributor/invoke! editor-initializations) + (set! edwin-editor + (make-editor "Edwin" + (let ((name (and (not (null? args)) (car args)))) + (if name + (let ((type (name->display-type name))) + (if (not type) + (error "Unknown display type name:" name)) + (if (not (display-type/available? type)) + (error "Requested display type unavailable:" + type)) + type) + (default-display-type '()))) + (if (null? args) '() (cdr args)))) + (set! edwin-initialization + (lambda () + (set! edwin-initialization #f) + (standard-editor-initialization))) + (set! edwin-continuation #f) + unspecific)) + +(define editor-initializations + (make-event-distributor)) + +(define (default-display-type preferences) + (define (fail) + (error "Can't find any usable display type")) + + (define (find-any) + (let ((types (editor-display-types))) + (if (null? types) + (fail) + (car types)))) + + (define (find-preferred display-type-names) + (if (null? display-type-names) + (find-any) + (let ((next (name->display-type (car display-type-names)))) + (if (and next + (display-type/available? next)) + next + (find-preferred (cdr display-type-names)))))) + + (find-preferred preferences)) + +(define (standard-editor-initialization) + (with-editor-interrupts-disabled + (lambda () + (if (and (not init-file-loaded?) + (not inhibit-editor-init-file?)) + (begin + (let ((filename (os/init-file-name))) + (if (file-exists? filename) + (load-edwin-file filename '(EDWIN) #t))) + (set! init-file-loaded? #t) + unspecific)))) + (let ((buffer (find-buffer initial-buffer-name))) + (if (and buffer + (not inhibit-initial-inferior-repl?)) + (start-inferior-repl! + buffer + (nearest-repl/environment) + (and (not (ref-variable inhibit-startup-message)) + (cmdl-message/append + (cmdl-message/active + (lambda (port) + (identify-world port) + (newline port))) + (cmdl-message/strings + "You are in an interaction window of the Edwin editor." + "Type `C-h' for help, or `C-h t' for a tutorial." + "`C-h m' will describe some commands." + "`C-h' means: hold down the Ctrl key and type `h'."))))))) + +(define inhibit-editor-init-file? #f) +(define init-file-loaded? #f) +(define inhibit-initial-inferior-repl? #f) + +(define-variable inhibit-startup-message + "True inhibits the initial startup messages. +This is for use in your personal init file, once you are familiar +with the contents of the startup message." + #f + boolean?) + +(define (reset-editor) + (without-interrupts + (lambda () + (if edwin-editor + (begin + (for-each (lambda (screen) + (screen-discard! screen)) + (editor-screens edwin-editor)) + (set! edwin-editor #f) + (set! edwin-continuation) + (set! init-file-loaded? #f) + (weak-set-car! *previous-popped-up-window* #f) + (weak-set-car! *previous-popped-up-buffer* #f) + (weak-set-car! *minibuffer-scroll-window* #f) + unspecific))))) + +(define (reset-editor-windows) + (for-each (lambda (screen) + (send (screen-root-window screen) ':salvage!)) + (editor-screens edwin-editor))) + +(define (enter-recursive-edit) + (let ((value + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((recursive-edit-continuation continuation) + (recursive-edit-level (1+ recursive-edit-level))) + (let ((recursive-edit-event! + (lambda () + (for-each (lambda (window) + (window-modeline-event! window + 'RECURSIVE-EDIT)) + (window-list))))) + (dynamic-wind recursive-edit-event! + command-reader + recursive-edit-event!))))))) + (if (eq? value 'ABORT) + (abort-current-command) + (begin + (reset-command-prompt!) + value)))) + +(define (exit-recursive-edit value) + (if recursive-edit-continuation + (recursive-edit-continuation value) + (editor-error "No recursive edit is in progress"))) + +(define recursive-edit-continuation) +(define recursive-edit-level) + +(define (editor-gc-daemon) + (let ((editor edwin-editor)) + (if editor + (do ((buffers (bufferset-buffer-list (editor-bufferset editor)) + (cdr buffers))) + ((null? buffers)) + (clean-group-marks! (buffer-group (car buffers))))))) + +(add-gc-daemon!/no-restore editor-gc-daemon) +(add-event-receiver! event:after-restore editor-gc-daemon) + +;;;; Error handling + +(define (internal-error-handler condition) + (cond ((and (eq? condition-type:primitive-procedure-error + (condition/type condition)) + (let ((operator (access-condition condition 'OPERATOR))) + (or (eq? operator (ucode-primitive x-display-process-events 2)) + (eq? operator (ucode-primitive x-display-flush 1))))) + ;; This error indicates that the connection to the X server + ;; has been broken. The safest thing to do is to kill the + ;; editor. + (exit-editor)) + (debug-internal-errors? + (error condition)) + (else + (maybe-debug-scheme-error 'INTERNAL condition)))) + +(define (maybe-debug-scheme-error error-type condition) + (let ((p + (variable-default-value + (or (name->variable (symbol 'DEBUG-ON- error-type '-ERROR) #f) + (ref-variable-object debug-on-internal-error))))) + (if p + (debug-scheme-error error-type condition (eq? p 'ASK)))) + (standard-error-report error-type condition #f) + (editor-beep) + (return-to-command-loop condition)) + +(define-variable debug-on-internal-error + "True means enter debugger if an internal error is signalled. +False means ignore the error and resume editing (this is the default value). +The symbol ASK means ask what to do. +This does not affect editor errors or evaluation errors." + #f + (lambda (x) (or (boolean? x) (eq? x 'ASK)))) + +(define debug-internal-errors? #f) + +(define condition-type:editor-error + (make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS) + (lambda (condition port) + (write-string (message-args->string (editor-error-strings condition)) + port)))) + +(define editor-error + (let ((signaller + (condition-signaller condition-type:editor-error + '(STRINGS) + standard-error-handler))) + (lambda strings + (signaller strings)))) + +(define editor-error-strings + (condition-accessor condition-type:editor-error 'STRINGS)) + +(define (editor-error-handler condition) + (maybe-debug-scheme-error 'EDITOR condition)) + +(define-variable debug-on-editor-error + "True means enter debugger if an editor error is signalled. +False means ignore the error and resume editing (this is the default value). +The symbol ASK means ask what to do. +This does not affect internal errors or evaluation errors." + #f + (lambda (x) (or (boolean? x) (eq? x 'ASK)))) + +(define (standard-error-report error-type condition in-prompt?) + (let ((type-string + (string-append (string-capitalize (symbol->string error-type)) + " error")) + (report-string (condition/report-string condition)) + (get-error-buffer + (lambda strings + (string->temporary-buffer (apply string-append strings) + "*error*" + '(SHRINK-WINDOW))))) + (let ((typein-report + (lambda () + (if (eq? error-type 'EDITOR) + (message report-string) + (message type-string ": " report-string)))) + (error-buffer-report + (lambda () + (if in-prompt? + (if (eq? error-type 'EDITOR) + (get-error-buffer report-string) + (get-error-buffer type-string ":\n" report-string)) + (begin + (get-error-buffer report-string) + (message type-string))) + (update-screens! #f))) + (transcript-report + (lambda () + (and (ref-variable enable-transcript-buffer) + (begin + (with-output-to-transcript-buffer + (lambda () + (fresh-line) + (write-string ";") + (write-string type-string) + (write-string ": ") + (write-string report-string) + (newline) + (newline))) + #t))))) + (let ((fit-report + (lambda () + (if (and (not in-prompt?) + (not (string-find-next-char report-string #\newline)) + (< (string-columns report-string 0 8 + (ref-variable char-image-strings + #f)) + (window-x-size (typein-window)))) + (typein-report) + (error-buffer-report))))) + (case (ref-variable error-display-mode) + ((STANDARD) (transcript-report) (fit-report)) + ((TRANSCRIPT) (or (transcript-report) (fit-report))) + ((ERROR-BUFFER) (error-buffer-report)) + ((TYPEIN) (if in-prompt? (error-buffer-report) (typein-report))) + ((FIT) (fit-report))))))) + +(define-variable error-display-mode + "Value of this variable controls the way evaluation error messages +are displayed: +STANDARD like FIT, except messages also appear in transcript buffer, + if it is enabled (this is the default value). +FIT messages appear in typein window if they fit; + in \"*error*\" buffer if they don't. +TYPEIN messages appear in typein window. +ERROR-BUFFER messages appear in \"*error*\" buffer. +TRANSCRIPT messages appear in transcript buffer, if it is enabled; + otherwise this is the same as FIT." + 'STANDARD + (lambda (value) (memq value '(STANDARD TRANSCRIPT ERROR-BUFFER TYPEIN FIT)))) + +;;;; Abort and quit + +(define condition-type:abort-current-command + (make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT) + (lambda (condition port) + (write-string "Abort current command" port) + (let ((input (abort-current-command/input condition))) + (if input + (begin + (write-string " with input: " port) + (write input port)))) + (write-string "." port)))) + +(define condition/abort-current-command? + (condition-predicate condition-type:abort-current-command)) + +(define abort-current-command/input + (condition-accessor condition-type:abort-current-command 'INPUT)) + +(define abort-current-command + (let ((signaller + (condition-signaller condition-type:abort-current-command + '(INPUT) + standard-error-handler))) + (lambda (#!optional input) + (let ((input (if (default-object? input) #f input))) + (if (not (or (not input) (input-event? input))) + (error:wrong-type-argument input "input event" + 'ABORT-CURRENT-COMMAND)) + (signaller input))))) + +(define-structure (input-event + (constructor make-input-event (type operator . operands)) + (conc-name input-event/) + (print-procedure + (standard-print-method 'input-event + (lambda (event) + (list (input-event/type event)))))) + (type #f read-only #t) + (operator #f read-only #t) + (operands #f read-only #t)) + +(define (apply-input-event input-event) + (if (not (input-event? input-event)) + (error:wrong-type-argument input-event "input event" apply-input-event)) + (apply (input-event/operator input-event) + (input-event/operands input-event))) + +(define condition-type:^G + (make-condition-type '^G condition-type:abort-current-command '() + (lambda (condition port) + condition + (write-string "Signal editor ^G." port)))) + +(define condition/^G? + (condition-predicate condition-type:^G)) + +(define ^G-signal + (let ((signaller + (condition-signaller condition-type:^G + '(INPUT) + standard-error-handler))) + (lambda () + (signaller #f)))) + +(define (quit-editor-and-signal-error condition) + (quit-editor-and (lambda () (error condition)))) + +(define (quit-editor) + (quit-editor-and (lambda () *the-non-printing-object*))) + +(define (quit-scheme) + (let ((dir (buffer-default-directory (current-buffer)))) + (quit-editor-and (lambda () (os/quit dir) (edit))))) + +(define (quit-editor-and thunk) + (call-with-current-continuation + (lambda (continuation) + (within-continuation editor-abort + (lambda () + (set! edwin-continuation continuation) + (thunk)))))) + +(define (exit-editor) + (within-continuation editor-abort reset-editor)) + +(define (exit-scheme) + (within-continuation editor-abort exit)) + +(define (editor-grab-display editor receiver) + (display-type/with-display-grabbed (editor-display-type editor) + (lambda (with-display-ungrabbed operations) + (with-current-local-bindings! + (lambda () + (let ((enter + (lambda () + (let ((screen (selected-screen))) + (screen-enter! screen) + (update-screen! screen #t)))) + (exit + (lambda () + (screen-exit! (selected-screen))))) + (dynamic-wind enter + (lambda () + (receiver + (lambda (thunk) + (dynamic-wind exit + (lambda () + (with-display-ungrabbed thunk)) + enter)) + operations)) + exit))))))) + +(define dummy-i/o-port + (make-port (make-port-type + (map (lambda (name) + (list name + (lambda (port . ignore) + ignore + (error "Attempt to perform a" + name + (error-irritant/noise + " operation on dummy I/O port:") + port)))) + '(CHAR-READY? READ-CHAR WRITE-CHAR)) + #f) + #f)) + +(define null-output-port + (make-port (make-port-type + `((WRITE-CHAR ,(lambda (port char) + port char + ;; Return the number of characters written. + 1))) + #f) + #f)) + +(define (editor-start-child-cmdl with-editor-ungrabbed) + (lambda (cmdl thunk) cmdl (with-editor-ungrabbed thunk))) + +(define (editor-child-cmdl-port port) + (lambda (cmdl) cmdl port)) + +;;;; Inferior threads + +(define inferior-thread-changes?) +(define inferior-threads) + +(define (register-inferior-thread! thread output-processor) + (let ((flags (cons #f output-processor))) + (without-interrupts + (lambda () + (set! inferior-threads + (cons (weak-cons thread flags) + inferior-threads)) + unspecific)) + flags)) + +(define (deregister-inferior-thread! flags) + (without-interrupts + (lambda () + (let loop ((threads inferior-threads) (prev #f)) + (if (pair? threads) + (if (eq? flags (weak-cdr (car threads))) + (begin + (if prev + (set-cdr! prev (cdr threads)) + (set! inferior-threads (cdr threads))) + (weak-set-car! (car threads) #f) + (weak-set-cdr! (car threads) #f)) + (loop (cdr threads) threads))))))) + +(define (start-standard-polling-thread interval output-processor + #!optional name) + (let ((holder (list #f))) + (set-car! holder + (register-inferior-thread! + (let ((thread + (create-thread editor-thread-root-continuation + (lambda () + (do () (#f) + (let ((registration (car holder))) + (cond ((eq? registration 'KILL-THREAD) + (exit-current-thread unspecific)) + (registration + (inferior-thread-output! registration)))) + (sleep-current-thread interval))) + name))) + (detach-thread thread) + thread) + output-processor)) + holder)) + +(define (stop-standard-polling-thread holder) + (without-interrupts + (lambda () + (let ((registration (car holder))) + (if (and registration (not (eq? registration 'KILL-THREAD))) + (deregister-inferior-thread! registration))) + (set-car! holder 'KILL-THREAD)))) + +(define (inferior-thread-output! flags) + (without-interrupts (lambda () (inferior-thread-output!/unsafe flags)))) + +(define (inferior-thread-output!/unsafe flags) + (set-car! flags #t) + (if (not inferior-thread-changes?) + (begin + (set! inferior-thread-changes? #t) + (signal-thread-event editor-thread #f)))) + +(define (inferior-thread-run-light! flags) + (set-car! flags #t) + (if (not inferior-thread-changes?) + (set! inferior-thread-changes? #t))) + +(define (accept-thread-output) + (with-interrupt-mask interrupt-mask/gc-ok + (lambda (interrupt-mask) + (and inferior-thread-changes? + (begin + (set! inferior-thread-changes? #f) + (let loop ((threads inferior-threads) (prev #f) (output? #f)) + (if (null? threads) + output? + (let ((record (car threads)) + (next (cdr threads))) + (let ((thread (weak-car record)) + (flags (weak-cdr record))) + (if (and (thread? thread) + (not (thread-dead? thread))) + (loop next + threads + (if (car flags) + (begin + (set-car! flags #f) + (let ((result + (invoke-thread-output-processor + (cdr flags) + interrupt-mask))) + (if (eq? output? 'FORCE-RETURN) + output? + (or result output?)))) + output?)) + (begin + (if prev + (set-cdr! prev next) + (set! inferior-threads next)) + (loop next prev output?)))))))))))) + +(define (invoke-thread-output-processor processor interrupt-mask) + (call-with-current-continuation + (lambda (k) + (with-restart 'ABORT "Return to ACCEPT-THREAD-OUTPUT." + (lambda () (k #t)) + values + (lambda () + (with-interrupt-mask interrupt-mask + (lambda (interrupt-mask) + interrupt-mask + (processor)))))))) \ No newline at end of file diff --git a/edwin/edtfrm.scm b/edwin/edtfrm.scm new file mode 100644 index 0000000..400e564 --- /dev/null +++ b/edwin/edtfrm.scm @@ -0,0 +1,190 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Editor Frame + +(declare (usual-integrations)) + +;;; Editor Frame + +(define-class editor-frame vanilla-window + (screen + root-inferior + typein-inferior + selected-window + cursor-window + properties)) + +(define (make-editor-frame root-screen main-buffer typein-buffer) + (let ((window (make-object editor-frame))) + (with-instance-variables editor-frame + window + (root-screen main-buffer typein-buffer) + (set! superior false) + (set! x-size (screen-x-size root-screen)) + (set! y-size (screen-y-size root-screen)) + (set! redisplay-flags (list false)) + (set! inferiors '()) + (set! properties (make-1d-table)) + (let ((main-window (make-buffer-frame window main-buffer true)) + (typein-window (make-buffer-frame window typein-buffer false))) + (set! screen root-screen) + (set! root-inferior (find-inferior inferiors main-window)) + (set! typein-inferior (find-inferior inferiors typein-window)) + (set! selected-window main-window) + (set! cursor-window main-window) + (window-cursor-enable! main-window)) + (set-editor-frame-size! window x-size y-size)) + window)) + +(define (editor-frame-update-display! window display-style) + ;; Returns true if update is successfully completed (or unnecessary). + ;; Assumes that interrupts are disabled. + (notice-window-changes! (editor-frame-typein-window window)) + (let ((start (editor-frame-window0 window))) + (notice-window-changes! start) + (do ((window (window1+ start) (window1+ window))) + ((eq? window start)) + (notice-window-changes! window))) + (with-instance-variables editor-frame window (display-style) + (or (not (or (display-style/ignore-redisplay-flags? display-style) + (car redisplay-flags))) + (let ((finished? + (window-update-display! window screen 0 0 0 x-size 0 y-size + display-style))) + (if finished? + (set-car! redisplay-flags false)) + finished?)))) + +(define (set-editor-frame-size! window x y) + (with-instance-variables editor-frame window (x y) + (usual==> window :set-size! x y) + (set-inferior-start! root-inferior 0 0) + (let ((y* (- y typein-y-size))) + (set-inferior-start! typein-inferior 0 y*) + (set-inferior-size! root-inferior x y*)) + (set-inferior-size! typein-inferior x-size typein-y-size) + (if (< x (screen-x-size screen)) + (screen-clear-rectangle screen + x (screen-x-size screen) + 0 (screen-y-size screen) + false)) + (if (< y (screen-y-size screen)) + (screen-clear-rectangle screen + 0 (screen-x-size screen) + y (screen-y-size screen) + false)))) + +(define-method editor-frame :set-size! + set-editor-frame-size!) + +(define typein-y-size 1) + +(define-method editor-frame (:new-root-window! window window*) + (set! root-inferior (find-inferior inferiors window*)) + unspecific) + +(define-integrable (editor-frame-window0 window) + (with-instance-variables editor-frame window () + (window0 (inferior-window root-inferior)))) + +(define-integrable (editor-frame-typein-window window) + (with-instance-variables editor-frame window () + (inferior-window typein-inferior))) + +(define-integrable (editor-frame-selected-window window) + (with-instance-variables editor-frame window () + selected-window)) + +(define-integrable (editor-frame-cursor-window window) + (with-instance-variables editor-frame window () + cursor-window)) + +(define-integrable (editor-frame-root-window window) + (with-instance-variables editor-frame window () + (inferior-window root-inferior))) + +(define-integrable (editor-frame-screen window) + (with-instance-variables editor-frame window () + screen)) + +(define-integrable (editor-frame-properties window) + (with-instance-variables editor-frame window () + properties)) + +(define (editor-frame-windows window) + (cons (editor-frame-typein-window window) + (let ((start (editor-frame-window0 window))) + (let loop ((window start)) + (cons window + (let ((window (window1+ window))) + (if (eq? window start) + '() + (loop window)))))))) + +(define (editor-frame-select-window! window window*) + (with-instance-variables editor-frame window (window*) + (if (not (buffer-frame? window*)) + (error "Attempt to select non-window" window*)) + (window-cursor-disable! cursor-window) + (set! selected-window window*) + (set-window-select-time! window* (increment-select-time!)) + (set! cursor-window window*) + (window-cursor-enable! window*))) + +(define (editor-frame-select-cursor! window window*) + (with-instance-variables editor-frame window (window*) + (if (not (buffer-frame? window*)) + (error "Attempt to select non-window" window*)) + (window-cursor-disable! cursor-window) + (set! cursor-window window*) + (window-cursor-enable! cursor-window))) + +(define-method editor-frame (:button-event! editor-frame button x y) + (call-with-values + (lambda () + (inferior-containing-coordinates editor-frame x y buffer-frame?)) + (lambda (frame relative-x relative-y) + (if frame + ;; Make sure the event is inside the text portion of the + ;; buffer, not in the modeline or other decoration. + (cond ((and (or (not (eq? frame + (editor-frame-typein-window editor-frame))) + (within-typein-edit?)) + (< -1 relative-x (buffer-frame-x-size frame)) + (< -1 relative-y (buffer-frame-y-size frame)) + (local-comtab-entry + (buffer-comtabs (window-buffer frame)) + button + (window-coordinates->mark frame + relative-x + relative-y))) + => (lambda (command) + (with-current-button-event + (make-button-event frame relative-x relative-y) + (lambda () (execute-command command))))) + ((button-down? button) + (editor-beep))))))) \ No newline at end of file diff --git a/edwin/edtstr.scm b/edwin/edtstr.scm new file mode 100644 index 0000000..fc323d6 --- /dev/null +++ b/edwin/edtstr.scm @@ -0,0 +1,161 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019, 2020 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Editor Data Abstraction + +(declare (usual-integrations)) + +(define-structure (editor (constructor %make-editor)) + (name #f read-only #t) + (display-type #f read-only #t) + (screens '()) + (selected-screen #f) + (bufferset #f read-only #t) + (char-history #f read-only #t) + (halt-update? #f read-only #t) + (peek-no-hang #f read-only #t) + (peek #f read-only #t) + (read #f read-only #t) + (button-event #f) + (select-time 1)) + +(define (make-editor name display-type make-screen-args) + (let ((initial-buffer + (make-buffer initial-buffer-name + (ref-mode-object fundamental) + (working-directory-pathname)))) + (let ((bufferset (make-bufferset initial-buffer)) + (screen (display-type/make-screen display-type make-screen-args))) + (initialize-screen-root-window! screen bufferset initial-buffer) + (call-with-values + (lambda () (display-type/get-input-operations display-type screen)) + (lambda (halt-update? peek-no-hang peek read) + (%make-editor name + display-type + (list screen) + screen + bufferset + (make-ring 100) + halt-update? + peek-no-hang + peek + read + #f + 1)))))) + +(define-integrable (current-display-type) + (editor-display-type current-editor)) + +(define-integrable (with-editor-interrupts-enabled thunk) + (display-type/with-interrupts-enabled (current-display-type) thunk)) + +(define-integrable (with-editor-interrupts-disabled thunk) + (display-type/with-interrupts-disabled (current-display-type) thunk)) + +(define-integrable (current-bufferset) + (editor-bufferset current-editor)) + +(define-integrable (current-char-history) + (editor-char-history current-editor)) + +(define (increment-select-time!) + (let ((time (editor-select-time current-editor))) + (set-editor-select-time! current-editor (1+ time)) + time)) + +;;;; Buttons + +(define-record-type