From fa8c0263cde4bf1ccfbbf2ad30a473e2031c6417 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 26 Apr 2021 14:53:20 +0300 Subject: [PATCH] Initial import from MIT Scheme commit 41967043bf1019564f0dbcfa61a92773d1e37037 subdirectory src/edwin some packaging scripts omitted --- AUTHORS | 7 + COPYING | 482 ++++ ChangeLog | 7 + NEWS | 28 + README | 47 + TUTORIAL | 786 ++++++ edwin.cbf | 30 + edwin.ldr | 261 ++ edwin.pkg | 1928 +++++++++++++++ edwin.sf | 93 + edwin/abbrev.scm | 634 +++++ edwin/adapters.scm | 64 + edwin/ansi.scm | 153 ++ edwin/argred.scm | 143 ++ edwin/artdebug.scm | 1356 ++++++++++ edwin/autold.scm | 239 ++ edwin/autosv.scm | 180 ++ edwin/basic.scm | 573 +++++ edwin/bios.scm | 187 ++ edwin/bufcom.scm | 339 +++ edwin/buffer.scm | 566 +++++ edwin/buffrm.scm | 532 ++++ edwin/bufinp.scm | 116 + edwin/bufmnu.scm | 432 ++++ edwin/bufout.scm | 110 + edwin/bufset.scm | 106 + edwin/bufwfs.scm | 432 ++++ edwin/bufwin.scm | 1264 ++++++++++ edwin/bufwiu.scm | 549 +++++ edwin/bufwmc.scm | 588 +++++ edwin/c-mode.scm | 274 +++ edwin/calias.scm | 290 +++ edwin/cinden.scm | 416 ++++ edwin/class.scm | 111 + edwin/clscon.scm | 99 + edwin/clsmac.scm | 123 + edwin/comatch.scm | 151 ++ edwin/comhst.scm | 130 + edwin/comint.scm | 496 ++++ edwin/comman.scm | 206 ++ edwin/compile.scm | 139 ++ edwin/comred.scm | 522 ++++ edwin/comtab.scm | 421 ++++ edwin/comwin.scm | 690 ++++++ edwin/curren.scm | 747 ++++++ edwin/dabbrev.scm | 248 ++ edwin/debian-changelog.scm | 273 +++ edwin/debug.scm | 1788 ++++++++++++++ edwin/debuge.scm | 177 ++ edwin/decls.scm | 245 ++ edwin/diff.scm | 145 ++ edwin/dired.scm | 1064 ++++++++ edwin/dirunx.scm | 111 + edwin/dirw32.scm | 126 + edwin/display.scm | 96 + edwin/docstr.scm | 202 ++ edwin/dos.scm | 158 ++ edwin/doscom.scm | 108 + edwin/dosfile.scm | 568 +++++ edwin/dosproc.scm | 57 + edwin/dosshell.scm | 329 +++ edwin/ed-ffi.scm | 188 ++ edwin/editor.scm | 663 +++++ edwin/edtfrm.scm | 190 ++ edwin/edtstr.scm | 161 ++ edwin/evlcom.scm | 570 +++++ edwin/eystep.scm | 289 +++ edwin/filcom.scm | 899 +++++++ edwin/fileio.scm | 798 ++++++ edwin/fill.scm | 584 +++++ edwin/grpops.scm | 400 +++ edwin/hlpcom.scm | 442 ++++ edwin/htmlmode.scm | 107 + edwin/image.scm | 415 ++++ edwin/info.scm | 1271 ++++++++++ edwin/input.scm | 293 +++ edwin/intmod.scm | 1186 +++++++++ edwin/iserch.scm | 367 +++ edwin/javamode.scm | 135 + edwin/key-w32.scm | 154 ++ edwin/keymap.scm | 213 ++ edwin/keyparse.scm | 521 ++++ edwin/kilcom.scm | 433 ++++ edwin/kmacro.scm | 257 ++ edwin/lincom.scm | 522 ++++ edwin/linden.scm | 364 +++ edwin/loadef.scm | 428 ++++ edwin/lspcom.scm | 302 +++ edwin/macros.scm | 264 ++ edwin/make.scm | 37 + edwin/malias.scm | 175 ++ edwin/manual.scm | 205 ++ edwin/midas.scm | 65 + edwin/modefs.scm | 398 +++ edwin/modes.scm | 141 ++ edwin/modlin.scm | 371 +++ edwin/modwin.scm | 82 + edwin/motcom.scm | 189 ++ edwin/motion.scm | 198 ++ edwin/mousecom.scm | 124 + edwin/nntp.scm | 1872 ++++++++++++++ edwin/notify.scm | 216 ++ edwin/nvector.scm | 35 + edwin/occur.scm | 280 +++ edwin/outline.scm | 289 +++ edwin/paredit.scm | 906 +++++++ edwin/pasmod.scm | 167 ++ edwin/paths.scm | 63 + edwin/print.scm | 160 ++ edwin/process.scm | 703 ++++++ edwin/prompt.scm | 1133 +++++++++ edwin/pwedit.scm | 210 ++ edwin/pwparse.scm | 182 ++ edwin/rcsparse.scm | 485 ++++ edwin/reccom.scm | 130 + edwin/regcom.scm | 191 ++ edwin/regexp.scm | 254 ++ edwin/regops.scm | 153 ++ edwin/replaz.scm | 224 ++ edwin/rfc822.scm | 578 +++++ edwin/ring.scm | 91 + edwin/rmail.scm | 2206 +++++++++++++++++ edwin/rmailsrt.scm | 289 +++ edwin/rmailsum.scm | 825 +++++++ edwin/schmod.scm | 387 +++ edwin/scrcom.scm | 70 + edwin/screen.scm | 937 +++++++ edwin/search.scm | 369 +++ edwin/sendmail.scm | 1854 ++++++++++++++ edwin/sercom.scm | 345 +++ edwin/shell.scm | 458 ++++ edwin/simple.scm | 349 +++ edwin/snr.scm | 4765 ++++++++++++++++++++++++++++++++++++ edwin/sort.scm | 198 ++ edwin/sources.scm | 80 + edwin/string.scm | 1647 +++++++++++++ edwin/strpad.scm | 68 + edwin/strtab.scm | 211 ++ edwin/struct.scm | 463 ++++ edwin/syntax.scm | 434 ++++ edwin/tagutl.scm | 438 ++++ edwin/techinfo.scm | 436 ++++ edwin/telnet.scm | 119 + edwin/termcap.scm | 334 +++ edwin/texcom.scm | 267 ++ edwin/things.scm | 318 +++ edwin/tparse.scm | 339 +++ edwin/tterm.scm | 1260 ++++++++++ edwin/tximod.scm | 279 +++ edwin/txtprp.scm | 793 ++++++ edwin/undo.scm | 352 +++ edwin/unix.scm | 686 ++++++ edwin/utils.scm | 302 +++ edwin/utlwin.scm | 127 + edwin/vc-bzr.scm | 346 +++ edwin/vc-cvs.scm | 388 +++ edwin/vc-git.scm | 256 ++ edwin/vc-rcs.scm | 298 +++ edwin/vc-svn.scm | 355 +++ edwin/vc.scm | 1691 +++++++++++++ edwin/verilog.scm | 262 ++ edwin/vhdl.scm | 467 ++++ edwin/webster.scm | 190 ++ edwin/win32.scm | 685 ++++++ edwin/win32com.scm | 148 ++ edwin/wincom.scm | 704 ++++++ edwin/window.scm | 513 ++++ edwin/winout.scm | 112 + edwin/world-monitor.scm | 120 + edwin/xform.scm | 146 ++ edwin/xterm.scm | 79 + 171 files changed, 74230 insertions(+) create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 NEWS create mode 100644 README create mode 100644 TUTORIAL create mode 100644 edwin.cbf create mode 100644 edwin.ldr create mode 100644 edwin.pkg create mode 100644 edwin.sf create mode 100644 edwin/abbrev.scm create mode 100644 edwin/adapters.scm create mode 100644 edwin/ansi.scm create mode 100644 edwin/argred.scm create mode 100644 edwin/artdebug.scm create mode 100644 edwin/autold.scm create mode 100644 edwin/autosv.scm create mode 100644 edwin/basic.scm create mode 100644 edwin/bios.scm create mode 100644 edwin/bufcom.scm create mode 100644 edwin/buffer.scm create mode 100644 edwin/buffrm.scm create mode 100644 edwin/bufinp.scm create mode 100644 edwin/bufmnu.scm create mode 100644 edwin/bufout.scm create mode 100644 edwin/bufset.scm create mode 100644 edwin/bufwfs.scm create mode 100644 edwin/bufwin.scm create mode 100644 edwin/bufwiu.scm create mode 100644 edwin/bufwmc.scm create mode 100644 edwin/c-mode.scm create mode 100644 edwin/calias.scm create mode 100644 edwin/cinden.scm create mode 100644 edwin/class.scm create mode 100644 edwin/clscon.scm create mode 100644 edwin/clsmac.scm create mode 100644 edwin/comatch.scm create mode 100644 edwin/comhst.scm create mode 100644 edwin/comint.scm create mode 100644 edwin/comman.scm create mode 100644 edwin/compile.scm create mode 100644 edwin/comred.scm create mode 100644 edwin/comtab.scm create mode 100644 edwin/comwin.scm create mode 100644 edwin/curren.scm create mode 100644 edwin/dabbrev.scm create mode 100644 edwin/debian-changelog.scm create mode 100644 edwin/debug.scm create mode 100644 edwin/debuge.scm create mode 100644 edwin/decls.scm create mode 100644 edwin/diff.scm create mode 100644 edwin/dired.scm create mode 100644 edwin/dirunx.scm create mode 100644 edwin/dirw32.scm create mode 100644 edwin/display.scm create mode 100644 edwin/docstr.scm create mode 100644 edwin/dos.scm create mode 100644 edwin/doscom.scm create mode 100644 edwin/dosfile.scm create mode 100644 edwin/dosproc.scm create mode 100644 edwin/dosshell.scm create mode 100644 edwin/ed-ffi.scm create mode 100644 edwin/editor.scm create mode 100644 edwin/edtfrm.scm create mode 100644 edwin/edtstr.scm create mode 100644 edwin/evlcom.scm create mode 100644 edwin/eystep.scm create mode 100644 edwin/filcom.scm create mode 100644 edwin/fileio.scm create mode 100644 edwin/fill.scm create mode 100644 edwin/grpops.scm create mode 100644 edwin/hlpcom.scm create mode 100644 edwin/htmlmode.scm create mode 100644 edwin/image.scm create mode 100644 edwin/info.scm create mode 100644 edwin/input.scm create mode 100644 edwin/intmod.scm create mode 100644 edwin/iserch.scm create mode 100644 edwin/javamode.scm create mode 100644 edwin/key-w32.scm create mode 100644 edwin/keymap.scm create mode 100644 edwin/keyparse.scm create mode 100644 edwin/kilcom.scm create mode 100644 edwin/kmacro.scm create mode 100644 edwin/lincom.scm create mode 100644 edwin/linden.scm create mode 100644 edwin/loadef.scm create mode 100644 edwin/lspcom.scm create mode 100644 edwin/macros.scm create mode 100644 edwin/make.scm create mode 100644 edwin/malias.scm create mode 100644 edwin/manual.scm create mode 100644 edwin/midas.scm create mode 100644 edwin/modefs.scm create mode 100644 edwin/modes.scm create mode 100644 edwin/modlin.scm create mode 100644 edwin/modwin.scm create mode 100644 edwin/motcom.scm create mode 100644 edwin/motion.scm create mode 100644 edwin/mousecom.scm create mode 100644 edwin/nntp.scm create mode 100644 edwin/notify.scm create mode 100644 edwin/nvector.scm create mode 100644 edwin/occur.scm create mode 100644 edwin/outline.scm create mode 100644 edwin/paredit.scm create mode 100644 edwin/pasmod.scm create mode 100644 edwin/paths.scm create mode 100644 edwin/print.scm create mode 100644 edwin/process.scm create mode 100644 edwin/prompt.scm create mode 100644 edwin/pwedit.scm create mode 100644 edwin/pwparse.scm create mode 100644 edwin/rcsparse.scm create mode 100644 edwin/reccom.scm create mode 100644 edwin/regcom.scm create mode 100644 edwin/regexp.scm create mode 100644 edwin/regops.scm create mode 100644 edwin/replaz.scm create mode 100644 edwin/rfc822.scm create mode 100644 edwin/ring.scm create mode 100644 edwin/rmail.scm create mode 100644 edwin/rmailsrt.scm create mode 100644 edwin/rmailsum.scm create mode 100644 edwin/schmod.scm create mode 100644 edwin/scrcom.scm create mode 100644 edwin/screen.scm create mode 100644 edwin/search.scm create mode 100644 edwin/sendmail.scm create mode 100644 edwin/sercom.scm create mode 100644 edwin/shell.scm create mode 100644 edwin/simple.scm create mode 100644 edwin/snr.scm create mode 100644 edwin/sort.scm create mode 100644 edwin/sources.scm create mode 100644 edwin/string.scm create mode 100644 edwin/strpad.scm create mode 100644 edwin/strtab.scm create mode 100644 edwin/struct.scm create mode 100644 edwin/syntax.scm create mode 100644 edwin/tagutl.scm create mode 100644 edwin/techinfo.scm create mode 100644 edwin/telnet.scm create mode 100644 edwin/termcap.scm create mode 100644 edwin/texcom.scm create mode 100644 edwin/things.scm create mode 100644 edwin/tparse.scm create mode 100644 edwin/tterm.scm create mode 100644 edwin/tximod.scm create mode 100644 edwin/txtprp.scm create mode 100644 edwin/undo.scm create mode 100644 edwin/unix.scm create mode 100644 edwin/utils.scm create mode 100644 edwin/utlwin.scm create mode 100644 edwin/vc-bzr.scm create mode 100644 edwin/vc-cvs.scm create mode 100644 edwin/vc-git.scm create mode 100644 edwin/vc-rcs.scm create mode 100644 edwin/vc-svn.scm create mode 100644 edwin/vc.scm create mode 100644 edwin/verilog.scm create mode 100644 edwin/vhdl.scm create mode 100644 edwin/webster.scm create mode 100644 edwin/win32.scm create mode 100644 edwin/win32com.scm create mode 100644 edwin/wincom.scm create mode 100644 edwin/window.scm create mode 100644 edwin/winout.scm create mode 100644 edwin/world-monitor.scm create mode 100644 edwin/xform.scm create mode 100644 edwin/xterm.scm 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