From: Matt Birkholz Date: Fri, 27 May 2016 01:32:06 +0000 (-0700) Subject: New plugins x11 and x11-screen, to replace the x11 μmodule. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~40 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ab734b1a241b5f371c0efafcfaacae2ce4860824;p=mit-scheme.git New plugins x11 and x11-screen, to replace the x11 μmodule. The "new" code is a translation of the x11 μmodule and associated runtime Scheme code. The C code consing Scheme objects was translated into Scheme/FFI code parsing C data. This removed the Scheme-specific C code except for many calls to error_external_return, which are now error status returns. Most of the error checking is intact. All C data structures used by Scheme are protected from leaking by "GC cleanups". --- diff --git a/src/x11-screen/AUTHORS b/src/x11-screen/AUTHORS new file mode 100644 index 000000000..08b67eac9 --- /dev/null +++ b/src/x11-screen/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 separate package. +The MIT/GNU Scheme Team The Edwin code using the prx11 microcode + module. diff --git a/src/x11-screen/COPYING b/src/x11-screen/COPYING new file mode 100644 index 000000000..bf50f20de --- /dev/null +++ b/src/x11-screen/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/src/x11-screen/ChangeLog b/src/x11-screen/ChangeLog new file mode 100644 index 000000000..54b188003 --- /dev/null +++ b/src/x11-screen/ChangeLog @@ -0,0 +1,6 @@ +-*-Text-*- + +Please see the git commit log: + +$ git clone git://git.savannah.gnu.org/mit-scheme.git +$ git log origin/master -- src/x11-screen/ diff --git a/src/x11-screen/Makefile.am b/src/x11-screen/Makefile.am new file mode 100644 index 000000000..f469a15a4 --- /dev/null +++ b/src/x11-screen/Makefile.am @@ -0,0 +1,74 @@ +## Process this file with automake to produce Makefile.in +## +## 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 +## Massachusetts Institute of Technology +## +## This file is part of the X11-Screen option for MIT/GNU Scheme. +## +## X11-Screen 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. +## +## X11-Screen 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 X11-Screen; if not, write to the Free Software +## Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +## 02110-1301, USA. + +EXTRA_DIST = autogen.sh + +MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ +scmlibdir = @MIT_SCHEME_LIBDIR@ +scmlib_subdir = $(scmlibdir)x11-screen + +sources = x11-screen.scm # x11-key.scm x11-command.scm +binaries = x11-screen.bci x11-screen.com +# binaries += x11-key.bci x11-key.com x11-command.scm.bci x11-command.scm.com + +scmlib_sub_DATA = $(sources) +scmlib_sub_DATA += $(binaries) +scmlib_sub_DATA += make.scm x11-screen-@MIT_SCHEME_OS_SUFFIX@.pkd + +# Set these to the defaults used by Scheme. +infodir = $(datarootdir)/info +htmldir = $(libdir)/mit-scheme/doc +dvidir = $(libdir)/mit-scheme/doc +pdfdir = $(libdir)/mit-scheme/doc + +#x11-key.bci: stamp-scheme +#x11-key.com: stamp-scheme +#x11-command.scm.bci: stamp-scheme +#x11-command.scm.com: stamp-scheme +x11-screen.bci: stamp-scheme +x11-screen.com: stamp-scheme +x11-screen-@MIT_SCHEME_OS_SUFFIX@.pkd: stamp-scheme +stamp-scheme: $(sources) x11-screen.pkg + touch stamp-scheme + if ! ./compile.sh; then rm stamp-scheme; exit 1; fi + +CLEANFILES = *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd + +TESTS = x11-screen-check.sh + +ETAGS_ARGS = $(sources) +TAGS_DEPENDENCIES = $(sources) + +EXTRA_DIST += $(sources) compile.sh x11-screen.pkg +EXTRA_DIST += make.scm + +install-data-hook: + echo '(update-optiondb "$(DESTDIR)$(scmlibdir)")' \ + | $(MIT_SCHEME_EXE) --batch-mode + +uninstall-hook: + echo '(update-optiondb "$(DESTDIR)$(scmlibdir)")' \ + | $(MIT_SCHEME_EXE) --batch-mode + [ -d "$(DESTDIR)$(scmlib_subdir)" ] \ + && rmdir "$(DESTDIR)$(scmlib_subdir)" diff --git a/src/x11-screen/NEWS b/src/x11-screen/NEWS new file mode 100644 index 000000000..1043181c5 --- /dev/null +++ b/src/x11-screen/NEWS @@ -0,0 +1,30 @@ +mit-scheme-x11-screen 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 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-x11-screen 0.1 - Matt Birkholz, 2016-05-25 +===================================================== + +* The Edwin display type x11-screen is now a separately buildable and + installable automake package. It requires MIT/GNU Scheme with an + x11 plugin to build and operate. diff --git a/src/x11-screen/README b/src/x11-screen/README new file mode 100644 index 000000000..d4cbc031f --- /dev/null +++ b/src/x11-screen/README @@ -0,0 +1,17 @@ +The X11-SCREEN option. + +This is a drop-in replacement for Edwin's X screen-type that uses the +X11 plugin rather than the x11 microcode module. This plugin is not +part of the core build and can be built outside the core build tree in +the customary way: + + ./configure ... + make all check install + +The install target copies a shared library shim and compiled Scheme +files into the system library path, and re-writes the optiondb.scm +found there. You can override the default command name "mit-scheme" +(and thus the system library path) by setting MIT_SCHEME_EXE. + +To use: (load-option 'X11-SCREEN). Edwin will then create X11 type +screens rather than X type screens. diff --git a/src/x11-screen/autogen.sh b/src/x11-screen/autogen.sh new file mode 100755 index 000000000..70bd51f82 --- /dev/null +++ b/src/x11-screen/autogen.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +set -e +autoreconf --force --install diff --git a/src/x11-screen/compile.sh b/src/x11-screen/compile.sh new file mode 100755 index 000000000..d44f7298a --- /dev/null +++ b/src/x11-screen/compile.sh @@ -0,0 +1,55 @@ +#!/bin/sh +# -*-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 +# 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. + +# Compile the X11-SCREEN option. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode <<\EOF +(begin + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'X11) + (load-option 'EDWIN)) + + (if (name->package '(EDWIN SCREEN X11-SCREEN)) + (error "The (EDWIN SCREEN X11-SCREEN) package already exists.")) + (let ((package-set (package-set-pathname "x11-screen"))) + (if (not (file-modification-timeenvironment '(edwin screen x11-screen))) + ;;(compile-file "x11-key" '() (->environment '(edwin x-keys))) + ;;(compile-file "x11-com" '() (->environment '(edwin x-commands))) + + (cref/generate-constructors "x11-screen") + ) +EOF +SUFFIX=`echo "(display (microcode-id/operating-system-suffix))" \ + | ${MIT_SCHEME_EXE} --batch-mode` +REPORT=x11-screen-$SUFFIX.crf +if [ -s "$REPORT" ]; then echo "$REPORT:1: error: not empty"; exit 1; fi diff --git a/src/x11-screen/configure.ac b/src/x11-screen/configure.ac new file mode 100644 index 000000000..e4a0cf709 --- /dev/null +++ b/src/x11-screen/configure.ac @@ -0,0 +1,47 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT([MIT/GNU Scheme Edwin X11 Screen], + [0.1], + [bug-mit-scheme@gnu.org], + [mit-scheme-x11-screen]) +AC_CONFIG_SRCDIR([x11-screen.pkg]) + +AC_COPYRIGHT( +[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 + Massachusetts Institute of Technology + +This file is part of an x11-screen option for MIT/GNU Scheme. + +This option is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This option is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this option; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +]) + +AM_INIT_AUTOMAKE + +AC_PROG_INSTALL + +: ${MIT_SCHEME_EXE=mit-scheme} +MIT_SCHEME_LIBDIR=`( echo "(display (->namestring" ;\ + echo " (system-library-directory-pathname)))" ) \ + | ${MIT_SCHEME_EXE} --batch-mode` +MIT_SCHEME_OS_SUFFIX=`echo "(display (microcode-id/operating-system-suffix))" \ + | ${MIT_SCHEME_EXE} --batch-mode` + +AC_SUBST([MIT_SCHEME_EXE]) +AC_SUBST([MIT_SCHEME_LIBDIR]) +AC_SUBST([MIT_SCHEME_OS_SUFFIX]) +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/src/x11-screen/ed-ffi.scm b/src/x11-screen/ed-ffi.scm new file mode 100644 index 000000000..5328df603 --- /dev/null +++ b/src/x11-screen/ed-ffi.scm @@ -0,0 +1,34 @@ +#| -*-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 + 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 + '#(("x11-key" (edwin x-keys)) + ("x11-command" (edwin x-commands)) + ("x11-screen" (edwin screen x11-screen)))) \ No newline at end of file diff --git a/src/x11-screen/make.scm b/src/x11-screen/make.scm new file mode 100644 index 000000000..f1a8c5138 --- /dev/null +++ b/src/x11-screen/make.scm @@ -0,0 +1,76 @@ +#| -*-Scheme-*- + +Load the X11-Screen option. |# + +(load-option 'X11) +(load-option 'Edwin) +(with-loader-base-uri (system-library-uri "x11-screen/") + (lambda () + (load-package-set "x11-screen"))) +(add-subsystem-identification! "X11-Screen" '(0 1)) + +;; Reassign (edwin x-commands) bindings created by the define- +;; primitives form. Reassign them to their replacements in the (x11) +;; package. +(let ((xcom (->environment '(edwin x-commands))) + (x11 (->environment '(x11)))) + (for-each (lambda (name) + (environment-assign! xcom name (environment-lookup x11 name))) + '(x-list-fonts + x-set-default-font + x-window-clear + x-window-get-position + x-window-get-size + x-window-lower + x-window-raise + x-window-set-background-color + x-window-set-border-color + x-window-set-border-width + x-window-set-cursor-color + x-window-set-font + x-window-set-foreground-color + x-window-set-internal-border-width + x-window-set-mouse-color + x-window-set-mouse-shape + x-window-set-position + x-window-set-size + x-window-x-size + x-window-y-size + xterm-reconfigure + xterm-set-size + xterm-x-size + xterm-y-size))) + +;; Reassign (edwin screen x-screen) bindings exported to (edwin). +(let ((edwin (->environment '(edwin))) + (x11 (->environment '(edwin screen x11-screen)))) + (for-each (lambda (name) + (environment-assign! edwin name (environment-lookup x11 name))) + '(edwin-variable$x-cut-to-clipboard + edwin-variable$x-paste-from-clipboard + os/interprogram-cut + os/interprogram-paste + x-root-window-size + x-screen-ignore-focus-button? + x-selection-timeout + xterm-screen/flush! + xterm-screen/grab-focus!))) + +;; Reassign (edwin screen x-screen) bindings exported to (edwin x-commands). +(let ((edwin (->environment '(edwin x-commands))) + (x11 (->environment '(edwin screen x11-screen)))) + (for-each (lambda (name) + (environment-assign! edwin name (environment-lookup x11 name))) + '(screen-display + screen-xterm + xterm-screen/set-icon-name + xterm-screen/set-name))) + +;; Remove the X display type. If it stays on the list, its available? +;; operation will load the prx11 microcode module which contains +;; conflicting definitions for symbols like xterm_open_window. +(let ((env (->environment '(edwin display-type)))) + (set! (access display-types env) + (filter (lambda (display-type) + (not (eq? 'X ((access display-type/name env) display-type)))) + (access display-types env)))) \ No newline at end of file diff --git a/src/x11-screen/optiondb.scm b/src/x11-screen/optiondb.scm new file mode 100644 index 000000000..43fbb4734 --- /dev/null +++ b/src/x11-screen/optiondb.scm @@ -0,0 +1,10 @@ +#| -*-Scheme-*- |# + +(define-load-option 'X11-SCREEN + (standard-system-loader ".")) + +(further-load-options + (named-lambda (system-load-options) + (merge-pathnames "optiondb" + (cadr (access library-directory-path + (->environment '(runtime pathname))))))) \ No newline at end of file diff --git a/src/x11-screen/x11-command.scm b/src/x11-screen/x11-command.scm new file mode 100644 index 000000000..0a7999b02 --- /dev/null +++ b/src/x11-screen/x11-command.scm @@ -0,0 +1,318 @@ +#| -*-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 + 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. + +|# + +;;;; X Commands + +(declare (usual-integrations)) + +(define (current-xterm) + (screen-xterm (selected-screen))) + +(define-command set-foreground-color + "Set foreground (text) color of selected frame to COLOR." + "sSet foreground color" + (lambda (color) + (x-window-set-foreground-color (current-xterm) color) + (update-screen! (selected-screen) true))) + +(define-command set-background-color + "Set background color of selected frame to COLOR." + "sSet background color" + (lambda (color) + (let ((xterm (current-xterm))) + (x-window-set-background-color xterm color) + (x-window-clear xterm)) + (update-screen! (selected-screen) true))) + +(define-command set-border-color + "Set border color of selected frame to COLOR." + "sSet border color" + (lambda (color) + (x-window-set-border-color (current-xterm) color))) + +(define-command set-cursor-color + "Set cursor color of selected frame to COLOR." + "sSet cursor color" + (lambda (color) + (x-window-set-cursor-color (current-xterm) color))) + +(define-command set-mouse-color + "Set mouse color of selected frame to COLOR." + "sSet mouse color" + (lambda (color) + (x-window-set-mouse-color (current-xterm) color))) + +(define-command set-border-width + "Set border width of selected frame to WIDTH." + "nSet border width" + (lambda (width) + (x-window-set-border-width (current-xterm) (max 0 width)) + (update-screen! (selected-screen) true))) + +(define-command set-internal-border-width + "Set internal border width of selected frame to WIDTH." + "nSet internal border width" + (lambda (width) + (x-window-set-internal-border-width (current-xterm) (max 0 width)))) + +(define-command set-font + "Set text font of selected frame to FONT." + (lambda () + (list (prompt-for-x-font-name "Set font" #f))) + (lambda (font) + (let ((xterm (current-xterm))) + (let ((x-size (xterm-x-size xterm)) + (y-size (xterm-y-size xterm))) + (if (not (x-window-set-font xterm font)) + (editor-error "Unknown font name: " font)) + (xterm-reconfigure xterm x-size y-size))))) + +(define-command set-default-font + "Set text font to be used in new frames." + (lambda () + (list (prompt-for-x-font-name "Set default font" #f))) + (lambda (font) + (x-set-default-font (screen-display (selected-screen)) font))) + +(define-command font-apropos + "Show all X fonts whose names match a given regular expression." + "sFont apropos (regexp)" + (lambda (regexp) + (with-output-to-help-display + (lambda () + (font-apropos regexp))))) + +(define-command apropos-font + (command-description (ref-command-object font-apropos)) + (command-interactive-specification (ref-command-object font-apropos)) + (command-procedure (ref-command-object font-apropos))) + +(define (font-apropos regexp) + (for-each (lambda (font) + (write-string font) + (newline)) + (string-table-apropos (x-font-name-table) regexp))) + +(define (prompt-for-x-font-name prompt default . options) + (apply prompt-for-string-table-name prompt default (x-font-name-table) + options)) + +(define (x-font-name-table) + (build-x-font-name-table (screen-display (selected-screen)) + "*" + #f)) + +(define (build-x-font-name-table display pattern limit) + (let ((font-name-vector (x-list-fonts display pattern limit)) + (font-name-table (make-string-table))) + (do ((index 0 (fix:+ index 1))) + ((fix:= index (vector-length font-name-vector))) + (let ((font-name (vector-ref font-name-vector index))) + (string-table-put! font-name-table font-name font-name))) + font-name-table)) + +(define-command show-frame-size + "Show size of editor frame." + () + (lambda () + (let ((screen (selected-screen))) + (let ((w.h (x-window-get-size (screen-xterm screen)))) + (message "Frame is " + (screen-x-size screen) + " chars wide and " + (screen-y-size screen) + " chars high (" + (car w.h) + "x" + (cdr w.h) + " pixels)"))))) + +(define-command set-frame-size + "Set size of selected frame to WIDTH x HEIGHT." + "nFrame width (chars)\nnFrame height (chars)" + (lambda (width height) + (xterm-set-size (current-xterm) (max 2 width) (max 2 height)))) + +(define-command show-frame-position + "Show position of editor frame. +This is the position of the upper left-hand corner of the frame border +surrounding the frame, relative to the upper left-hand corner of the +desktop." + () + (lambda () + (let ((x.y (x-window-get-position (current-xterm)))) + (message "Frame's upper left-hand corner is at (" + (car x.y) "," (cdr x.y) ")")))) + +(define-command set-frame-position + "Set position of selected frame to (X,Y)." + "nX position (pixels)\nnY position (pixels)" + (lambda (x y) + (x-window-set-position (current-xterm) x y))) + +(define-command set-frame-name + "Set name of selected frame to NAME. +Useful only if `frame-name-format' is false." + "sSet frame name" + (lambda (name) (xterm-screen/set-name (selected-screen) name))) + +(define-command set-frame-icon-name + "Set icon name of selected frame to NAME. +Useful only if `frame-icon-name-format' is false." + "sSet frame icon name" + (lambda (name) (xterm-screen/set-icon-name (selected-screen) name))) + +(define (update-xterm-screen-names! screen) + (let ((window + (if (and (selected-screen? screen) (within-typein-edit?)) + (typein-edit-other-window) + (screen-selected-window screen)))) + (let ((buffer (window-buffer window)) + (update-name + (lambda (set-name format length) + (if format + (set-name + screen + (string-trim-right + (format-modeline-string window format length))))))) + (update-name xterm-screen/set-name + (ref-variable frame-name-format buffer) + (ref-variable frame-name-length buffer)) + (update-name xterm-screen/set-icon-name + (ref-variable frame-icon-name-format buffer) + (ref-variable frame-icon-name-length buffer))))) + +(define-variable frame-icon-name-format + "If not false, template for displaying frame icon name. +Has same format as `mode-line-format'." + "edwin") + +(define-variable frame-icon-name-length + "Maximum length of frame icon name. +Used only if `frame-icon-name-format' is non-false." + 32 + exact-nonnegative-integer?) + +(define-command raise-frame + "Raise the selected frame so that it is not obscured by other windows." + () + (lambda () (x-window-raise (current-xterm)))) + +(define-command lower-frame + "Lower the selected frame so that it does not obscure other windows." + () + (lambda () (x-window-lower (current-xterm)))) + +(define-command set-mouse-shape + "Set mouse cursor shape for selected frame to SHAPE. +SHAPE must be the (string) name of one of the known cursor shapes. +When called interactively, completion is available on the input." + (lambda () + (list (prompt-for-alist-value "Set mouse shape" + (map (lambda (x) (cons x x)) + mouse-cursor-shapes)))) + (lambda (shape) + (x-window-set-mouse-shape + (current-xterm) + (let loop ((shapes mouse-cursor-shapes) (index 0)) + (if (not (pair? shapes)) + (error "Unknown shape name:" shape)) + (if (string-ci=? shape (car shapes)) + index + (loop (cdr shapes) (fix:+ index 1))))))) + +(define mouse-cursor-shapes + '("X-cursor" "arrow" "based-arrow-down" "based-arrow-up" "boat" "bogosity" + "bottom-left-corner" "bottom-right-corner" "bottom-side" + "bottom-tee" "box-spiral" "center-ptr" "circle" "clock" + "coffee-mug" "cross" "cross-reverse" "crosshair" "diamond-cross" + "dot" "dotbox" "double-arrow" "draft-large" "draft-small" + "draped-box" "exchange" "fleur" "gobbler" "gumby" "hand1" + "hand2" "heart" "icon" "iron-cross" "left-ptr" "left-side" + "left-tee" "leftbutton" "ll-angle" "lr-angle" "man" + "middlebutton" "mouse" "pencil" "pirate" "plus" "question-arrow" + "right-ptr" "right-side" "right-tee" "rightbutton" "rtl-logo" + "sailboat" "sb-down-arrow" "sb-h-double-arrow" "sb-left-arrow" + "sb-right-arrow" "sb-up-arrow" "sb-v-double-arrow" "shuttle" + "sizing" "spider" "spraycan" "star" "target" "tcross" + "top-left-arrow" "top-left-corner" "top-right-corner" + "top-side" "top-tee" "trek" "ul-angle" "umbrella" "ur-angle" + "watch" "xterm")) + +;;;; Mouse Commands +;;; (For compatibility with old code.) + +(define-syntax define-old-mouse-command + (sc-macro-transformer + (lambda (form environment) + (let ((name (cadr form))) + `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name) + ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name) + environment)))))) + +(define-old-mouse-command set-foreground-color) +(define-old-mouse-command set-background-color) +(define-old-mouse-command set-border-color) +(define-old-mouse-command set-cursor-color) +(define-old-mouse-command set-mouse-color) +(define-old-mouse-command set-font) +(define-old-mouse-command set-border-width) +(define-old-mouse-command set-internal-border-width) +(define-old-mouse-command set-mouse-shape) +(define-old-mouse-command mouse-select) +(define-old-mouse-command mouse-keep-one-window) +(define-old-mouse-command mouse-select-and-split) +(define-old-mouse-command mouse-set-point) +(define-old-mouse-command mouse-set-mark) +(define-old-mouse-command mouse-show-event) +(define-old-mouse-command mouse-ignore) + +(define edwin-command$x-set-size edwin-command$set-frame-size) +(define edwin-command$x-set-position edwin-command$set-frame-position) +(define edwin-command$x-set-window-name edwin-command$set-frame-name) +(define edwin-command$x-set-icon-name edwin-command$set-frame-icon-name) +(define edwin-command$x-raise-screen edwin-command$raise-frame) +(define edwin-command$x-lower-screen edwin-command$lower-frame) + +(define edwin-variable$x-screen-name-format edwin-variable$frame-name-format) +(define edwin-variable$x-screen-name-length edwin-variable$frame-name-length) +(define edwin-variable$x-screen-length-format edwin-variable$frame-name-length) + +(define edwin-variable$x-screen-icon-name-format + edwin-variable$frame-icon-name-format) +(define edwin-variable$x-screen-icon-name-length + edwin-variable$frame-icon-name-length) + +(define x-button1-down button1-down) +(define x-button2-down button2-down) +(define x-button3-down button3-down) +(define x-button4-down button4-down) +(define x-button5-down button5-down) +(define x-button1-up button1-up) +(define x-button2-up button2-up) +(define x-button3-up button3-up) +(define x-button4-up button4-up) +(define x-button5-up button5-up) \ No newline at end of file diff --git a/src/x11-screen/x11-key.scm b/src/x11-screen/x11-key.scm new file mode 100644 index 000000000..686773f7e --- /dev/null +++ b/src/x11-screen/x11-key.scm @@ -0,0 +1,916 @@ +#| -*-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 + 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. + +|# + +;;;; Keys +;;; Package: (edwin x-keys) + +(declare (usual-integrations)) + +(define (x-make-special-key keysym bucky-bits) + (make-special-key (or (keysym->name keysym) + (editor-error "Keysym not registered:" keysym)) + bucky-bits)) + +(define (keysym->name keysym) + (let ((entry + (vector-binary-search x-key-translation-table + (lambda (u v) (< u v)) + (lambda (pair) (car pair)) + keysym))) + (and entry (cdr entry)))) + +;; This table is a simple translation of /usr/include/X11/keysym.h. +;; However, that the vendor-specific marker (bit 28, numbered from 0) +;; has been moved to bit 23 so that all keysym values will fit in +;; Scheme fixnums, even with eight-bit type tags. Duplicate keysyms +;; have been pruned arbitrarily. + +(define x-key-translation-table + (vector + '(#x7B . braceleft) + '(#x7C . bar) + '(#x7D . braceright) + '(#x7E . asciitilde) + '(#xA0 . nobreakspace) + '(#xA1 . exclamdown) + '(#xA2 . cent) + '(#xA3 . sterling) + '(#xA4 . currency) + '(#xA5 . yen) + '(#xA6 . brokenbar) + '(#xA7 . section) + '(#xA8 . diaeresis) + '(#xA9 . copyright) + '(#xAA . ordfeminine) + '(#xAB . guillemotleft) + '(#xAC . notsign) + '(#xAD . hyphen) + '(#xAE . registered) + '(#xAF . macron) + '(#xB0 . degree) + '(#xB1 . plusminus) + '(#xB2 . twosuperior) + '(#xB3 . threesuperior) + '(#xB4 . acute) + '(#xB5 . mu) + '(#xB6 . paragraph) + '(#xB7 . periodcentered) + '(#xB8 . cedilla) + '(#xB9 . onesuperior) + '(#xBA . masculine) + '(#xBB . guillemotright) + '(#xBC . onequarter) + '(#xBD . onehalf) + '(#xBE . threequarters) + '(#xBF . questiondown) + '(#xC0 . Agrave) + '(#xC1 . Aacute) + '(#xC2 . Acircumflex) + '(#xC3 . Atilde) + '(#xC4 . Adiaeresis) + '(#xC5 . Aring) + '(#xC6 . AE) + '(#xC7 . Ccedilla) + '(#xC8 . Egrave) + '(#xC9 . Eacute) + '(#xCA . Ecircumflex) + '(#xCB . Ediaeresis) + '(#xCC . Igrave) + '(#xCD . Iacute) + '(#xCE . Icircumflex) + '(#xCF . Idiaeresis) + '(#xD0 . Eth) + '(#xD1 . Ntilde) + '(#xD2 . Ograve) + '(#xD3 . Oacute) + '(#xD4 . Ocircumflex) + '(#xD5 . Otilde) + '(#xD6 . Odiaeresis) + '(#xD7 . multiply) + '(#xD8 . Ooblique) + '(#xD9 . Ugrave) + '(#xDA . Uacute) + '(#xDB . Ucircumflex) + '(#xDC . Udiaeresis) + '(#xDD . Yacute) + '(#xDE . Thorn) + '(#xDF . ssharp) + '(#xE0 . agrave) + '(#xE1 . aacute) + '(#xE2 . acircumflex) + '(#xE3 . atilde) + '(#xE4 . adiaeresis) + '(#xE5 . aring) + '(#xE6 . ae) + '(#xE7 . ccedilla) + '(#xE8 . egrave) + '(#xE9 . eacute) + '(#xEA . ecircumflex) + '(#xEB . ediaeresis) + '(#xEC . igrave) + '(#xED . iacute) + '(#xEE . icircumflex) + '(#xEF . idiaeresis) + '(#xF0 . eth) + '(#xF1 . ntilde) + '(#xF2 . ograve) + '(#xF3 . oacute) + '(#xF4 . ocircumflex) + '(#xF5 . otilde) + '(#xF6 . odiaeresis) + '(#xF7 . division) + '(#xF8 . oslash) + '(#xF9 . ugrave) + '(#xFA . uacute) + '(#xFB . ucircumflex) + '(#xFC . udiaeresis) + '(#xFD . yacute) + '(#xFE . thorn) + '(#xFF . ydiaeresis) + '(#x1A1 . Aogonek) + '(#x1A2 . breve) + '(#x1A3 . Lstroke) + '(#x1A5 . Lcaron) + '(#x1A6 . Sacute) + '(#x1A9 . Scaron) + '(#x1AA . Scedilla) + '(#x1AB . Tcaron) + '(#x1AC . Zacute) + '(#x1AE . Zcaron) + '(#x1AF . Zabovedot) + '(#x1B1 . aogonek) + '(#x1B2 . ogonek) + '(#x1B3 . lstroke) + '(#x1B5 . lcaron) + '(#x1B6 . sacute) + '(#x1B7 . caron) + '(#x1B9 . scaron) + '(#x1BA . scedilla) + '(#x1BB . tcaron) + '(#x1BC . zacute) + '(#x1BD . doubleacute) + '(#x1BE . zcaron) + '(#x1BF . zabovedot) + '(#x1C0 . Racute) + '(#x1C3 . Abreve) + '(#x1C5 . Lacute) + '(#x1C6 . Cacute) + '(#x1C8 . Ccaron) + '(#x1CA . Eogonek) + '(#x1CC . Ecaron) + '(#x1CF . Dcaron) + '(#x1D0 . Dstroke) + '(#x1D1 . Nacute) + '(#x1D2 . Ncaron) + '(#x1D5 . Odoubleacute) + '(#x1D8 . Rcaron) + '(#x1D9 . Uring) + '(#x1DB . Udoubleacute) + '(#x1DE . Tcedilla) + '(#x1E0 . racute) + '(#x1E3 . abreve) + '(#x1E5 . lacute) + '(#x1E6 . cacute) + '(#x1E8 . ccaron) + '(#x1EA . eogonek) + '(#x1EC . ecaron) + '(#x1EF . dcaron) + '(#x1F0 . dstroke) + '(#x1F1 . nacute) + '(#x1F2 . ncaron) + '(#x1F5 . odoubleacute) + '(#x1F8 . rcaron) + '(#x1F9 . uring) + '(#x1FB . udoubleacute) + '(#x1FE . tcedilla) + '(#x1FF . abovedot) + '(#x2A1 . Hstroke) + '(#x2A6 . Hcircumflex) + '(#x2A9 . Iabovedot) + '(#x2AB . Gbreve) + '(#x2AC . Jcircumflex) + '(#x2B1 . hstroke) + '(#x2B6 . hcircumflex) + '(#x2B9 . idotless) + '(#x2BB . gbreve) + '(#x2BC . jcircumflex) + '(#x2C5 . Cabovedot) + '(#x2C6 . Ccircumflex) + '(#x2D5 . Gabovedot) + '(#x2D8 . Gcircumflex) + '(#x2DD . Ubreve) + '(#x2DE . Scircumflex) + '(#x2E5 . cabovedot) + '(#x2E6 . ccircumflex) + '(#x2F5 . gabovedot) + '(#x2F8 . gcircumflex) + '(#x2FD . ubreve) + '(#x2FE . scircumflex) + '(#x3A2 . kappa) + '(#x3A3 . Rcedilla) + '(#x3A5 . Itilde) + '(#x3A6 . Lcedilla) + '(#x3AA . Emacron) + '(#x3AB . Gcedilla) + '(#x3AC . Tslash) + '(#x3B3 . rcedilla) + '(#x3B5 . itilde) + '(#x3B6 . lcedilla) + '(#x3BA . emacron) + '(#x3BB . gcedilla) + '(#x3BC . tslash) + '(#x3BD . ENG) + '(#x3BF . eng) + '(#x3C0 . Amacron) + '(#x3C7 . Iogonek) + '(#x3CC . Eabovedot) + '(#x3CF . Imacron) + '(#x3D1 . Ncedilla) + '(#x3D2 . Omacron) + '(#x3D3 . Kcedilla) + '(#x3D9 . Uogonek) + '(#x3DD . Utilde) + '(#x3DE . Umacron) + '(#x3E0 . amacron) + '(#x3E7 . iogonek) + '(#x3EC . eabovedot) + '(#x3EF . imacron) + '(#x3F1 . ncedilla) + '(#x3F2 . omacron) + '(#x3F3 . kcedilla) + '(#x3F9 . uogonek) + '(#x3FD . utilde) + '(#x3FE . umacron) + '(#x47E . overline) + '(#x4A1 . kana-fullstop) + '(#x4A2 . kana-openingbracket) + '(#x4A3 . kana-closingbracket) + '(#x4A4 . kana-comma) + '(#x4A5 . kana-conjunctive) + '(#x4A6 . kana-WO) + '(#x4A7 . kana-a) + '(#x4A8 . kana-i) + '(#x4A9 . kana-u) + '(#x4AA . kana-e) + '(#x4AB . kana-o) + '(#x4AC . kana-ya) + '(#x4AD . kana-yu) + '(#x4AE . kana-yo) + '(#x4AF . kana-tu) + '(#x4B0 . prolongedsound) + '(#x4B1 . kana-A) + '(#x4B2 . kana-I) + '(#x4B3 . kana-U) + '(#x4B4 . kana-E) + '(#x4B5 . kana-O) + '(#x4B6 . kana-KA) + '(#x4B7 . kana-KI) + '(#x4B8 . kana-KU) + '(#x4B9 . kana-KE) + '(#x4BA . kana-KO) + '(#x4BB . kana-SA) + '(#x4BC . kana-SHI) + '(#x4BD . kana-SU) + '(#x4BE . kana-SE) + '(#x4BF . kana-SO) + '(#x4C0 . kana-TA) + '(#x4C1 . kana-TI) + '(#x4C2 . kana-TU) + '(#x4C3 . kana-TE) + '(#x4C4 . kana-TO) + '(#x4C5 . kana-NA) + '(#x4C6 . kana-NI) + '(#x4C7 . kana-NU) + '(#x4C8 . kana-NE) + '(#x4C9 . kana-NO) + '(#x4CA . kana-HA) + '(#x4CB . kana-HI) + '(#x4CC . kana-HU) + '(#x4CD . kana-HE) + '(#x4CE . kana-HO) + '(#x4CF . kana-MA) + '(#x4D0 . kana-MI) + '(#x4D1 . kana-MU) + '(#x4D2 . kana-ME) + '(#x4D3 . kana-MO) + '(#x4D4 . kana-YA) + '(#x4D5 . kana-YU) + '(#x4D6 . kana-YO) + '(#x4D7 . kana-RA) + '(#x4D8 . kana-RI) + '(#x4D9 . kana-RU) + '(#x4DA . kana-RE) + '(#x4DB . kana-RO) + '(#x4DC . kana-WA) + '(#x4DD . kana-N) + '(#x4DE . voicedsound) + '(#x4DF . semivoicedsound) + '(#x5AC . Arabic-comma) + '(#x5BB . Arabic-semicolon) + '(#x5BF . Arabic-question-mark) + '(#x5C1 . Arabic-hamza) + '(#x5C2 . Arabic-maddaonalef) + '(#x5C3 . Arabic-hamzaonalef) + '(#x5C4 . Arabic-hamzaonwaw) + '(#x5C5 . Arabic-hamzaunderalef) + '(#x5C6 . Arabic-hamzaonyeh) + '(#x5C7 . Arabic-alef) + '(#x5C8 . Arabic-beh) + '(#x5C9 . Arabic-tehmarbuta) + '(#x5CA . Arabic-teh) + '(#x5CB . Arabic-theh) + '(#x5CC . Arabic-jeem) + '(#x5CD . Arabic-hah) + '(#x5CE . Arabic-khah) + '(#x5CF . Arabic-dal) + '(#x5D0 . Arabic-thal) + '(#x5D1 . Arabic-ra) + '(#x5D2 . Arabic-zain) + '(#x5D3 . Arabic-seen) + '(#x5D4 . Arabic-sheen) + '(#x5D5 . Arabic-sad) + '(#x5D6 . Arabic-dad) + '(#x5D7 . Arabic-tah) + '(#x5D8 . Arabic-zah) + '(#x5D9 . Arabic-ain) + '(#x5DA . Arabic-ghain) + '(#x5E0 . Arabic-tatweel) + '(#x5E1 . Arabic-feh) + '(#x5E2 . Arabic-qaf) + '(#x5E3 . Arabic-kaf) + '(#x5E4 . Arabic-lam) + '(#x5E5 . Arabic-meem) + '(#x5E6 . Arabic-noon) + '(#x5E7 . Arabic-heh) + '(#x5E8 . Arabic-waw) + '(#x5E9 . Arabic-alefmaksura) + '(#x5EA . Arabic-yeh) + '(#x5EB . Arabic-fathatan) + '(#x5EC . Arabic-dammatan) + '(#x5ED . Arabic-kasratan) + '(#x5EE . Arabic-fatha) + '(#x5EF . Arabic-damma) + '(#x5F0 . Arabic-kasra) + '(#x5F1 . Arabic-shadda) + '(#x5F2 . Arabic-sukun) + '(#x6A1 . Serbian-dje) + '(#x6A2 . Macedonia-gje) + '(#x6A3 . Cyrillic-io) + '(#x6A4 . Ukranian-je) + '(#x6A5 . Macedonia-dse) + '(#x6A6 . Ukranian-i) + '(#x6A7 . Ukranian-yi) + '(#x6A8 . Cyrillic-je) + '(#x6A9 . Cyrillic-lje) + '(#x6AA . Cyrillic-nje) + '(#x6AB . Serbian-tshe) + '(#x6AC . Macedonia-kje) + '(#x6AE . Byelorussian-shortu) + '(#x6AF . Cyrillic-dzhe) + '(#x6B0 . numerosign) + '(#x6B1 . Serbian-DJE) + '(#x6B2 . Macedonia-GJE) + '(#x6B3 . Cyrillic-IO) + '(#x6B4 . Ukranian-JE) + '(#x6B5 . Macedonia-DSE) + '(#x6B6 . Ukranian-I) + '(#x6B7 . Ukrainian-YI) + '(#x6B8 . Cyrillic-JE) + '(#x6B9 . Cyrillic-LJE) + '(#x6BA . Cyrillic-NJE) + '(#x6BB . Serbian-TSHE) + '(#x6BC . Macedonia-KJE) + '(#x6BE . Byelorussian-SHORTU) + '(#x6BF . Cyrillic-DZHE) + '(#x6C0 . Cyrillic-yu) + '(#x6C1 . Cyrillic-a) + '(#x6C2 . Cyrillic-be) + '(#x6C3 . Cyrillic-tse) + '(#x6C4 . Cyrillic-de) + '(#x6C5 . Cyrillic-ie) + '(#x6C6 . Cyrillic-ef) + '(#x6C7 . Cyrillic-ghe) + '(#x6C8 . Cyrillic-ha) + '(#x6C9 . Cyrillic-i) + '(#x6CA . Cyrillic-shorti) + '(#x6CB . Cyrillic-ka) + '(#x6CC . Cyrillic-el) + '(#x6CD . Cyrillic-em) + '(#x6CE . Cyrillic-en) + '(#x6CF . Cyrillic-o) + '(#x6D0 . Cyrillic-pe) + '(#x6D1 . Cyrillic-ya) + '(#x6D2 . Cyrillic-er) + '(#x6D3 . Cyrillic-es) + '(#x6D4 . Cyrillic-te) + '(#x6D5 . Cyrillic-u) + '(#x6D6 . Cyrillic-zhe) + '(#x6D7 . Cyrillic-ve) + '(#x6D8 . Cyrillic-softsign) + '(#x6D9 . Cyrillic-yeru) + '(#x6DA . Cyrillic-ze) + '(#x6DB . Cyrillic-sha) + '(#x6DC . Cyrillic-e) + '(#x6DD . Cyrillic-shcha) + '(#x6DE . Cyrillic-che) + '(#x6DF . Cyrillic-hardsign) + '(#x6E0 . Cyrillic-YU) + '(#x6E1 . Cyrillic-A) + '(#x6E2 . Cyrillic-BE) + '(#x6E3 . Cyrillic-TSE) + '(#x6E4 . Cyrillic-DE) + '(#x6E5 . Cyrillic-IE) + '(#x6E6 . Cyrillic-EF) + '(#x6E7 . Cyrillic-GHE) + '(#x6E8 . Cyrillic-HA) + '(#x6E9 . Cyrillic-I) + '(#x6EA . Cyrillic-SHORTI) + '(#x6EB . Cyrillic-KA) + '(#x6EC . Cyrillic-EL) + '(#x6ED . Cyrillic-EM) + '(#x6EE . Cyrillic-EN) + '(#x6EF . Cyrillic-O) + '(#x6F0 . Cyrillic-PE) + '(#x6F1 . Cyrillic-YA) + '(#x6F2 . Cyrillic-ER) + '(#x6F3 . Cyrillic-ES) + '(#x6F4 . Cyrillic-TE) + '(#x6F5 . Cyrillic-U) + '(#x6F6 . Cyrillic-ZHE) + '(#x6F7 . Cyrillic-VE) + '(#x6F8 . Cyrillic-SOFTSIGN) + '(#x6F9 . Cyrillic-YERU) + '(#x6FA . Cyrillic-ZE) + '(#x6FB . Cyrillic-SHA) + '(#x6FC . Cyrillic-E) + '(#x6FD . Cyrillic-SHCHA) + '(#x6FE . Cyrillic-CHE) + '(#x6FF . Cyrillic-HARDSIGN) + '(#x7A1 . Greek-ALPHAaccent) + '(#x7A2 . Greek-EPSILONaccent) + '(#x7A3 . Greek-ETAaccent) + '(#x7A4 . Greek-IOTAaccent) + '(#x7A5 . Greek-IOTAdiaeresis) + '(#x7A7 . Greek-OMICRONaccent) + '(#x7A8 . Greek-UPSILONaccent) + '(#x7A9 . Greek-UPSILONdieresis) + '(#x7AB . Greek-OMEGAaccent) + '(#x7AE . Greek-accentdieresis) + '(#x7AF . Greek-horizbar) + '(#x7B1 . Greek-alphaaccent) + '(#x7B2 . Greek-epsilonaccent) + '(#x7B3 . Greek-etaaccent) + '(#x7B4 . Greek-iotaaccent) + '(#x7B5 . Greek-iotadieresis) + '(#x7B6 . Greek-iotaaccentdieresis) + '(#x7B7 . Greek-omicronaccent) + '(#x7B8 . Greek-upsilonaccent) + '(#x7B9 . Greek-upsilondieresis) + '(#x7BA . Greek-upsilonaccentdieresis) + '(#x7BB . Greek-omegaaccent) + '(#x7C1 . Greek-ALPHA) + '(#x7C2 . Greek-BETA) + '(#x7C3 . Greek-GAMMA) + '(#x7C4 . Greek-DELTA) + '(#x7C5 . Greek-EPSILON) + '(#x7C6 . Greek-ZETA) + '(#x7C7 . Greek-ETA) + '(#x7C8 . Greek-THETA) + '(#x7C9 . Greek-IOTA) + '(#x7CA . Greek-KAPPA) + '(#x7CB . Greek-LAMBDA) + '(#x7CC . Greek-MU) + '(#x7CD . Greek-NU) + '(#x7CE . Greek-XI) + '(#x7CF . Greek-OMICRON) + '(#x7D0 . Greek-PI) + '(#x7D1 . Greek-RHO) + '(#x7D2 . Greek-SIGMA) + '(#x7D4 . Greek-TAU) + '(#x7D5 . Greek-UPSILON) + '(#x7D6 . Greek-PHI) + '(#x7D7 . Greek-CHI) + '(#x7D8 . Greek-PSI) + '(#x7D9 . Greek-OMEGA) + '(#x7E1 . Greek-alpha) + '(#x7E2 . Greek-beta) + '(#x7E3 . Greek-gamma) + '(#x7E4 . Greek-delta) + '(#x7E5 . Greek-epsilon) + '(#x7E6 . Greek-zeta) + '(#x7E7 . Greek-eta) + '(#x7E8 . Greek-theta) + '(#x7E9 . Greek-iota) + '(#x7EA . Greek-kappa) + '(#x7EB . Greek-lambda) + '(#x7EC . Greek-mu) + '(#x7ED . Greek-nu) + '(#x7EE . Greek-xi) + '(#x7EF . Greek-omicron) + '(#x7F0 . Greek-pi) + '(#x7F1 . Greek-rho) + '(#x7F2 . Greek-sigma) + '(#x7F3 . Greek-finalsmallsigma) + '(#x7F4 . Greek-tau) + '(#x7F5 . Greek-upsilon) + '(#x7F6 . Greek-phi) + '(#x7F7 . Greek-chi) + '(#x7F8 . Greek-psi) + '(#x7F9 . Greek-omega) + '(#x8A1 . leftradical) + '(#x8A2 . topleftradical) + '(#x8A3 . horizconnector) + '(#x8A4 . topintegral) + '(#x8A5 . botintegral) + '(#x8A6 . vertconnector) + '(#x8A7 . topleftsqbracket) + '(#x8A8 . botleftsqbracket) + '(#x8A9 . toprightsqbracket) + '(#x8AA . botrightsqbracket) + '(#x8AB . topleftparens) + '(#x8AC . botleftparens) + '(#x8AD . toprightparens) + '(#x8AE . botrightparens) + '(#x8AF . leftmiddlecurlybrace) + '(#x8B0 . rightmiddlecurlybrace) + '(#x8B1 . topleftsummation) + '(#x8B2 . botleftsummation) + '(#x8B3 . topvertsummationconnector) + '(#x8B4 . botvertsummationconnector) + '(#x8B5 . toprightsummation) + '(#x8B6 . botrightsummation) + '(#x8B7 . rightmiddlesummation) + '(#x8BC . lessthanequal) + '(#x8BD . notequal) + '(#x8BE . greaterthanequal) + '(#x8BF . integral) + '(#x8C0 . therefore) + '(#x8C1 . variation) + '(#x8C2 . infinity) + '(#x8C5 . nabla) + '(#x8C8 . approximate) + '(#x8C9 . similarequal) + '(#x8CD . ifonlyif) + '(#x8CE . implies) + '(#x8CF . identical) + '(#x8D6 . radical) + '(#x8DA . includedin) + '(#x8DB . includes) + '(#x8DC . intersection) + '(#x8DD . union) + '(#x8DE . logicaland) + '(#x8DF . logicalor) + '(#x8EF . partialderivative) + '(#x8F6 . function) + '(#x8FB . leftarrow) + '(#x8FC . uparrow) + '(#x8FD . rightarrow) + '(#x8FE . downarrow) + '(#x9DF . blank) + '(#x9E0 . soliddiamond) + '(#x9E1 . checkerboard) + '(#x9E2 . ht) + '(#x9E3 . ff) + '(#x9E4 . cr) + '(#x9E5 . lf) + '(#x9E8 . nl) + '(#x9E9 . vt) + '(#x9EA . lowrightcorner) + '(#x9EB . uprightcorner) + '(#x9EC . upleftcorner) + '(#x9ED . lowleftcorner) + '(#x9EE . crossinglines) + '(#x9EF . horizlinescan1) + '(#x9F0 . horizlinescan3) + '(#x9F1 . horizlinescan5) + '(#x9F2 . horizlinescan7) + '(#x9F3 . horizlinescan9) + '(#x9F4 . leftt) + '(#x9F5 . rightt) + '(#x9F6 . bott) + '(#x9F7 . topt) + '(#x9F8 . vertbar) + '(#xAA1 . emspace) + '(#xAA2 . enspace) + '(#xAA3 . em3space) + '(#xAA4 . em4space) + '(#xAA5 . digitspace) + '(#xAA6 . punctspace) + '(#xAA7 . thinspace) + '(#xAA8 . hairspace) + '(#xAA9 . emdash) + '(#xAAA . endash) + '(#xAAC . signifblank) + '(#xAAE . ellipsis) + '(#xAAF . doubbaselinedot) + '(#xAB0 . onethird) + '(#xAB1 . twothirds) + '(#xAB2 . onefifth) + '(#xAB3 . twofifths) + '(#xAB4 . threefifths) + '(#xAB5 . fourfifths) + '(#xAB6 . onesixth) + '(#xAB7 . fivesixths) + '(#xAB8 . careof) + '(#xABB . figdash) + '(#xABC . leftanglebracket) + '(#xABD . decimalpoint) + '(#xABE . rightanglebracket) + '(#xABF . marker) + '(#xAC3 . oneeighth) + '(#xAC4 . threeeighths) + '(#xAC5 . fiveeighths) + '(#xAC6 . seveneighths) + '(#xAC9 . trademark) + '(#xACA . signaturemark) + '(#xACB . trademarkincircle) + '(#xACC . leftopentriangle) + '(#xACD . rightopentriangle) + '(#xACE . emopencircle) + '(#xACF . emopenrectangle) + '(#xAD0 . leftsinglequotemark) + '(#xAD1 . rightsinglequotemark) + '(#xAD2 . leftdoublequotemark) + '(#xAD3 . rightdoublequotemark) + '(#xAD4 . prescription) + '(#xAD6 . minutes) + '(#xAD7 . seconds) + '(#xAD9 . latincross) + '(#xADA . hexagram) + '(#xADB . filledrectbullet) + '(#xADC . filledlefttribullet) + '(#xADD . filledrighttribullet) + '(#xADE . emfilledcircle) + '(#xADF . emfilledrect) + '(#xAE0 . enopencircbullet) + '(#xAE1 . enopensquarebullet) + '(#xAE2 . openrectbullet) + '(#xAE3 . opentribulletup) + '(#xAE4 . opentribulletdown) + '(#xAE5 . openstar) + '(#xAE6 . enfilledcircbullet) + '(#xAE7 . enfilledsqbullet) + '(#xAE8 . filledtribulletup) + '(#xAE9 . filledtribulletdown) + '(#xAEA . leftpointer) + '(#xAEB . rightpointer) + '(#xAEC . club) + '(#xAED . diamond) + '(#xAEE . heart) + '(#xAF0 . maltesecross) + '(#xAF1 . dagger) + '(#xAF2 . doubledagger) + '(#xAF3 . checkmark) + '(#xAF4 . ballotcross) + '(#xAF5 . musicalsharp) + '(#xAF6 . musicalflat) + '(#xAF7 . malesymbol) + '(#xAF8 . femalesymbol) + '(#xAF9 . telephone) + '(#xAFA . telephonerecorder) + '(#xAFB . phonographcopyright) + '(#xAFC . caret) + '(#xAFD . singlelowquotemark) + '(#xAFE . doublelowquotemark) + '(#xAFF . cursor) + '(#xBA3 . leftcaret) + '(#xBA6 . rightcaret) + '(#xBA8 . downcaret) + '(#xBA9 . upcaret) + '(#xBC0 . overbar) + '(#xBC2 . downtack) + '(#xBC3 . upshoe) + '(#xBC4 . downstile) + '(#xBC6 . underbar) + '(#xBCA . jot) + '(#xBCC . quad) + '(#xBCE . uptack) + '(#xBCF . circle) + '(#xBD3 . upstile) + '(#xBD6 . downshoe) + '(#xBD8 . rightshoe) + '(#xBDA . leftshoe) + '(#xBDC . lefttack) + '(#xBFC . righttack) + '(#xCDF . hebrew-doublelowline) + '(#xCE0 . hebrew-aleph) + '(#xCE1 . hebrew-beth) + '(#xCE2 . hebrew-gimmel) + '(#xCE3 . hebrew-daleth) + '(#xCE4 . hebrew-he) + '(#xCE5 . hebrew-waw) + '(#xCE6 . hebrew-zayin) + '(#xCE7 . hebrew-het) + '(#xCE8 . hebrew-teth) + '(#xCE9 . hebrew-yod) + '(#xCEA . hebrew-finalkaph) + '(#xCEB . hebrew-kaph) + '(#xCEC . hebrew-lamed) + '(#xCED . hebrew-finalmem) + '(#xCEE . hebrew-mem) + '(#xCEF . hebrew-finalnun) + '(#xCF0 . hebrew-nun) + '(#xCF1 . hebrew-samekh) + '(#xCF2 . hebrew-ayin) + '(#xCF3 . hebrew-finalpe) + '(#xCF4 . hebrew-pe) + '(#xCF5 . hebrew-finalzadi) + '(#xCF6 . hebrew-zadi) + '(#xCF7 . hebrew-qoph) + '(#xCF8 . hebrew-resh) + '(#xCF9 . hebrew-shin) + '(#xCFA . hebrew-taf) + '(#xFF08 . BackSpace) + '(#xFF09 . Tab) + '(#xFF0A . Linefeed) + '(#xFF0B . Clear) + '(#xFF0D . Return) + '(#xFF13 . Pause) + '(#xFF14 . Scroll-Lock) + '(#xFF1B . Escape) + '(#xFF20 . Multi-key) + '(#xFF21 . Kanji) + '(#xFF22 . Muhenkan) + '(#xFF23 . Henkan) + '(#xFF24 . Romaji) + '(#xFF25 . Hiragana) + '(#xFF26 . Katakana) + '(#xFF27 . Hiragana-Katakana) + '(#xFF28 . Zenkaku) + '(#xFF29 . Hankaku) + '(#xFF2A . Zenkaku-Hankaku) + '(#xFF2B . Touroku) + '(#xFF2C . Massyo) + '(#xFF2D . Kana-Lock) + '(#xFF2E . Kana-Shift) + '(#xFF2F . Eisu-Shift) + '(#xFF30 . Eisu-toggle) + '(#xFF50 . Home) + '(#xFF51 . Left) + '(#xFF52 . Up) + '(#xFF53 . Right) + '(#xFF54 . Down) + '(#xFF55 . Prior) + '(#xFF56 . Next) + '(#xFF57 . End) + '(#xFF58 . Begin) + '(#xFF60 . Select) + '(#xFF61 . Print) + '(#xFF62 . Execute) + '(#xFF63 . Insert) + '(#xFF65 . Undo) + '(#xFF66 . Redo) + '(#xFF67 . Menu) + '(#xFF68 . Find) + '(#xFF69 . Stop) ;originally called Cancel + '(#xFF6A . Help) + '(#xFF6B . Break) + '(#xFF7E . script-switch) + '(#xFF7F . Num-Lock) + '(#xFF80 . KP-Space) + '(#xFF89 . KP-Tab) + '(#xFF8D . KP-Enter) + '(#xFF91 . KP-F1) + '(#xFF92 . KP-F2) + '(#xFF93 . KP-F3) + '(#xFF94 . KP-F4) + '(#xFFAA . KP-Multiply) + '(#xFFAB . KP-Add) + '(#xFFAC . KP-Separator) + '(#xFFAD . KP-Subtract) + '(#xFFAE . KP-Decimal) + '(#xFFAF . KP-Divide) + '(#xFFB0 . KP-0) + '(#xFFB1 . KP-1) + '(#xFFB2 . KP-2) + '(#xFFB3 . KP-3) + '(#xFFB4 . KP-4) + '(#xFFB5 . KP-5) + '(#xFFB6 . KP-6) + '(#xFFB7 . KP-7) + '(#xFFB8 . KP-8) + '(#xFFB9 . KP-9) + '(#xFFBD . KP-Equal) + '(#xFFBE . F1) + '(#xFFBF . F2) + '(#xFFC0 . F3) + '(#xFFC1 . F4) + '(#xFFC2 . F5) + '(#xFFC3 . F6) + '(#xFFC4 . F7) + '(#xFFC5 . F8) + '(#xFFC6 . F9) + '(#xFFC7 . F10) + '(#xFFC8 . F11) + '(#xFFC9 . F12) + '(#xFFCA . F13) + '(#xFFCB . F14) + '(#xFFCC . F15) + '(#xFFCD . F16) + '(#xFFCE . F17) + '(#xFFCF . F18) + '(#xFFD0 . F19) + '(#xFFD1 . F20) + '(#xFFD2 . F21) + '(#xFFD3 . F22) + '(#xFFD4 . F23) + '(#xFFD5 . F24) + '(#xFFD6 . F25) + '(#xFFD7 . F26) + '(#xFFD8 . F27) + '(#xFFD9 . F28) + '(#xFFDA . F29) + '(#xFFDB . F30) + '(#xFFDC . F31) + '(#xFFDD . F32) + '(#xFFDE . F33) + '(#xFFDF . F34) + '(#xFFE0 . F35) + '(#xFFE1 . Shift-L) + '(#xFFE2 . Shift-R) + '(#xFFE3 . Control-L) + '(#xFFE4 . Control-R) + '(#xFFE5 . Caps-Lock) + '(#xFFE6 . Shift-Lock) + '(#xFFE7 . Meta-L) + '(#xFFE8 . Meta-R) + '(#xFFE9 . Alt-L) + '(#xFFEA . Alt-R) + '(#xFFEB . Super-L) + '(#xFFEC . Super-R) + '(#xFFED . Hyper-L) + '(#xFFEE . Hyper-R) + '(#xFFFF . Delete) + '(#x8000A8 . mute-acute) + '(#x8000A9 . mute-grave) + '(#x8000AA . mute-asciicircum) + '(#x8000AB . mute-diaeresis) + '(#x8000AC . mute-asciitilde) + '(#x8000AF . lira) + '(#x8000BE . guilder) + '(#x8000EE . Ydiaeresis) + '(#x8000F6 . longminus) + '(#x8000FC . block) + '(#x80FF48 . hpModelock1) + '(#x80FF49 . hpModelock2) + '(#x80FF6C . Reset) + '(#x80FF6D . System) + '(#x80FF6E . User) + '(#x80FF6F . ClearLine) + '(#x80FF70 . InsertLine) + '(#x80FF71 . DeleteLine) + '(#x80FF72 . InsertChar) + '(#x80FF73 . DeleteChar) + '(#x80FF74 . BackTab) + '(#x80FF75 . KP-BackTab) + '(#x80FF76 . Ext16bit-L) + '(#x80FF77 . Ext16bit-R) + '(#x84FF02 . osfCopy) + '(#x84FF03 . osfCut) + '(#x84FF04 . osfPaste) + '(#x84FF08 . osfBackSpace) + '(#x84FF0B . osfClear) + '(#x84FF31 . osfAddMode) + '(#x84FF32 . osfPrimaryPaste) + '(#x84FF33 . osfQuickPaste) + '(#x84FF41 . osfPageUp) + '(#x84FF42 . osfPageDown) + '(#x84FF44 . osfActivate) + '(#x84FF45 . osfMenuBar) + '(#x84FF51 . osfLeft) + '(#x84FF52 . osfUp) + '(#x84FF53 . osfRight) + '(#x84FF54 . osfDown) + '(#x84FF57 . osfEndLine) + '(#x84FF58 . osfBeginLine) + '(#x84FF60 . osfSelect) + '(#x84FF63 . osfInsert) + '(#x84FF65 . osfUndo) + '(#x84FF67 . osfMenu) + '(#x84FF69 . osfCancel) + '(#x84FF6A . osfHelp) + '(#x84FFFF . osfDelete) + '(#xFFFFFF . VoidSymbol))) \ No newline at end of file diff --git a/src/x11-screen/x11-screen-check.sh b/src/x11-screen/x11-screen-check.sh new file mode 100755 index 000000000..e6f727c39 --- /dev/null +++ b/src/x11-screen/x11-screen-check.sh @@ -0,0 +1,16 @@ +#!/bin/sh +# +# Test the X11-SCREEN option. + +set -e +${MIT_SCHEME_EXE} --prepend-library . <<\EOF +(begin + (load-option 'X11-SCREEN) + + (if (let ((display (get-environment-variable "DISPLAY"))) + (or (not (string? display)) + (string-null? display))) + (warn "DISPLAY not set") + (edit)) + ) +EOF diff --git a/src/x11-screen/x11-screen.pkg b/src/x11-screen/x11-screen.pkg new file mode 100644 index 000000000..3a5ff34e6 --- /dev/null +++ b/src/x11-screen/x11-screen.pkg @@ -0,0 +1,215 @@ +#| -*-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 + 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 edwin/) +(global-definitions x11/) + +(define-package (edwin screen x11-screen) + (files "x11-screen") + (parent (edwin screen)) + ;; Until the microcode module based Edwin X Screen is removed, these + ;; bindings are already in (edwin) and (edwin x-commands). They + ;; cannot be exported again, and must be patched by + ;; (load-option 'x11-screen). + #;(export (edwin) + edwin-variable$x-cut-to-clipboard + edwin-variable$x-paste-from-clipboard + os/interprogram-cut + os/interprogram-paste + x-root-window-size + x-screen-ignore-focus-button? + x-selection-timeout + xterm-screen/flush! + xterm-screen/grab-focus!) + #;(export (edwin x-commands) + screen-display + screen-xterm + xterm-screen/set-icon-name + xterm-screen/set-name) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) + (import (edwin process) + register-process-output-events) + (import (edwin x-keys) + x-make-special-key) + (import (edwin x-commands) + update-xterm-screen-names!) + ;; Import bindings that, in (edwin screen x-screen), are defined by + ;; a define-primitives form. + (import (x11) + x-change-property + x-close-all-displays + x-close-display + x-close-window + x-convert-selection + x-delete-property + x-display-descriptor + x-display-flush + x-display-get-default + x-display-get-size + x-display-process-events + x-display-sync + x-get-atom-name + x-get-selection-owner + x-get-window-property + x-intern-atom + x-max-request-size + x-open-display + x-select-input + x-send-selection-notify + x-set-selection-owner + x-window-andc-event-mask + x-window-beep + x-window-display + x-window-flush + x-window-id + x-window-map + x-window-or-event-mask + x-window-raise + x-window-set-event-mask + x-window-set-icon-name + x-window-set-input-focus + x-window-set-name + xterm-clear-rectangle! + xterm-draw-cursor + xterm-dump-rectangle + xterm-enable-cursor + xterm-erase-cursor + xterm-map-x-coordinate + xterm-map-x-size + xterm-map-y-coordinate + xterm-map-y-size + xterm-open-window + xterm-reconfigure + xterm-restore-contents + xterm-save-contents + xterm-scroll-lines-down + xterm-scroll-lines-up + xterm-set-size + xterm-write-char! + xterm-write-cursor! + xterm-write-substring! + xterm-x-size + xterm-y-size) + ;; Import bindings that, in (edwin screen x-screen), are defined by + ;; optimistic stabs at FFI constants. + (import (x11) + event-type:button-down + event-type:button-up + event-type:configure + event-type:enter + event-type:focus-in + event-type:focus-out + event-type:key-press + event-type:leave + event-type:motion + event-type:expose + event-type:delete-window + event-type:map + event-type:unmap + event-type:take-focus + event-type:visibility + event-type:selection-clear + event-type:selection-notify + event-type:selection-request + event-type:property-notify + number-of-event-types)) + +#;(define-package (edwin x11-keys) + (files "x11-key") + (parent (edwin)) + (export (edwin screen x11-screen) + x-make-special-key)) + +#;(define-package (edwin x-commands) + (files "x11-com") + (parent (edwin)) + (import (edwin) + edwin-command$lower-frame + edwin-command$raise-frame + edwin-command$set-background-color + edwin-command$set-border-color + edwin-command$set-border-width + edwin-command$set-cursor-color + edwin-command$set-default-font + edwin-command$set-font + edwin-command$set-foreground-color + edwin-command$set-frame-icon-name + edwin-command$set-frame-name + edwin-command$set-frame-position + edwin-command$set-frame-size + edwin-command$set-internal-border-width + edwin-command$set-mouse-color + edwin-command$set-mouse-shape + edwin-command$show-frame-position + edwin-command$show-frame-size + edwin-command$x-lower-screen + edwin-command$x-mouse-ignore + edwin-command$x-mouse-keep-one-window + edwin-command$x-mouse-select + edwin-command$x-mouse-select-and-split + edwin-command$x-mouse-set-mark + edwin-command$x-mouse-set-point + edwin-command$x-mouse-show-event + edwin-command$x-raise-screen + edwin-command$x-set-background-color + edwin-command$x-set-border-color + edwin-command$x-set-border-width + edwin-command$x-set-cursor-color + edwin-command$x-set-font + edwin-command$x-set-foreground-color + edwin-command$x-set-icon-name + edwin-command$x-set-internal-border-width + edwin-command$x-set-mouse-color + edwin-command$x-set-mouse-shape + edwin-command$x-set-position + edwin-command$x-set-size + edwin-command$x-set-window-name + edwin-variable$frame-icon-name-format + edwin-variable$frame-icon-name-length + edwin-variable$x-screen-icon-name-format + edwin-variable$x-screen-icon-name-length + edwin-variable$x-screen-name-format + edwin-variable$x-screen-name-length + + ;; Convenience exports? Do we need non-X-specific + ;; abstractions to define mouse commands? + ;;x-button1-down + ;;x-button1-up + ;;x-button2-down + ;;x-button2-up + ;;x-button3-down + ;;x-button3-up + ;;x-button4-down + ;;x-button4-up + ;;x-button5-down + ;;x-button5-up + ) + (export (edwin screen x11-screen) + update-xterm-screen-names!)) \ No newline at end of file diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm new file mode 100644 index 000000000..b5bb4e1ac --- /dev/null +++ b/src/x11-screen/x11-screen.scm @@ -0,0 +1,1343 @@ +#| -*-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 + 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. + +|# + +;;;; X11 Screen +;;; Package: (edwin screen x11-screen) + +(declare (usual-integrations)) + +(define-integrable event:process-output -2) +(define-integrable event:process-status -3) +(define-integrable event:inferior-thread-output -4) + +(define event-mask + (apply + + + (map (lambda (nth) (shift-left 1 nth)) + (list event-type:button-down event-type:button-up event-type:configure + event-type:focus-in event-type:key-press event-type:expose + event-type:delete-window event-type:map event-type:unmap + event-type:visibility event-type:selection-clear + event-type:selection-notify event-type:selection-request + event-type:property-notify)))) + +(define-structure (xterm-screen-state + (constructor make-xterm-screen-state (xterm display)) + (conc-name xterm-screen-state/)) + (xterm #f read-only #t) + (display #f read-only #t) + (redisplay-flag #t) + (selected? #t) + (name #f) + (icon-name #f) + (x-visibility 'VISIBLE) + (mapped? #f) + (unexposed? #t)) + +(define screen-list) + +(define (make-xterm-screen #!optional geometry) + ;; Don't map the window until all of the data structures are in + ;; place. This guarantees that no events will be missed. + (let ((xterm + (open-window (null? screen-list) + (if (default-object? geometry) #f geometry)))) + (x-window-set-event-mask xterm event-mask) + (let ((screen + (make-screen (make-xterm-screen-state xterm + (x-window-display xterm)) + xterm-screen/beep + xterm-screen/clear-line! + xterm-screen/clear-rectangle! + xterm-screen/clear-screen! + xterm-screen/discard! + xterm-screen/enter! + xterm-screen/exit! + xterm-screen/flush! + xterm-screen/modeline-event! + #f + xterm-screen/scroll-lines-down! + xterm-screen/scroll-lines-up! + xterm-screen/wrap-update! + xterm-screen/write-char! + xterm-screen/write-cursor! + xterm-screen/write-substring! + 8 + (xterm-x-size xterm) + (xterm-y-size xterm)))) + (set! screen-list (cons screen screen-list)) + (update-visibility! screen) + (x-window-map xterm) + (x-window-flush xterm) + screen))) + +(define (open-window primary? geometry) + (let ((display (or (get-x-display) (error "Unable to open display."))) + (instance (if primary? "edwin" "edwinSecondary")) + (class "Emacs")) + (xterm-open-window display + (or geometry + (get-geometry display primary? instance class)) + (vector #f instance class)))) + +(define (get-geometry display primary? instance class) + (or (x-display-get-geometry display instance) + (let ((geometry (x-display-get-geometry display class))) + (and geometry + (if primary? geometry (strip-position-from-geometry geometry)))) + "80x40")) + +(define (x-display-get-geometry display key) + (or (x-display-get-default display key "geometry") + (x-display-get-default display key "Geometry"))) + +(define (strip-position-from-geometry geometry) + (let ((sign + (or (string-find-next-char geometry #\+) + (string-find-next-char geometry #\-)))) + (if sign + (string-head geometry sign) + geometry))) + +(define (x-root-window-size) + (x-display-get-size (or (get-x-display) (error "Unable to open display.")) + 0)) + +;;; According to the Xlib manual, we're not allowed to draw anything +;;; on the window until the first Expose event arrives. The manual +;;; says nothing about the relationship between this event and the +;;; MapNotify event associated with that mapping. We use the fields +;;; UNEXPOSED? and MAPPED? to track the arrival of those events. +;;; The screen's visibility remains 'UNMAPPED until both have arrived. +;;; Meanwhile, X-VISIBILITY tracks Visibility events. When the window +;;; is both exposed and mapped, VISIBILITY reflects X-VISIBILITY. + +(define (screen-x-visibility screen) + (xterm-screen-state/x-visibility (screen-state screen))) + +(define (set-screen-x-visibility! screen flag) + (set-xterm-screen-state/x-visibility! (screen-state screen) flag) + (update-visibility! screen)) + +(define (screen-mapped? screen) + (xterm-screen-state/mapped? (screen-state screen))) + +(define (set-screen-mapped?! screen flag) + (set-xterm-screen-state/mapped?! (screen-state screen) flag) + (update-visibility! screen)) + +(define (screen-unexposed? screen) + (xterm-screen-state/unexposed? (screen-state screen))) + +(define (set-screen-unexposed?! screen value) + (set-xterm-screen-state/unexposed?! (screen-state screen) value)) + +(define-integrable (screen-exposed? screen) + (not (screen-unexposed? screen))) + +(define (note-xterm-exposed xterm) + (let ((screen (xterm->screen xterm))) + (if screen + (let ((unexposed? (screen-unexposed? screen))) + (if unexposed? + (begin + (set-screen-unexposed?! screen #f) + (update-visibility! screen) + (if (eq? 'ENTERED unexposed?) + (xterm-screen/enter! screen)))))))) + +(define (update-visibility! screen) + (if (not (screen-deleted? screen)) + (set-screen-visibility! screen + (if (and (screen-mapped? screen) + (screen-exposed? screen)) + (screen-x-visibility screen) + 'UNMAPPED)))) + +(define (screen-xterm screen) + (xterm-screen-state/xterm (screen-state screen))) + +(define (xterm->screen xterm) + (let loop ((screens screen-list)) + (and (not (null? screens)) + (if (alien=? xterm (screen-xterm (car screens))) + (car screens) + (loop (cdr screens)))))) + +(define (screen-display screen) + (xterm-screen-state/display (screen-state screen))) + +(define (screen-redisplay-flag screen) + (xterm-screen-state/redisplay-flag (screen-state screen))) + +(define (set-screen-redisplay-flag! screen flag) + (set-xterm-screen-state/redisplay-flag! (screen-state screen) flag)) + +(define (screen-selected? screen) + (xterm-screen-state/selected? (screen-state screen))) + +(define (set-screen-selected?! screen selected?) + (set-xterm-screen-state/selected?! (screen-state screen) selected?)) + +(define (screen-name screen) + (xterm-screen-state/name (screen-state screen))) + +(define (set-screen-name! screen name) + (set-xterm-screen-state/name! (screen-state screen) name)) + +(define (xterm-screen/set-name screen name) + (let ((name* (screen-name screen))) + (if (or (not name*) (not (string=? name name*))) + (begin + (set-screen-name! screen name) + (x-window-set-name (screen-xterm screen) name))))) + +(define (screen-icon-name screen) + (xterm-screen-state/icon-name (screen-state screen))) + +(define (set-screen-icon-name! screen name) + (set-xterm-screen-state/icon-name! (screen-state screen) name)) + +(define (xterm-screen/set-icon-name screen name) + (let ((name* (screen-icon-name screen))) + (if (or (not name*) (not (string=? name name*))) + (begin + (set-screen-icon-name! screen name) + (x-window-set-icon-name (screen-xterm screen) name))))) + +(define (xterm-screen/wrap-update! screen thunk) + (let ((finished? #f)) + (dynamic-wind + (lambda () + (xterm-enable-cursor (screen-xterm screen) #f)) + (lambda () + (let ((result (thunk))) + (set! finished? result) + result)) + (lambda () + (if (screen-selected? screen) + (let ((xterm (screen-xterm screen))) + (xterm-enable-cursor xterm #t) + (xterm-draw-cursor xterm))) + (if (and finished? (screen-redisplay-flag screen)) + (begin + (update-xterm-screen-names! screen) + (set-screen-redisplay-flag! screen #f))) + (xterm-screen/flush! screen))))) + +(define (xterm-screen/discard! screen) + (set! screen-list (delq! screen screen-list)) + (x-close-window (screen-xterm screen))) + +(define (xterm-screen/modeline-event! screen window type) + window type ; ignored + (set-screen-redisplay-flag! screen #t)) + +(define (xterm-screen/enter! screen) + (if (screen-unexposed? screen) + (set-screen-unexposed?! screen 'ENTERED) + (begin + (set-screen-selected?! screen #t) + (let ((xterm (screen-xterm screen))) + (xterm-enable-cursor xterm #t) + (xterm-draw-cursor xterm)) + (xterm-screen/grab-focus! screen) + (xterm-screen/flush! screen)))) + +(define (xterm-screen/grab-focus! screen) + (and last-focus-time + (not (screen-deleted? screen)) + (screen-mapped? screen) + (begin + (x-window-set-input-focus (screen-xterm screen) last-focus-time) + #t))) + +(define (xterm-screen/exit! screen) + (set-screen-selected?! screen #f) + (let ((xterm (screen-xterm screen))) + (xterm-enable-cursor xterm #f) + (xterm-erase-cursor xterm)) + (xterm-screen/flush! screen)) + +(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount) + (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount) + 'UNCHANGED) + +(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount) + (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount) + 'UNCHANGED) + +(define (xterm-screen/beep screen) + (x-window-beep (screen-xterm screen)) + (xterm-screen/flush! screen)) + +(define (xterm-screen/flush! screen) + (x-display-flush (screen-display screen))) + +(define (xterm-screen/write-char! screen x y char highlight) + (xterm-write-char! (screen-xterm screen) x y char (if highlight 1 0))) + +(define (xterm-screen/write-cursor! screen x y) + (xterm-write-cursor! (screen-xterm screen) x y)) + +(define (xterm-screen/write-substring! screen x y string start end highlight) + (xterm-write-substring! (screen-xterm screen) x y string start end + (if highlight 1 0))) + +(define (xterm-screen/clear-line! screen x y first-unused-x) + (xterm-clear-rectangle! (screen-xterm screen) + x first-unused-x y (fix:1+ y) 0)) + +(define (xterm-screen/clear-rectangle! screen xl xu yl yu highlight) + (xterm-clear-rectangle! (screen-xterm screen) + xl xu yl yu (if highlight 1 0))) + +(define (xterm-screen/clear-screen! screen) + (xterm-clear-rectangle! (screen-xterm screen) + 0 (screen-x-size screen) 0 (screen-y-size screen) 0)) + +;;;; Event Handling + +(define (get-xterm-input-operations) + (let ((display x-display-data) + (queue x-display-events) + (pending-result #f) + (string #f) + (start 0) + (end 0)) + (let ((process-key-press-event + (lambda (event) + (set! last-focus-time (vector-ref event 5)) + (set! string (vector-ref event 2)) + (set! end (string-length string)) + (set! start end) + (cond ((fix:= end 0) + (x-make-special-key (vector-ref event 4) + (vector-ref event 3))) + ((fix:= end 1) + (let ((char + (merge-bucky-bits (string-ref string 0) + (vector-ref event 3)))) + (if (and signal-interrupts? (char=? char #\BEL)) + (begin + (signal-interrupt!) + #f) + char))) + (else + (let ((i + (and signal-interrupts? + (string-find-previous-char string #\BEL)))) + (if i + (begin + (set! start (fix:+ i 1)) + (signal-interrupt!) + (and (fix:< start end) + (let ((result (string-ref string start))) + (set! start (fix:+ start 1)) + result))) + (begin + (set! start 1) + (string-ref string 0))))))))) + (let ((process-event + (lambda (event) + (if (fix:= event-type:key-press (vector-ref event 0)) + (process-key-press-event event) + (process-special-event event)))) + (pce-event + (lambda (flag) + (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE) + update-screens! + #f)))) + (let ((get-next-event + (lambda (block?) + (let loop () + (let ((event (read-event queue display block?))) + (cond ((or (not event) (input-event? event)) + event) + ((not (vector? event)) + (let ((flag (process-change-event event))) + (if flag + (pce-event flag) + (loop)))) + (else + (or (process-event event) + (loop))))))))) + (let ((probe + (lambda (block?) + (let ((result (get-next-event block?))) + (if result + (set! pending-result result)) + result))) + (guarantee-result + (lambda () + (or (get-next-event #t) + (error "#F returned from blocking read"))))) + (values + (lambda () ;halt-update? + (or pending-result + (fix:< start end) + (probe 'IN-UPDATE))) + (lambda (timeout) ;peek-no-hang + (keyboard-peek-busy-no-hang + (lambda () + (or pending-result + (and (fix:< start end) + (string-ref string start)) + (probe #f))) + timeout)) + (lambda () ;peek + (or pending-result + (if (fix:< start end) + (string-ref string start) + (let ((result (guarantee-result))) + (set! pending-result result) + result)))) + (lambda () ;read + (cond (pending-result + => (lambda (result) + (set! pending-result #f) + result)) + ((fix:< start end) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char)) + (else + (guarantee-result))))))))))) + +(define (read-event queue display block?) + (preview-events display queue) + (let ((event + (if (queue-empty? queue) + (if (eq? 'IN-UPDATE block?) + #f + (read-event-1 display block?)) + (dequeue!/unsafe queue)))) + (if (and event trace-port) + (write-line event trace-port)) + event)) + +(define (preview-events display queue) + (let loop () + (let ((event (x-display-process-events display 2))) + (if event + (begin (preview-event event queue) + (loop)))))) + +(define trace-port #f) + +(define (start-trace filename) + (stop-trace) + (set! trace-port (open-output-file filename)) + unspecific) + +(define (stop-trace) + (let ((port trace-port)) + (set! trace-port #f) + (if port (close-port port)))) + +(define (process-expose-event event) + (let ((xterm (vector-ref event 1))) + ;; If this is the first Expose event for this window, it + ;; requires special treatment. Element 6 of the event + ;; is 0 for Expose events and 1 for GraphicsExpose + ;; events. + (if (eq? 0 (vector-ref event 6)) + (note-xterm-exposed xterm)) + (xterm-dump-rectangle xterm + (vector-ref event 2) + (vector-ref event 3) + (vector-ref event 4) + (vector-ref event 5)))) + +(define (read-event-1 display block?) + ;; Now consider other (non-X) events. + (if (eq? '#T block?) + (let loop () + (let ((event (block-for-event display))) + (or event + (loop)))) + (cond (inferior-thread-changes? + event:inferior-thread-output) + ((process-output-available?) + event:process-output) + ((process-status-changes?) + event:process-status) + (else #f)))) + +(define (block-for-event display) + (let ((x-events-available? #f) + (output-available? #f) + (registrations)) + (dynamic-wind + (lambda () + (let ((thread (current-thread))) + (set! registrations + (cons + (register-io-thread-event + (x-display-descriptor display) 'READ + thread (lambda (mode) + mode + (set! x-events-available? #t))) + (register-process-output-events + thread (lambda (mode) + mode + (set! output-available? #t))))))) + (lambda () + (let loop () + (with-thread-events-blocked + (lambda () + (if (and (not x-events-available?) + (not output-available?) + (not (process-status-changes?)) + (not inferior-thread-changes?)) + (suspend-current-thread)))) + (cond (x-events-available? + (let ((queue x-display-events)) + (preview-events display queue) + (if (queue-empty? queue) + #f + (dequeue!/unsafe queue)))) + ((process-status-changes?) + event:process-status) + (output-available? + event:process-output) + (inferior-thread-changes? + event:inferior-thread-output) + (else + (loop))))) + (lambda () + (for-each deregister-io-thread-event registrations) + (set! registrations))))) + +(define (wait-for-event interval predicate process-event) + (let ((timeout (+ (real-time-clock) interval))) + (let loop () + (let ((event (x-display-process-events x-display-data 2))) + (if event + (if (and (vector? event) (predicate event)) + (or (process-event event) (loop)) + (begin (preview-event event x-display-events) (loop))) + ;; Busy loop! + (and (< (real-time-clock) timeout) + (loop))))))) + +(define (preview-event event queue) + (cond ((and signal-interrupts? + (vector? event) + (fix:= event-type:key-press (vector-ref event 0)) + (let ((string (vector-ref event 2))) + (if (fix:= 1 (string-length string)) + (char=? #\BEL + (merge-bucky-bits (string-ref string 0) + (vector-ref event 3))) + (string-find-next-char string #\BEL)))) + (clean-event-queue queue) + (signal-interrupt!)) + ((and (vector? event) + (fix:= event-type:expose (vector-ref event 0))) + (process-expose-event event)) + ((and (vector? event) + (or (fix:= event-type:map (vector-ref event 0)) + (fix:= event-type:unmap (vector-ref event 0)) + (fix:= event-type:visibility (vector-ref event 0)))) + (let ((result (process-special-event event))) + (if result + (enqueue!/unsafe queue result)))) + (else + (enqueue!/unsafe queue event)))) + +(define (clean-event-queue queue) + ;; Flush keyboard and mouse events from the input queue. Other + ;; events are harmless and must be processed regardless. + (do ((events (let loop () + (if (queue-empty? queue) + '() + (let ((event (dequeue!/unsafe queue))) + (if (and (vector? event) + (let ((type (vector-ref event 0))) + (or (fix:= type event-type:button-down) + (fix:= type event-type:button-up) + (fix:= type event-type:key-press) + (fix:= type event-type:motion)))) + (loop) + (cons event (loop)))))) + (cdr events))) + ((null? events)) + (enqueue!/unsafe queue (car events)))) + +(define (process-change-event event) + (cond ((fix:= event event:process-status) (handle-process-status-changes)) + ((fix:= event event:process-output) (accept-process-output)) + ((fix:= event event:inferior-thread-output) (accept-thread-output)) + (else (error "Illegal change event:" event)))) + +(define (process-special-event event) + (let ((handler (vector-ref event-handlers (vector-ref event 0)))) + (and handler + (if (vector-ref event 1) + (let ((screen (xterm->screen (vector-ref event 1)))) + (and screen + (handler screen event))) + (handler #f event))))) + +(define event-handlers + (make-vector number-of-event-types #f)) + +(define (define-event-handler event-type handler) + (vector-set! event-handlers event-type handler)) + +(define-event-handler event-type:button-down + (lambda (screen event) + (set! last-focus-time (vector-ref event 5)) + (if (eq? ignore-button-state 'IGNORE-BUTTON-DOWN) + (begin + (set! ignore-button-state 'IGNORE-BUTTON-UP) + #f) + (let ((xterm (screen-xterm screen))) + (make-input-event + 'BUTTON + execute-button-command + screen + (let ((n (vector-ref event 4))) + (make-down-button (fix:and n #x0FF) + (fix:lsh (fix:and n #xF00) -8))) + (xterm-map-x-coordinate xterm (vector-ref event 2)) + (xterm-map-y-coordinate xterm (vector-ref event 3))))))) + +(define-event-handler event-type:button-up + (lambda (screen event) + (set! last-focus-time (vector-ref event 5)) + (if (eq? ignore-button-state 'IGNORE-BUTTON-UP) + (begin + (set! ignore-button-state #f) + #f) + (let ((xterm (screen-xterm screen))) + (make-input-event + 'BUTTON + execute-button-command + screen + (let ((n (vector-ref event 4))) + (make-up-button (fix:and n #x0FF) + (fix:lsh (fix:and n #xF00) -8))) + (xterm-map-x-coordinate xterm (vector-ref event 2)) + (xterm-map-y-coordinate xterm (vector-ref event 3))))))) + +(define-event-handler event-type:configure + (lambda (screen event) + (make-input-event 'SET-SCREEN-SIZE + (lambda (screen event) + (let ((xterm (screen-xterm screen)) + (x-size (vector-ref event 2)) + (y-size (vector-ref event 3))) + (let ((x-size (xterm-map-x-size xterm x-size)) + (y-size (xterm-map-y-size xterm y-size))) + (xterm-reconfigure xterm x-size y-size) + (if (not (and (= x-size (screen-x-size screen)) + (= y-size (screen-y-size screen)))) + (begin + (set-screen-size! screen x-size y-size) + (update-screen! screen #t)))))) + screen event))) + +(define x-screen-ignore-focus-button? #f) + +(define-event-handler event-type:focus-in + (lambda (screen event) + event + (if x-screen-ignore-focus-button? + (set! ignore-button-state 'IGNORE-BUTTON-DOWN)) + (and (not (selected-screen? screen)) + (make-input-event 'SELECT-SCREEN + (lambda (screen) + (fluid-let ((last-focus-time #f)) + (select-screen screen))) + screen)))) + +(define-event-handler event-type:delete-window + (lambda (screen event) + event + (and (not (screen-deleted? screen)) + (make-input-event 'DELETE-SCREEN delete-screen! screen)))) + +(define-event-handler event-type:map + (lambda (screen event) + event + (and (not (screen-deleted? screen)) + (begin + (set-screen-mapped?! screen #t) + (screen-force-update screen) + (make-input-event 'UPDATE update-screen! screen #f))))) + +(define-event-handler event-type:unmap + (lambda (screen event) + event + (if (not (screen-deleted? screen)) + (set-screen-mapped?! screen #f)) + #f)) + +(define-event-handler event-type:visibility + (lambda (screen event) + (and (not (screen-deleted? screen)) + (let ((old-visibility (screen-x-visibility screen))) + (case (vector-ref event 2) + ((0) (set-screen-x-visibility! screen 'VISIBLE)) + ((1) (set-screen-x-visibility! screen 'PARTIALLY-OBSCURED)) + ((2) (set-screen-x-visibility! screen 'OBSCURED))) + (and (eq? old-visibility 'OBSCURED) + (begin + (screen-force-update screen) + (make-input-event 'UPDATE update-screen! screen #f))))))) + +(define-event-handler event-type:take-focus + (lambda (screen event) + (set! last-focus-time (vector-ref event 2)) + (make-input-event 'SELECT-SCREEN select-screen screen))) + +;;;; Atoms + +(define built-in-atoms + '#(#F + PRIMARY + SECONDARY + ARC + ATOM + BITMAP + CARDINAL + COLORMAP + CURSOR + CUT_BUFFER0 + CUT_BUFFER1 + CUT_BUFFER2 + CUT_BUFFER3 + CUT_BUFFER4 + CUT_BUFFER5 + CUT_BUFFER6 + CUT_BUFFER7 + DRAWABLE + FONT + INTEGER + PIXMAP + POINT + RECTANGLE + RESOURCE_MANAGER + RGB_COLOR_MAP + RGB_BEST_MAP + RGB_BLUE_MAP + RGB_DEFAULT_MAP + RGB_GRAY_MAP + RGB_GREEN_MAP + RGB_RED_MAP + STRING + VISUALID + WINDOW + WM_COMMAND + WM_HINTS + WM_CLIENT_MACHINE + WM_ICON_NAME + WM_ICON_SIZE + WM_NAME + WM_NORMAL_HINTS + WM_SIZE_HINTS + WM_ZOOM_HINTS + MIN_SPACE + NORM_SPACE + MAX_SPACE + END_SPACE + SUPERSCRIPT_X + SUPERSCRIPT_Y + SUBSCRIPT_X + SUBSCRIPT_Y + UNDERLINE_POSITION + UNDERLINE_THICKNESS + STRIKEOUT_ASCENT + STRIKEOUT_DESCENT + ITALIC_ANGLE + X_HEIGHT + QUAD_WIDTH + WEIGHT + POINT_SIZE + RESOLUTION + COPYRIGHT + NOTICE + FONT_NAME + FAMILY_NAME + FULL_NAME + CAP_HEIGHT + WM_CLASS + WM_TRANSIENT_FOR)) + +(define (symbol->x-atom display name soft?) + (or (hash-table/get built-in-atoms-table name #f) + (let ((table (car (display/cached-atoms-tables display)))) + (or (hash-table/get table name #f) + (let ((atom + (x-intern-atom display + (string-upcase (symbol-name name)) + soft?))) + (if (not (= atom 0)) + (hash-table/put! table name atom)) + atom))))) + +(define (x-atom->symbol display atom) + (if (< atom (vector-length built-in-atoms)) + (vector-ref built-in-atoms atom) + (let ((table (cdr (display/cached-atoms-tables display)))) + (or (hash-table/get table atom #f) + (let ((symbol + (let ((string (x-get-atom-name display atom))) + (if (not (string? string)) + (error "X error (XGetAtomName):" string atom)) + (intern string)))) + (hash-table/put! table atom symbol) + symbol))))) + +(define built-in-atoms-table + (let ((n (vector-length built-in-atoms))) + (let ((table (make-strong-eq-hash-table n))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (hash-table/put! table (vector-ref built-in-atoms i) i)) + table))) + +(define display/cached-atoms-tables + (let ((table (make-weak-eq-hash-table))) + (lambda (display) + (or (hash-table/get table display #f) + (let ((result + (cons (make-strong-eq-hash-table) + (make-strong-eqv-hash-table)))) + (hash-table/put! table display result) + result))))) + +;;;; Properties + +(define (get-xterm-property xterm property type delete?) + (get-window-property (x-window-display xterm) + (x-window-id xterm) + property + type + delete?)) + +(define (get-window-property display window property type delete?) + (let ((property (symbol->x-atom display property #f)) + (type-atom (symbol->x-atom display type #f))) + (let ((v (x-get-window-property display window property 0 0 #f type-atom))) + (and v + (vector-ref v 3) + (let ((data + (get-window-property-1 display window property delete? + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2)))) + (if type + data + (cons (x-atom->symbol display (vector-ref v 0)) + data))))))) + +(define (get-window-property-1 display window property delete? + type format bytes) + (let ((read-once + (lambda (offset bytes n delete?) + (let ((v + (x-get-window-property display window property + (quotient offset 4) + (integer-ceiling n 4) + delete? type))) + (if (not (and v + (= type (vector-ref v 0)) + (= format (vector-ref v 1)) + (= (- bytes n) (vector-ref v 2)) + (vector-ref v 3) + (= n + (if (= format 8) + (string-length (vector-ref v 3)) + (* (vector-length (vector-ref v 3)) + (quotient format 8)))))) + (error "Window property changed:" v)) + (vector-ref v 3)))) + (qb (* (property-quantum display) 4))) + (if (<= bytes qb) + (read-once 0 bytes bytes delete?) + (let ((b/w (quotient format 8))) + (let ((result + (if (= b/w 1) + (make-string bytes) + (make-vector (quotient bytes b/w)))) + (move! + (if (= b/w 1) + substring-move-right! + subvector-move-right!))) + (let loop ((offset 0) (bytes bytes)) + (if (<= bytes qb) + (move! (read-once offset bytes bytes delete?) + 0 (quotient bytes b/w) + result (quotient offset b/w)) + (begin + (move! (read-once offset bytes qb #f) 0 (quotient qb b/w) + result (quotient offset b/w)) + (loop (+ offset qb) (- bytes qb))))) + result))))) + +(define (put-window-property display window property type format data) + (let ((put-1 + (let ((property (symbol->x-atom display property #f)) + (type (symbol->x-atom display type #f))) + (lambda (mode data) + (let ((status + (x-change-property display window property type format + mode data))) + (cond ((= status x-status:success) + #t) + ((= status x-status:bad-alloc) + (x-delete-property display window property) + #f) + (else + (error "X error (XChangeProperty):" status))))))) + (qw (property-quantum display)) + (i/w (quotient 32 format)) + (subpart (if (= format 8) substring subvector)) + (end (if (= format 8) (string-length data) (vector-length data))) + (mode:replace 0) + (mode:append 2)) + (let loop ((start 0) (nw (integer-ceiling end i/w)) (mode mode:replace)) + (if (<= nw qw) + (put-1 mode (if (= start 0) data (subpart data start end))) + (let ((end (+ start (* qw i/w)))) + (and (put-1 mode (subpart data start end)) + (loop end (- nw qw) mode:append))))))) + +(define (property-quantum display) + ;; The limit on the size of a property quantum is the maximum + ;; request size less the size of the largest header needed. The + ;; relevant packets are the GetProperty reply packet (header size 8) + ;; and the ChangeProperty request packet (header size 6). The magic + ;; number 8 is the larger of these two header sizes. + (fix:- (x-max-request-size display) 8)) + +(define (delete-xterm-property xterm property) + (delete-window-property (x-window-display xterm) + (x-window-id xterm) + property)) + +(define (delete-window-property display window property) + (x-delete-property display window (symbol->x-atom display property #f))) + +(define-integrable x-status:success 0) +(define-integrable x-status:bad-request 1) +(define-integrable x-status:bad-value 2) +(define-integrable x-status:bad-window 3) +(define-integrable x-status:bad-pixmap 4) +(define-integrable x-status:bad-atom 5) +(define-integrable x-status:bad-cursor 6) +(define-integrable x-status:bad-font 7) +(define-integrable x-status:bad-match 8) +(define-integrable x-status:bad-drawable 9) +(define-integrable x-status:bad-access 10) +(define-integrable x-status:bad-alloc 11) +(define-integrable x-status:bad-color 12) +(define-integrable x-status:bad-gc 13) +(define-integrable x-status:bad-id-choice 14) +(define-integrable x-status:bad-name 15) +(define-integrable x-status:bad-length 16) +(define-integrable x-status:bad-implementation 17) + +;;;; Selection Source + +(define-variable x-cut-to-clipboard + "If true, cutting text copies to the clipboard. +In either case, it is copied to the primary selection." + #t + boolean?) + +(set! + os/interprogram-cut + (named-lambda (os/interprogram-cut string context) + (if (eq? x-display-type (current-display-type)) + (let ((xterm (screen-xterm (selected-screen)))) + (let ((own-selection + (lambda (selection) + (own-selection (x-window-display xterm) + selection + (x-window-id xterm) + last-focus-time + string)))) + (own-selection 'PRIMARY) + (if (ref-variable x-cut-to-clipboard context) + (own-selection 'CLIPBOARD))))))) + +(define (own-selection display selection window time value) + (and (eqv? window + (let ((selection (symbol->x-atom display selection #f))) + (x-set-selection-owner display selection window time) + (x-get-selection-owner display selection))) + (begin + (hash-table/put! (display/selection-records display) + selection + (make-selection-record window time value)) + #t))) + +(define display/selection-records + (let ((table (make-weak-eq-hash-table))) + (lambda (display) + (or (hash-table/get table display #f) + (let ((result (make-strong-eq-hash-table))) + (hash-table/put! table display result) + result))))) + +;;; In the next two procedures, we must allow TIME to be 0, even +;;; though the ICCCM forbids this, because existing clients use that +;;; value. An example of a broken client is GTK+ version 1.2.6. + +(define (display/selection-record display name time) + (let ((record (hash-table/get (display/selection-records display) name #f))) + (and record + (or (= 0 time) (<= (selection-record/time record) time)) + record))) + +(define (display/delete-selection-record! display name time) + (let ((records (display/selection-records display))) + (if (let ((record (hash-table/get records name #f))) + (and record + (or (= 0 time) (<= (selection-record/time record) time)))) + (hash-table/remove! records name)))) + +(define-structure (selection-record (conc-name selection-record/)) + (window #f read-only #t) + (time #f read-only #t) + (value #f read-only #t)) + +(define-event-handler event-type:selection-request + (lambda (screen event) + screen + (let ((display x-display-data)) + (let ((requestor (selection-request/requestor event)) + (selection + (x-atom->symbol display (selection-request/selection event))) + (target + (x-atom->symbol display (selection-request/target event))) + (property + (x-atom->symbol display (selection-request/property event))) + (time (selection-request/time event))) + (let ((reply + (lambda (property) + (x-send-selection-notify display + requestor + (selection-request/selection event) + (selection-request/target event) + (symbol->x-atom display property #f) + time) + (x-display-flush display)))) + (if (let ((record (display/selection-record display selection time))) + (and record + property + (process-selection-request display requestor property + target time record #f))) + (reply property) + (reply #f))))) + #f)) + +(define-structure (selection-request (type vector) + (initial-offset 2) + (conc-name selection-request/)) + (requestor #f read-only #t) + (selection #f read-only #t) + (target #f read-only #t) + (property #f read-only #t) + (time #f read-only #t)) + +(define-event-handler event-type:selection-clear + (lambda (screen event) + screen + (let ((display x-display-data)) + (display/delete-selection-record! + display + (x-atom->symbol display (selection-clear/selection event)) + (selection-clear/time event))) + #f)) + +(define-structure (selection-clear (type vector) + (initial-offset 2) + (conc-name selection-clear/)) + (selection #f read-only #t) + (time #f read-only #t)) + +(define (process-selection-request display requestor property target time + record multiple?) + (let ((win + (lambda (format data) + (and (put-window-property display requestor property target format + data) + target)))) + (case target + ((STRING) + (win 8 (selection-record/value record))) + ((TARGETS) + (win 32 (atoms->property-data '(STRING TIMESTAMP) display))) + ((TIMESTAMP) + (win 32 (timestamp->property-data (selection-record/time record)))) + ((MULTIPLE) + (and multiple? + (let ((alist + (property-data->atom-alist + (or (get-window-property display requestor property + 'MULTIPLE #f) + (error "Missing MULTIPLE property:" property)) + display))) + (for-each (lambda (entry) + (set-car! entry + (process-selection-request display + requestor + (cdr entry) + (car entry) + time + record + #t))) + alist) + (win 32 (atom-alist->property-data alist display))))) + (else #f)))) + +(define (atoms->property-data names display) + (list->vector (map (lambda (name) (symbol->x-atom display name #f)) names))) + +(define (timestamp->property-data time) + (vector time)) + +(define (property-data->atom-alist data display) + (if (not (even? (vector-length data))) + (error:bad-range-argument data 'PROPERTY-DATA->ATOM-ALIST)) + (let loop ((atoms + (map (lambda (atom) (x-atom->symbol display atom)) + (vector->list data)))) + (if (null? atoms) + '() + (cons (cons (car atoms) (cadr atoms)) + (loop (cddr atoms)))))) + +(define (atom-alist->property-data alist display) + (atoms->property-data (let loop ((alist alist)) + (if (null? alist) + '() + (cons (caar alist) + (cons (cdar alist) + (loop (cdr alist)))))) + display)) + +;;;; Selection Sink + +(define-variable x-paste-from-clipboard + "If true, pasting text copies from the clipboard. +Otherwise, it is copied from the primary selection." + #t + boolean?) + +(set! + os/interprogram-paste + (named-lambda (os/interprogram-paste context) + (and (eq? x-display-type (current-display-type)) + (xterm/interprogram-paste (screen-xterm (selected-screen)) context)))) + +(define (xterm/interprogram-paste xterm context) + (or (and (ref-variable x-paste-from-clipboard context) + (xterm/interprogram-paste-1 xterm 'CLIPBOARD)) + (xterm/interprogram-paste-1 xterm 'PRIMARY))) + +(define (xterm/interprogram-paste-1 xterm selection) + (with-thread-events-blocked + (lambda () + (let ((property '_EDWIN_TMP_) + (time last-focus-time)) + (cond ((display/selection-record (x-window-display xterm) + selection time) + => selection-record/value) + ((request-selection xterm selection 'STRING property time) + (receive-selection xterm property 'STRING time)) + ((request-selection xterm selection 'C_STRING property time) + (receive-selection xterm property 'C_STRING time)) + (else #f)))))) + +(define (request-selection xterm selection target property time) + (let ((display (x-window-display xterm)) + (window (x-window-id xterm))) + (let ((selection (symbol->x-atom display selection #f)) + (target (symbol->x-atom display target #f)) + (property (symbol->x-atom display property #f))) + (x-delete-property display window property) + (x-convert-selection display selection target property window time) + (x-display-flush display) + (eq? 'REQUEST-GRANTED + (wait-for-event x-selection-timeout + (lambda (event) + (fix:= event-type:selection-notify (vector-ref event 0))) + (lambda (event) + (and (= window (selection-notify/requestor event)) + (= selection (selection-notify/selection event)) + (= target (selection-notify/target event)) + (= time (selection-notify/time event)) + (if (= property (selection-notify/property event)) + 'REQUEST-GRANTED + 'REQUEST-DENIED)))))))) + +(define-structure (selection-notify (type vector) + (initial-offset 2) + (conc-name selection-notify/)) + (requestor #f read-only #t) + (selection #f read-only #t) + (target #f read-only #t) + (property #f read-only #t) + (time #f read-only #t)) + +(define (receive-selection xterm property target time) + (let ((value (get-xterm-property xterm property #f #t))) + (if (not value) + (error "Missing selection value.")) + (if (eq? 'INCR (car value)) + (receive-incremental-selection xterm property target time) + (and (eq? target (car value)) + (cdr value))))) + +(define (receive-incremental-selection xterm property target time) + ;; I have been unable to get this to work, after a day of hacking, + ;; and I don't have any idea why it won't work. Given that this + ;; will only be used for selections of size exceeding ~230kb, I'm + ;; going to leave it broken. -- cph + (x-window-flush xterm) + (let loop ((time time) (accum '())) + (let ((time + (wait-for-window-property-change xterm property time + x-property-state:new-value))) + (if (not time) + (error "Timeout waiting for PROPERTY-NOTIFY event.")) + (let ((value (get-xterm-property xterm property target #t))) + (if (not value) + (error "Missing property after PROPERTY-NOTIFY event.")) + (if (string-null? value) + (apply string-append (reverse! accum)) + (loop time (cons value accum))))))) + +(define (wait-for-window-property-change xterm property time state) + (wait-for-event x-selection-timeout + (lambda (event) + (fix:= event-type:property-notify (vector-ref event 0))) + (let ((property (symbol->x-atom (x-window-display xterm) property #f)) + (window (x-window-id xterm))) + (lambda (event) + (and (= window (property-notify/window event)) + (= property (property-notify/property event)) + (< time (property-notify/time event)) + (= state (property-notify/state event)) + (property-notify/time event)))))) + +(define-structure (property-notify (type vector) + (initial-offset 2) + (conc-name property-notify/)) + (window #f read-only #t) + (property #f read-only #t) + (time #f read-only #t) + (state #f read-only #t)) + +(define-integrable x-property-state:new-value 0) +(define-integrable x-property-state:delete 1) + +(define x-selection-timeout 5000) + +;;;; Interrupts + +(define signal-interrupts?) +(define last-focus-time) +(define ignore-button-state) + +(define (with-editor-interrupts-from-x receiver) + (fluid-let ((signal-interrupts? #t) + (last-focus-time #f) + (ignore-button-state #f)) + (receiver (lambda (thunk) (thunk)) '()))) + +(define (with-x-interrupts-enabled thunk) + (with-signal-interrupts #t thunk)) + +(define (with-x-interrupts-disabled thunk) + (with-signal-interrupts #f thunk)) + +(define (with-signal-interrupts enabled? thunk) + (let ((old)) + (dynamic-wind (lambda () + (set! old signal-interrupts?) + (set! signal-interrupts? enabled?) + unspecific) + thunk + (lambda () + (set! enabled? signal-interrupts?) + (set! signal-interrupts? old) + unspecific)))) + +(define (signal-interrupt!) + (editor-beep) + (temporary-message "Quit") + (^G-signal)) + +;;;; Initialization + +(define x-display-type) +(define x-display-data) +(define x-display-events) +(define x-display-name #f) + +(define (reset-x-display!) + (set! x-display-data #f) + (set! x-display-events) + unspecific) + +(define (get-x-display) + ;; X-OPEN-DISPLAY hangs, uninterruptibly, when the X server is + ;; running the login loop of xdm. Can this be fixed? + (or x-display-data + (and (or x-display-name (get-environment-variable "DISPLAY")) + (plugin-available? "x11") + (begin + (load-option 'X11) + (let ((display (x-open-display x-display-name))) + (set! x-display-data display) + (set! x-display-events (make-queue)) + display))))) + +(define (initialize-package!) + (set! screen-list '()) + (set! x-display-type + (make-display-type 'X11 + #t + get-x-display + make-xterm-screen + (lambda (screen) + screen ;ignore + (get-xterm-input-operations)) + with-editor-interrupts-from-x + with-x-interrupts-enabled + with-x-interrupts-disabled)) + (reset-x-display!) + (add-event-receiver! event:after-restore reset-x-display!) + unspecific) + +(initialize-package!) \ No newline at end of file diff --git a/src/x11/AUTHORS b/src/x11/AUTHORS new file mode 100644 index 000000000..2af146e02 --- /dev/null +++ b/src/x11/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 separate package. +The MIT/GNU Scheme Team The original prx11 microcode module and + runtime/x11graph.scm. diff --git a/src/x11/COPYING b/src/x11/COPYING new file mode 100644 index 000000000..bf50f20de --- /dev/null +++ b/src/x11/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/src/x11/ChangeLog b/src/x11/ChangeLog new file mode 100644 index 000000000..bee4284fa --- /dev/null +++ b/src/x11/ChangeLog @@ -0,0 +1,6 @@ +-*-Text-*- + +Please see the git commit log: + +$ git clone git://git.savannah.gnu.org/mit-scheme.git +$ git log origin/master -- src/x11/ | more diff --git a/src/x11/Makefile.am b/src/x11/Makefile.am new file mode 100644 index 000000000..93abf62d3 --- /dev/null +++ b/src/x11/Makefile.am @@ -0,0 +1,119 @@ +## Process this file with automake to produce Makefile.in +## +## 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 +## 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. + +ACLOCAL_AMFLAGS = -I m4 +EXTRA_DIST = autogen.sh + +MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ +scmlibdir = @MIT_SCHEME_LIBDIR@ +scmlib_subdir = $(scmlibdir)x11 + +scmlib_LTLIBRARIES = x11-shim.la +scmlib_DATA = x11-types.bin x11-const.bin + +sources = x11base.scm x11color.scm x11graph.scm x11term.scm x11device.scm +binaries = x11base.bci x11base.com x11color.bci x11color.com +binaries += x11graph.bci x11graph.com x11term.bci x11term.com +binaries += x11device.bci x11device.com +cdecls = x11.cdecl + +scmlib_sub_DATA = $(sources) $(binaries) +scmlib_sub_DATA += make.scm x11-@MIT_SCHEME_OS_SUFFIX@.pkd + +#info_TEXINFOS = mit-scheme-x11.texi +AM_MAKEINFOHTMLFLAGS = --no-split + +# Set these to the defaults used by Scheme. +infodir = $(datarootdir)/info +htmldir = $(libdir)/mit-scheme/doc +dvidir = $(libdir)/mit-scheme/doc +pdfdir = $(libdir)/mit-scheme/doc + +AM_CPPFLAGS = -I$(scmlibdir) +AM_CFLAGS = `pkg-config --cflags x11` +LIBS = `pkg-config --libs x11` + +x11_shim_la_LIBADD = x11base.lo x11color.lo x11graph.lo x11term.lo +c_sources = x11-shim.h x11.h x11base.c x11color.c x11graph.c x11term.c +x11_shim_la_LDFLAGS = -module -avoid-version -shared + +noinst_PROGRAMS = x11-const +x11_const_SOURCES = x11-const.c x11-shim.h + +x11-shim.c: stamp-shim +x11-const.c: stamp-shim +x11-types.bin: stamp-shim +stamp-shim: $(c_sources) $(cdecls) + touch stamp-shim + echo '(generate-shim "x11" "#include \"x11-shim.h\"")' \ + | $(MIT_SCHEME_EXE) --batch-mode \ + || rm stamp-shim + +x11-const.bin: x11-const.scm + echo '(sf "x11-const")' | $(MIT_SCHEME_EXE) --batch-mode + +x11-const.scm: x11-const + ./x11-const + +x11base.bci: stamp-scheme +x11base.com: stamp-scheme +x11color.bci: stamp-scheme +x11color.com: stamp-scheme +x11graph.bci: stamp-scheme +x11graph.com: stamp-scheme +x11term.bci: stamp-scheme +x11term.com: stamp-scheme +x11device.bci: stamp-scheme +x11device.com: stamp-scheme +x11-@MIT_SCHEME_OS_SUFFIX@.pkg: stamp-scheme +stamp-scheme: stamp-shim $(sources) x11.pkg + touch stamp-scheme + if ! ./compile.sh; then rm stamp-scheme; exit 1; fi + +CLEANFILES = x11-const* x11-shim.c +CLEANFILES += *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd + +#TESTS = x11-check.sh + +tags: tags-am + ./tags-fix.sh x11 + +TESTS = x11-check.sh + +all_sources = $(sources) $(c_sources) +ETAGS_ARGS = $(all_sources) -r '/^([^iI].*/' $(cdecls) +TAGS_DEPENDENCIES = $(all_sources) $(cdecls) + +EXTRA_DIST += $(all_sources) $(cdecls) compile.sh x11.pkg +EXTRA_DIST += make.scm tags-fix.sh + +install-data-hook: + echo '(update-optiondb "$(DESTDIR)$(scmlibdir)")' \ + | $(MIT_SCHEME_EXE) --batch-mode + +uninstall-hook: + echo '(update-optiondb "$(DESTDIR)$(scmlibdir)")' \ + | $(MIT_SCHEME_EXE) --batch-mode + [ -d "$(DESTDIR)$(scmlib_subdir)" ] \ + && rmdir "$(DESTDIR)$(scmlib_subdir)" diff --git a/src/x11/NEWS b/src/x11/NEWS new file mode 100644 index 000000000..908f30d45 --- /dev/null +++ b/src/x11/NEWS @@ -0,0 +1,29 @@ +mit-scheme-x11 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 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-x11 3.116 - Matt Birkholz, 2016-02-19 +================================================ + +* Convert to plugin, moving X11 data parsing (x_event_to_object) to + Scheme/FFI code, using libtool and automake... diff --git a/src/x11/README b/src/x11/README new file mode 100644 index 000000000..5c9a8b430 --- /dev/null +++ b/src/x11/README @@ -0,0 +1,19 @@ +The X11 option. + +This is a drop-in replacement for the x11 microcode module and +runtime/x11graph.scm. It is not part of the core build and can be +built outside the core build tree in the customary way: + + ./configure ... + make all check install + +The install target copies a shared library shim and compiled Scheme +files into the system library path, and re-writes the optiondb.scm +found there. You can override the default command name "mit-scheme" +(and thus the system library path) by setting MIT_SCHEME_EXE. + +To use: (load-option 'X11) and import the bindings you want. They are +not exported to the global environment because they would conflict +with the exports from (runtime x-graphics). Once this option is +loaded, make-graphics-device will create X11 graphics devices rather +than X graphics devices. diff --git a/src/x11/autogen.sh b/src/x11/autogen.sh new file mode 100755 index 000000000..8af4031c7 --- /dev/null +++ b/src/x11/autogen.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +set -e +rm -rf m4 +mkdir m4 +autoreconf --force --install -I m4 diff --git a/src/x11/compile.sh b/src/x11/compile.sh new file mode 100755 index 000000000..edeb82d0d --- /dev/null +++ b/src/x11/compile.sh @@ -0,0 +1,49 @@ +#!/bin/sh +# -*-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 +# 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. + +# Compile the X11 option. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF + +(begin + (load-option 'CREF) + (load-option 'FFI) + + (let ((runtime (->environment '(runtime)))) + (compile-file "x11base" '() runtime) + (compile-file "x11color" '() runtime) + (compile-file "x11graph" '() runtime) + (compile-file "x11device" '() runtime) + (compile-file "x11term" '() runtime)) + + (cref/generate-constructors "x11") + ) +EOF +SUFFIX=`echo "(display (microcode-id/operating-system-suffix))" \ + | ${MIT_SCHEME_EXE} --batch-mode` +REPORT=x11-$SUFFIX.crf +if [ -s "$REPORT" ]; then echo "$REPORT:1: error: not empty"; exit 1; fi diff --git a/src/x11/configure.ac b/src/x11/configure.ac new file mode 100644 index 000000000..08e192cac --- /dev/null +++ b/src/x11/configure.ac @@ -0,0 +1,60 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_PREREQ([2.69]) +AC_INIT([MIT/GNU Scheme x11 plugin], + [0.1], + [bug-mit-scheme@gnu.org], + [mit-scheme-x11]) +AC_CONFIG_SRCDIR([x11.pkg]) +AC_CONFIG_MACRO_DIR([m4]) + +AC_COPYRIGHT( +[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 + Massachusetts Institute of Technology + +This file is part of an x11 option for MIT/GNU Scheme. + +This option is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This option is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this option; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +]) + +AM_INIT_AUTOMAKE + +LT_PREREQ([2.2.6]) +LT_INIT([dlopen]) + +AC_PROG_CC +AC_PROG_CPP +AC_PROG_INSTALL + +AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) + +if ! pkg-config --exists x11 2>/dev/null; then + AC_MSG_ERROR([X11 not found.]) +fi + +: ${MIT_SCHEME_EXE=mit-scheme} +MIT_SCHEME_LIBDIR=`( echo "(display (->namestring" ;\ + echo " (system-library-directory-pathname)))" ) \ + | ${MIT_SCHEME_EXE} --batch-mode` +MIT_SCHEME_OS_SUFFIX=`echo "(display (microcode-id/operating-system-suffix))" \ + | ${MIT_SCHEME_EXE} --batch-mode` + +AC_SUBST([MIT_SCHEME_EXE]) +AC_SUBST([MIT_SCHEME_LIBDIR]) +AC_SUBST([MIT_SCHEME_OS_SUFFIX]) +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/src/x11/make.scm b/src/x11/make.scm new file mode 100644 index 000000000..dacdbe01f --- /dev/null +++ b/src/x11/make.scm @@ -0,0 +1,117 @@ +#| -*-Scheme-*- + +Load the X11 option. |# + +(with-loader-base-uri (system-library-uri "x11/") + (lambda () + (load-package-set "x11"))) +(add-subsystem-identification! "X11" '(0 1)) + +;; Until the microcode module based X Graphics system is removed, +;; reassign the define-primitives bindings in (runtime x-graphics) to +;; their replacements in (x11). +(let ((x-graphics (->environment '(runtime x-graphics))) + (x11 (->environment '(x11)))) + (for-each (lambda (name) + (environment-assign! x-graphics name + (environment-lookup x11 name))) + '( + x-close-all-displays + x-display-descriptor + x-display-get-default + x-display-process-events + x-font-structure + x-window-beep + x-window-clear + x-window-colormap + x-window-depth + x-window-event-mask + x-window-flush + x-window-iconify + x-window-id + x-window-lower + x-window-map + x-window-query-pointer + x-window-raise + x-window-set-background-color + x-window-set-border-color + x-window-set-border-width + x-window-set-cursor-color + x-window-set-event-mask + x-window-set-font + x-window-set-foreground-color + x-window-set-icon-name + x-window-set-input-hint + x-window-set-internal-border-width + x-window-set-mouse-color + x-window-set-mouse-shape + x-window-set-name + x-window-set-position + x-window-set-size + ;; x-window-starbase-filename No such primitive! + x-window-visual + x-window-withdraw + x-window-x-size + x-window-y-size + x-graphics-copy-area + x-graphics-drag-cursor + x-graphics-draw-arc + x-graphics-draw-line + x-graphics-draw-lines + x-graphics-draw-point + x-graphics-draw-points + x-graphics-draw-string + x-graphics-draw-image-string + x-graphics-fill-polygon + x-graphics-map-x-coordinate + x-graphics-map-y-coordinate + x-graphics-move-cursor + x-graphics-open-window + x-graphics-reconfigure + x-graphics-reset-clip-rectangle + x-graphics-set-clip-rectangle + x-graphics-set-dashes + x-graphics-set-fill-style + x-graphics-set-function + x-graphics-set-line-style + x-graphics-set-vdc-extent + x-graphics-vdc-extent + x-bytes-into-image + x-create-image + x-destroy-image + x-display-image + x-get-pixel-from-image + x-set-pixel-in-image + x-allocate-color + x-create-colormap + x-free-colormap + x-query-color + x-set-window-colormap + x-store-color + x-store-colors + x-visual-deallocate))) + +;; Check that these (integrated!) constants DO "match" the C +;; constants, just because we can (with the FFI's help). +(let ((x-graphics (->environment '(runtime x-graphics))) + (x11 (->environment '(x11)))) + (for-each (lambda (name) + (if (not (equal? (environment-lookup x-graphics name) + (environment-lookup x11 name))) + (warn "Incorrect C constant in (runtime x-graphics):" name))) + '(event-type:button-down + event-type:button-up + event-type:configure + event-type:enter + event-type:focus-in + event-type:focus-out + event-type:key-press + event-type:leave + event-type:motion + event-type:expose + event-type:delete-window + event-type:map + event-type:unmap + event-type:take-focus + event-type:visibility + number-of-event-types))) \ No newline at end of file diff --git a/src/x11/optiondb.scm b/src/x11/optiondb.scm new file mode 100644 index 000000000..3ea420f14 --- /dev/null +++ b/src/x11/optiondb.scm @@ -0,0 +1,10 @@ +#| -*-Scheme-*- |# + +(define-load-option 'X11 + (standard-system-loader ".")) + +(further-load-options + (named-lambda (system-load-options) + (merge-pathnames "optiondb" + (cadr (access library-directory-path + (->environment '(runtime pathname))))))) \ No newline at end of file diff --git a/src/x11/tags-fix.sh b/src/x11/tags-fix.sh new file mode 100755 index 000000000..c2823ad7f --- /dev/null +++ b/src/x11/tags-fix.sh @@ -0,0 +1,42 @@ +#!/bin/sh +# -*-Scheme-*- +# +# Chop the generated $1-shim.c and $1-const.c files out of TAGS. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF +(let ((name (car (command-line)))) + (let ((shim.c-prefix (string-append name "-shim.c,")) + (const.c-prefix (string-append name "-const.c,"))) + + (define (rewriter in out) + (let loop ((skipping? #f)) + (let ((line (read-line in))) + (cond ((eof-object? line) + unspecific) + ((string=? line "\f") + (let ((next (read-line in))) + (cond ((eof-object? next) (error "Bogus TAGS format:" next)) + ((or (string-prefix? shim.c-prefix next) + (string-prefix? const.c-prefix next)) + (loop #t)) + (else + (write-string line out) + (newline out) + (write-string next out) + (newline out) + (loop #f))))) + (skipping? + (loop skipping?)) + (else + (write-string line out) + (newline out) + (loop skipping?)))))) + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'FFI)) + ((access rewrite-file (->environment '(ffi build))) + (merge-pathnames "TAGS") + rewriter))) +EOF diff --git a/src/x11/x11-check.sh b/src/x11/x11-check.sh new file mode 100755 index 000000000..a0f1531f5 --- /dev/null +++ b/src/x11/x11-check.sh @@ -0,0 +1,33 @@ +#!/bin/sh +# +# Test the X11 option. + +set -e +${MIT_SCHEME_EXE} --prepend-library . <<\EOF +(begin + (load-option 'X11) + + (if (let ((display (get-environment-variable "DISPLAY"))) + (or (not (string? display)) + (string-null? display))) + (warn "DISPLAY not set") + (let ((dev (make-graphics-device))) + (if (not (eq? 'X11 (graphics-type-name (graphics-type dev)))) + (error "The X11 graphics type is NOT the default.")) + (graphics-draw-point dev 0 .1) + (graphics-draw-point dev 0 .2) + (graphics-draw-point dev 0 .3) + (graphics-erase-point dev 0 .2) + (graphics-draw-text dev 0. .4 "Hello!") + (graphics-draw-line dev -.5 -.5 .5 .5) + (graphics-move-cursor dev -.5 .5) + (graphics-drag-cursor dev .5 -.5) + (display "Waiting for graphics window to close...\n") + (let wait () + (sleep-current-thread 1000) + (if ((access x-window/xw (->environment '(runtime x-graphics))) + (graphics-device/descriptor dev)) + (wait))) + (display "Graphics window closed.\n"))) + ) +EOF diff --git a/src/x11/x11-shim.h b/src/x11/x11-shim.h new file mode 100644 index 000000000..bea0d9503 --- /dev/null +++ b/src/x11/x11-shim.h @@ -0,0 +1,298 @@ +/* -*-C-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016 Matthew Birkholz + +This file is part of a gtk plugin for MIT/GNU Scheme. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +*/ + +/* Header for x11-shim.c, x11-const.c and x11base.c et al. */ + +#include "x11.h" + +/* x11base.c */ + +extern struct xvisual * allocate_x_visual (Visual * visual); +extern void x_visual_deallocate (struct xvisual * xv); +extern void x_close_display (struct xdisplay * xd); +extern void x_close_all_displays (void); +extern int x_window_set_input_hint (struct xwindow * xw, int input_hint); +extern int x_window_set_name (struct xwindow * xw, const char * name); +extern int x_window_set_icon_name (struct xwindow * xw, const char * name); +extern int x_event_delete_window_p (struct xwindow * xw, XEvent * event); +extern int x_event_take_focus_p (struct xwindow * xw, XEvent * event); +extern Time x_event_take_focus_time (XEvent * event); +extern int x_lookup_string (XKeyEvent * event, + char *buffer_return, int bytes_buffer, + KeySym * keysym_return); +extern unsigned long x_modifier_mask_to_bucky_bits (unsigned int mask, + struct xwindow * xw); +extern struct xdisplay * x_open_display (char * display_name); +extern void x_display_get_size (struct xdisplay * xd, long screen, + int * results); +extern void x_close_window (struct xwindow * xw); +extern int x_set_default_font (struct xdisplay * xd, const char * name); +extern int x_display_descriptor (struct xdisplay * xd); +extern long x_max_request_size (struct xdisplay * xd); +extern struct xwindow * x_display_process_events (struct xdisplay * xd, + XEvent * event); +extern void x_select_input (struct xdisplay * xd, Window window, long mask); +extern long x_window_event_mask (struct xwindow * xw); +extern int x_window_set_event_mask (struct xwindow * xw, long mask); +extern void x_window_or_event_mask (struct xwindow * xw, long mask); +extern void x_window_andc_event_mask (struct xwindow * xw, long mask); +extern struct xdisplay * x_window_display (struct xwindow * xw); +extern long x_window_screen_number (struct xwindow * xw); +extern int x_window_x_size (struct xwindow * xw); +extern int x_window_y_size (struct xwindow * xw); +extern void x_window_beep (struct xwindow * xw); +extern void x_window_clear (struct xwindow * xw); +extern void x_display_flush (struct xdisplay * xd); +extern void x_window_flush (struct xwindow * xw); +extern void x_display_sync (struct xdisplay * xd, Bool discard); +extern char * x_display_get_default (struct xdisplay * xd, + char * resource_name, + char * class_name); +extern int x_window_query_pointer (struct xwindow * xw, int * result); +extern unsigned long x_window_id (struct xwindow * xw); +extern void x_window_set_foreground_color_pixel (struct xwindow * xw, + unsigned long pixel); +extern void x_window_set_foreground_color_name (struct xwindow * xw, + char * color); +extern int x_window_set_background_color_pixel (struct xwindow * xw, + unsigned long pixel); +extern void x_window_set_background_color_name (struct xwindow * xw, + char * color); +extern void x_window_set_border_color_pixel (struct xwindow * xw, + unsigned long pixel); +extern void x_window_set_border_color_name (struct xwindow * xw, char * color); +extern void x_window_set_cursor_color_pixel (struct xwindow * xw, + unsigned long pixel); +extern void x_window_set_cursor_color_name (struct xwindow * xw, char * color); +extern int x_window_set_mouse_color_pixel (struct xwindow * xw, + unsigned long pixel); +extern void x_window_set_mouse_color_name (struct xwindow * xw, char * color); +extern int x_window_set_mouse_shape (struct xwindow * xw, int shape); +extern int x_window_set_font (struct xwindow * xw, char * font_name); +extern void x_window_set_border_width (struct xwindow * xw, uint border_width); +extern void x_window_set_internal_border_width (struct xwindow * xw, + uint internal_border_width); +extern int x_window_set_input_focus (struct xwindow * xw, Time time); +extern void x_window_map (struct xwindow * xw); +extern void x_window_iconify (struct xwindow * xw); +extern void x_window_withdraw (struct xwindow * xw); +extern void x_window_set_size (struct xwindow * xw, int width, int height); +extern void x_window_raise (struct xwindow * xw); +extern void x_window_lower (struct xwindow * xw); +extern void x_window_get_size (struct xwindow * xw, int * dimens); +extern void x_window_get_position (struct xwindow * xw, int * coord_return); +extern void x_window_set_position (struct xwindow * xw, int x, int y); +extern XFontStruct * x_font_structure_by_name (struct xdisplay * xd, + const char * font_name); +extern XFontStruct * x_font_structure_by_id (struct xdisplay * xd, XID id); +extern void x_free_font (struct xdisplay * xd, XFontStruct *font); +extern char * * x_list_fonts (struct xdisplay * xd, + char * pattern, long limit, int * actual_count); +extern Atom x_intern_atom (struct xdisplay * xd, const char * name, int soft_p); +extern int x_get_atom_name (struct xdisplay * xd, Atom atom, + char * * name_return); +extern int x_get_window_property (struct xdisplay * xd, + Window window, Atom property, + long long_offset, long long_length, + Bool delete, Atom req_type, + Atom * actual_type_return, + int * actual_format_return, + unsigned long * nitems_return, + unsigned long * bytes_after_return, + unsigned char * * prop_return); +extern int x_change_property (struct xdisplay * wd, + Window window, Atom property, + Atom type, int format, int mode, + char * data, unsigned long dlen); +extern void x_delete_property (struct xdisplay * xd, + Window window, Atom property); +extern void x_set_selection_owner (struct xdisplay * xd, + Atom selection, Window owner, Time time); +extern Window x_get_selection_owner (struct xdisplay * xd, Atom selection); +extern void x_convert_selection (struct xdisplay * xd, + Atom selection, Atom target, + Atom property, Window requestor, Time time); +extern void x_send_selection_notify (struct xdisplay * xd, + Window requestor, + Atom selection, Atom target, + Atom property, Time time); + +/* x11color.c */ + +extern struct xvisual * x_window_visual (struct xwindow * xw); +extern void x_get_visual_info (struct xdisplay * xd, + long mask, XVisualInfo * info, + XVisualInfo * * items_return, + int * nitems_return); +extern struct xcolormap * x_window_colormap (struct xwindow * xw); +extern void x_set_window_colormap (struct xwindow * xw, struct xcolormap * xcm); +extern struct xcolormap * x_create_colormap (struct xwindow * xw, + struct xvisual * visual, + int writable_p); +extern void x_free_colormap (struct xcolormap * xcm); +extern long x_allocate_color (struct xcolormap * xcm, unsigned int red, + unsigned int green, unsigned int blue); +extern void x_store_color (struct xcolormap * xcm, + int pixel, int red, int green, int blue); +extern void x_store_colors (struct xcolormap * xcm, int * color_vector, + unsigned long n_colors); +extern void x_query_color (struct xcolormap * xcm, + unsigned long pixel, + unsigned int * results); + +/* x11graph.c */ + +extern void x_graphics_set_vdc_extent (struct xwindow * xw, + float x_left, float y_bottom, + float x_right, float y_top); +extern void x_graphics_vdc_extent (struct xwindow * xw, float * results); +extern void x_graphics_reset_clip_rectangle (struct xwindow * xw); +extern void x_graphics_set_clip_rectangle (struct xwindow * xw, + int x_left, int y_bottom, + int x_right, int y_top); +extern void x_graphics_reconfigure (struct xwindow * xw, + unsigned int width, unsigned int height); +extern struct xwindow * x_graphics_open_window (struct xdisplay * xd, + char * geometry, + const char * resource_name, + const char * resource_class, + int map_p); +extern void x_graphics_draw_line (struct xwindow * xw, + float x_start, float y_start, + float x_end, float y_end); +extern void x_graphics_move_cursor (struct xwindow * xw, float x, float y); +extern void x_graphics_drag_cursor (struct xwindow * xw, float x, float y); +extern void x_graphics_draw_point (struct xwindow * xw, float x, float y); +extern void x_graphics_draw_arc (struct xwindow * xw, + float virtual_device_x, float virtual_device_y, + float radius_x, float radius_y, + float angle_start, float angle_sweep, + int fill_p); +extern void x_graphics_draw_string (struct xwindow * xw, + float x, float y, char * string); +extern void x_graphics_draw_image_string (struct xwindow * xw, + float x, float y, char * string); +extern int x_graphics_set_function (struct xwindow * xw, unsigned int function); +extern void x_graphics_draw_points (struct xwindow * xw, + double * x_vector, double * y_vector, + unsigned int n_points, XPoint * points); +extern void x_graphics_draw_lines (struct xwindow * xw, + double * x_vector, double * y_vector, + unsigned int n_points, XPoint * points); +extern int x_graphics_set_fill_style (struct xwindow * xw, + unsigned int fill_style); +extern int x_graphics_set_line_style (struct xwindow * xw, unsigned int style); +extern int x_graphics_set_dashes (struct xwindow * xw, int dash_offset, + char * dash_list, int dash_list_length); +extern int x_graphics_copy_area (struct xwindow * source_xw, + struct xwindow * destination_xw, + int source_x, int source_y, + int width, int height, + int dest_x, int dest_y); +extern void x_graphics_fill_polygon (struct xwindow * xw, + double * vector, unsigned int length, + XPoint * points); +extern struct ximage * x_create_image (struct xwindow * xw, + uint width, uint height); +extern int x_bytes_into_image (char * vector, int length, + struct ximage * ximage); +extern long x_get_pixel_from_image (struct ximage * xi, int x, int y); +extern int x_set_pixel_in_image (struct ximage * xi, + int x, int y, unsigned long pixel); +extern void x_destroy_image (struct ximage * xi); +extern int x_display_image (struct ximage * xi, + unsigned int x_offset, unsigned int y_offset, + struct xwindow * xw, + unsigned int window_xoff, unsigned int window_yoff, + unsigned int width, unsigned int height); +extern void x_read_image (struct ximage * xi, + long XImageOffset, long YImageOffset, + struct xwindow * xw, + long XWindowOffset, long YWindowOffset, + long Width, long Height); +extern int x_window_depth (struct xwindow * xw); +extern float x_graphics_map_x_coordinate (struct xwindow * xw, int signed_xp); +extern float x_graphics_map_y_coordinate (struct xwindow * xw, int signed_yp); + +/* x11term.c */ + +extern void xterm_erase_cursor (struct xwindow * xw); +extern void xterm_draw_cursor (struct xwindow * xw); +extern void xterm_dump_rectangle (struct xwindow * xw, + int signed_x, int signed_y, + unsigned int width, unsigned int height); +extern void xterm_reconfigure (struct xwindow * xw, + unsigned int x_csize, unsigned int y_csize); +extern long xterm_map_x_coordinate (struct xwindow * xw, int signed_xp); +extern long xterm_map_y_coordinate (struct xwindow * xw, int signed_yp); +extern unsigned long xterm_map_x_size (struct xwindow * xw, + unsigned int width); +extern unsigned long xterm_map_y_size (struct xwindow * xw, + unsigned int height); +extern struct xwindow * xterm_open_window (struct xdisplay * xd, + char * geometry, + const char * resource_name, + const char * resource_class, + int map_p); +extern unsigned int xterm_x_size (struct xwindow * xw); +extern unsigned int xterm_y_size (struct xwindow * xw); +extern void xterm_set_size (struct xwindow * xw, + unsigned int width, unsigned int height); +extern void xterm_enable_cursor (struct xwindow * xw, int enable_p); +extern int xterm_write_cursor (struct xwindow * xw, + unsigned int x, unsigned int y); +extern int xterm_write_char (struct xwindow * xw, + unsigned int x, unsigned int y, + int c, unsigned int hl); +extern int xterm_write_substring (struct xwindow * xw, + unsigned int x, unsigned int y, + char * string, unsigned int start, + unsigned int end, unsigned int hl); +extern int xterm_clear_rectangle (struct xwindow * xw, + unsigned int x_start, unsigned int x_end, + unsigned int y_start, unsigned int y_end, + unsigned int hl); +extern int xterm_scroll_lines_up (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines); +extern int xterm_scroll_lines_down (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines); +extern int xterm_save_contents (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + char * contents); +extern int xterm_restore_contents (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + char * contents); diff --git a/src/x11/x11.cdecl b/src/x11/x11.cdecl new file mode 100644 index 000000000..4c99242b1 --- /dev/null +++ b/src/x11/x11.cdecl @@ -0,0 +1,982 @@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016 Matthew Birkholz + +This file is part of a gtk plugin for MIT/GNU Scheme. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; C declarations for x11-shim.so. + +(typedef size_t uint) + +(typedef CARD32 uint) +(typedef CARD16 ushort) +(typedef XID ulong) +(typedef Bool int) +(typedef KeySym int) +(typedef Window ulong) +(typedef Atom ulong) +(typedef Time ulong) +(typedef VisualID ulong) + +(typedef XPoint + (struct + (x short) + (y short))) + +(enum (ShiftMask) + (LockMask) + (ControlMask) + (Mod1Mask) + (Mod2Mask) + (Mod3Mask) + (Mod4Mask) + (Mod5Mask)) + +(enum (Button1Mask) + (Button2Mask) + (Button3Mask) + (Button4Mask) + (Button5Mask)) + +(typedef XButtonEvent + (struct + (type int) + (x int) + (y int) + (button uint) + (state uint) + (time Time))) + +(typedef XKeyEvent + (struct + (type int) + (state uint) + (time Time))) + +(typedef XEvent + (struct + (type int))) + +(typedef XPropertyEvent + (struct + (type int) + (serial ulong) ; # of last request processed by server + (send_event Bool) ; true if this came from a SendEvent request + (display (* Display)) ; Display the event was read from + (window Window) + (atom Atom) + (time Time) + (state int) ; NewValue, Deleted + )) + +(typedef XMotionEvent + (struct + (x int) + (y int) + (state uint))) + +(typedef XConfigureEvent + (struct + (width int) + (height int))) + +(typedef XExposeEvent + (struct + (x int) + (y int) + (width int) + (height int))) + +(typedef XGraphicsExposeEvent + (struct + (x int) + (y int) + (width int) + (height int))) + +(typedef XVisibilityEvent + (struct + (state int))) + +(enum (VisibilityUnobscured) + (VisibilityPartiallyObscured) + (VisibilityFullyObscured) + (AnyPropertyType)) + +(typedef XSelectionClearEvent + (struct + (selection Atom) + (time Time))) + +(typedef XSelectionEvent + (struct + (type int) + (serial ulong) ; # of last request processed by server + (send_event Bool) ; true if this came from a SendEvent request + (display (* Display)) ; Display the event was read from + (requestor Window) + (selection Atom) + (target Atom) + (property Atom) + (time Time))) + +(typedef XSelectionRequestEvent + (struct + (type int) + (serial ulong) ; # of last request processed by server + (send_event Bool) ; true if this came from a SendEvent request + (display (* Display)) ; Display the event was read from + (owner Window) + (requestor Window) + (selection Atom) + (target Atom) + (property Atom) + (time Time))) + +(typedef XVisualInfo + (struct + (visual (* Visual)) + (visualid VisualID) + (screen int) + (depth int) + (class int) + (red_mask ulong) + (green_mask ulong) + (blue_mask ulong) + (colormap_size int) + (bits_per_rgb int))) + +(enum (VisualNoMask) + (VisualIDMask) + (VisualScreenMask) + (VisualDepthMask) + (VisualClassMask) + (VisualRedMaskMask) + (VisualGreenMaskMask) + (VisualBlueMaskMask) + (VisualColormapSizeMask) + (VisualBitsPerRGBMask) + (VisualAllMask)) + +(extern int + IsModifierKey + (keysym KeySym)) + +(extern int + XFree + (data (* void))) + +(extern int + XFreeFontNames + (list (* (* char)))) + +(enum (NoSymbol) + (True) + (XK_BackSpace)) + +(enum (ButtonPress) + (ButtonRelease) + (ClientMessage) + (ConfigureNotify) + (EnterNotify) + (Expose) + (FocusIn) + (FocusOut) + (GraphicsExpose) + (KeyPress) + (LeaveNotify) + (MapNotify) + (MotionNotify) + (PropertyNotify) + (SelectionClear) + (SelectionNotify) + (SelectionRequest) + (UnmapNotify) + (VisibilityNotify)) + +(typedef XFontStruct + (struct + (direction uint) + (min_char_or_byte2 uint) + (max_char_or_byte2 uint) + (min_byte1 uint) + (max_byte1 uint) + (all_chars_exist Bool) + (default_char uint) + (min_bounds XCharStruct) + (max_bounds XCharStruct) + (per_char (* XCharStruct)) + (ascent int) + (descent int))) + +(typedef XCharStruct + (struct + (lbearing short) + (rbearing short) + (width short) + (ascent short) + (descent short) + (attributes ushort))) + +;;; x11base.c + +(typedef ScmEventType + (enum (event_type_button_down) + (event_type_button_up) + (event_type_configure) + (event_type_enter) + (event_type_focus_in) + (event_type_focus_out) + (event_type_key_press) + (event_type_leave) + (event_type_motion) + (event_type_expose) + (event_type_delete_window) + (event_type_map) + (event_type_unmap) + (event_type_take_focus) + (event_type_visibility) + (event_type_selection_clear) + (event_type_selection_notify) + (event_type_selection_request) + (event_type_property_notify) + (event_type_supremum))) + +(extern (* (struct xvisual)) + allocate_x_visual + (visual (* Visual))) + +(extern void + x_visual_deallocate + (xv (* (struct xvisual)))) + +(extern void + x_close_display + (xd (* (struct xdisplay)))) + +(extern void + x_close_all_displays) + +(extern int + x_window_set_input_hint + (xw (* (struct xwindow))) + (input_hint int)) + +(extern int + x_window_set_name + (xw (* (struct xwindow))) + (name (* (const char)))) + +(extern int + x_window_set_icon_name + (xw (* (struct xwindow))) + (name (* (const char)))) + +(extern int + x_event_delete_window_p + (xw (* (struct xwindow))) + (event (* XEvent))) + +(extern int + x_event_take_focus_p + (xw (* (struct xwindow))) + (event (* XEvent))) + +(extern Time + x_event_take_focus_time + (event (* XEvent))) + +(extern int + x_lookup_string + (event (* XKeyEvent)) + (buffer_return (* char)) + (bytes_buffer int) + (keysym_return (* KeySym))) + +(extern ulong + x_modifier_mask_to_bucky_bits + (mask uint) + (xw (* (struct xwindow)))) + +(extern (* (struct xdisplay)) + x_open_display + (display_name (* char))) + +(extern void + x_display_get_size + (xd (* (struct xdisplay))) + (screen long) + (results (* int))) + +(extern void + x_close_window + (xw (* (struct xwindow)))) + +(extern int + x_set_default_font + (xd (* (struct xdisplay))) + (name (* (const char)))) + +(extern int + x_display_descriptor + (xd (* (struct xdisplay)))) + +(extern long + x_max_request_size + (xd (* (struct xdisplay)))) + +(extern (* (struct xwindow)) + x_display_process_events + (xd (* (struct xdisplay))) + (event (* XEvent))) + +(extern void + x_select_input + (xd (* (struct xdisplay))) + (window Window) + (mask long)) + +(extern long + x_window_event_mask + (xw (* (struct xwindow)))) + +(extern int + x_window_set_event_mask + (xw (* (struct xwindow))) + (mask long)) + +(extern void + x_window_or_event_mask + (xw (* (struct xwindow))) + (mask long)) + +(extern void + x_window_andc_event_mask + (xw (* (struct xwindow))) + (mask long)) + +(extern (* (struct xdisplay)) + x_window_display + (xw (* (struct xwindow)))) + +(extern long + x_window_screen_number + (xw (* (struct xwindow)))) + +(extern int + x_window_x_size + (xw (* (struct xwindow)))) + +(extern int + x_window_y_size + (xw (* (struct xwindow)))) + +(extern void + x_window_beep + (xw (* (struct xwindow)))) + +(extern void + x_window_clear + (xw (* (struct xwindow)))) + +(extern void + x_display_flush + (xd (* (struct xdisplay)))) + +(extern void + x_window_flush + (xw (* (struct xwindow)))) + +(extern void + x_display_sync + (xd (* (struct xdisplay))) + (discard Bool)) + +(extern (* char) + x_display_get_default + (xd (* (struct xdisplay))) + (resource_name (* char)) + (class_name (* char))) + +(extern int + x_window_query_pointer + (xw (* (struct xwindow))) + (result (* int))) + +(extern ulong + x_window_id + (xw (* (struct xwindow)))) + +(extern void + x_window_set_foreground_color_pixel + (xw (* (struct xwindow))) + (pixel ulong)) + +(extern void + x_window_set_foreground_color_name + (xw (* (struct xwindow))) + (color (* char))) + +(extern int + x_window_set_background_color_pixel + (xw (* (struct xwindow))) + (pixel ulong)) + +(extern void + x_window_set_background_color_name + (xw (* (struct xwindow))) + (color (* char))) + +(extern void + x_window_set_border_color_pixel + (xw (* (struct xwindow))) + (pixel ulong)) + +(extern void + x_window_set_border_color_name + (xw (* (struct xwindow))) + (color (* char))) + +(extern void + x_window_set_cursor_color_pixel + (xw (* (struct xwindow))) + (pixel ulong)) + +(extern void + x_window_set_cursor_color_name + (xw (* (struct xwindow))) + (color (* char))) + +(extern int + x_window_set_mouse_color_pixel + (xw (* (struct xwindow))) + (pixel ulong)) + +(extern void + x_window_set_mouse_color_name + (xw (* (struct xwindow))) + (color (* char))) + +(extern int + x_window_set_mouse_shape + (xw (* (struct xwindow))) + (shape int)) + +(extern int + x_window_set_font + (xw (* (struct xwindow))) + (font_name (* char))) + +(extern void + x_window_set_border_width + (xw (* (struct xwindow))) + (border_width uint)) + +(extern void + x_window_set_internal_border_width + (xw (* (struct xwindow))) + (internal_border_width uint)) + +(extern int + x_window_set_input_focus + (xw (* (struct xwindow))) + (time Time)) + +(extern void + x_window_map + (xw (* (struct xwindow)))) + +(extern void + x_window_iconify + (xw (* (struct xwindow)))) + +(extern void + x_window_withdraw + (xw (* (struct xwindow)))) + +(extern void + x_window_set_size + (xw (* (struct xwindow))) + (width int) (height int)) + +(extern void + x_window_raise + (xw (* (struct xwindow)))) + +(extern void + x_window_lower + (xw (* (struct xwindow)))) + +(extern void + x_window_get_size + (xw (* (struct xwindow))) + (dimens (* int))) + +(extern void + x_window_get_position + (xw (* (struct xwindow))) + (coord_return (* int))) + +(extern void + x_window_set_position + (xw (* (struct xwindow))) + (x int) (y int)) + +(extern (* XFontStruct) + x_font_structure_by_name + (xd (* (struct xdisplay))) + (font_name (* (const char)))) + +(extern (* XFontStruct) + x_font_structure_by_id + (xd (* (struct xdisplay))) + (id XID)) + +(extern void + x_free_font + (xd (* (struct xdisplay))) + (font (* XFontStruct))) + +(extern (* (* char)) + x_list_fonts + (xd (* (struct xdisplay))) + (pattern (* char)) + (limit long) + (actual_count (* int))) + +(extern Atom + x_intern_atom + (xd (* (struct xdisplay))) + (name (* (const char))) + (soft_p int)) + +(extern int + x_get_atom_name + (xd (* (struct xdisplay))) + (atom Atom) + (name_return (* (* char)))) + +(extern int + x_get_window_property + (xd (* (struct xdisplay))) + (window Window) + (property Atom) + (long_offset long) + (long_length long) + (delete Bool) + (req_type Atom) + (actual_type_return (* Atom)) + (actual_format_return (* int)) + (nitems_return (* ulong)) + (bytes_after_return (* ulong)) + (prop_return (* (* uchar)))) + +(extern int + x_change_property + (wd (* (struct xdisplay))) + (window Window) + (property Atom) + (type Atom) + (format int) + (mode int) + (data (* char)) + (dlen ulong)) + +(extern void + x_delete_property + (xd (* (struct xdisplay))) + (window Window) + (property Atom)) + +(extern void + x_set_selection_owner + (xd (* (struct xdisplay))) + (selection Atom) + (owner Window) + (time Time)) + +(extern Window + x_get_selection_owner + (xd (* (struct xdisplay))) + (selection Atom)) + +(extern void + x_convert_selection + (xd (* (struct xdisplay))) + (selection Atom) + (target Atom) + (property Atom) + (requestor Window) + (time Time)) + +(extern void + x_send_selection_notify + (xd (* (struct xdisplay))) + (requestor Window) + (selection Atom) + (target Atom) + (property Atom) + (time Time)) + +;;; x11color.c + +(extern (* (struct xvisual)) + x_window_visual + (xw (* (struct xwindow)))) + +(extern void + x_get_visual_info + (xd (* (struct xdisplay))) + (mask long) + (info (* XVisualInfo)) + (items_return (* (* XVisualInfo))) + (nitems_return (* int))) + +(extern (* (struct xcolormap)) + x_window_colormap + (xw (* (struct xwindow)))) + +(extern void + x_set_window_colormap + (xw (* (struct xwindow))) + (xcm (* (struct xcolormap)))) + +(extern (* (struct xcolormap)) + x_create_colormap + (xw (* (struct xwindow))) + (visual (* (struct xvisual))) + (writable_p int)) + +(extern void + x_free_colormap + (xcm (* (struct xcolormap)))) + +(extern long + x_allocate_color + (xcm (* (struct xcolormap))) + (red uint) (green uint) (blue uint)) + +(extern void + x_store_color + (xcm (* (struct xcolormap))) + (pixel int) (red int) (green int) (blue int)) + +(extern void + x_store_colors + (xcm (* (struct xcolormap))) + (color_vector (* int)) + (n_colors ulong)) + +(extern void + x_query_color + (xcm (* (struct xcolormap))) + (pixel ulong) + (results (* uint))) + +;;; x11graph.c + +(extern void + x_graphics_set_vdc_extent + (xw (* (struct xwindow))) + (x_left float) (y_bottom float) (x_right float) (y_top float)) + +(extern void + x_graphics_vdc_extent + (xw (* (struct xwindow))) + (results (* float))) + +(extern void + x_graphics_reset_clip_rectangle + (xw (* (struct xwindow)))) + +(extern void + x_graphics_set_clip_rectangle + (xw (* (struct xwindow))) + (x_left int) (y_bottom int) (x_right int) (y_top int)) + +(extern void + x_graphics_reconfigure + (xw (* (struct xwindow))) + (height uint) (width uint)) + +(extern (* (struct xwindow)) + x_graphics_open_window + (xd (* (struct xdisplay))) + (geometry (* char)) + (resource_name (* (const char))) + (resource_class (* (const char))) + (map_p int)) + +(extern void + x_graphics_draw_line + (xw (* (struct xwindow))) + (x_start float) (y_start float) + (x_end float) (y_end float)) + +(extern void + x_graphics_move_cursor + (xw (* (struct xwindow))) + (x float) (y float)) + +(extern void + x_graphics_drag_cursor + (xw (* (struct xwindow))) + (x float) (y float)) + +(extern void + x_graphics_draw_point + (xw (* (struct xwindow))) + (x float) (y float)) + +(extern void + x_graphics_draw_arc + (xw (* (struct xwindow))) + (virtual_device_x float) (virtual_device_y float) + (radius_x float) (radius_y float) + (angle_start float) (angle_sweep float) + (fill_p int)) + +(extern void + x_graphics_draw_string + (xw (* (struct xwindow))) + (x float) (y float) (string (* char))) + +(extern void + x_graphics_draw_image_string + (xw (* (struct xwindow))) + (x float) (y float) (string (* char))) + +(extern int + x_graphics_set_function + (xw (* (struct xwindow))) + (function uint)) + +(extern void + x_graphics_draw_points + (xw (* (struct xwindow))) + (x_vector (* double)) (y_vector (* double)) + (n_points uint) (points (* XPoint))) + +(extern void + x_graphics_draw_lines + (xw (* (struct xwindow))) + (x_vector (* double)) (y_vector (* double)) + (n_points uint) (points (* XPoint))) + +(extern int + x_graphics_set_fill_style + (xw (* (struct xwindow))) + (fill_style uint)) + +(extern int + x_graphics_set_line_style + (xw (* (struct xwindow))) + (style uint)) + +(extern int + x_graphics_set_dashes + (xw (* (struct xwindow))) + (dash_offset int) (dash_list (* char)) (dash_list_length int)) + +(extern int + x_graphics_copy_area + (source_xw (* (struct xwindow))) + (destination_xw (* (struct xwindow))) + (source_x int) (source_y int) + (width int) (height int) + (dest_x int) (dest_y int)) + +(extern void + x_graphics_fill_polygon + (xw (* (struct xwindow))) + (vector (* double)) (length uint) (points (* XPoint))) + +(extern (* (struct ximage)) + x_create_image + (xw (* (struct xwindow))) + (width uint) (height uint)) + +(extern int + x_bytes_into_image + (vector (* char)) (length int) (ximage (* (struct ximage)))) + +(extern long + x_get_pixel_from_image + (xi (* (struct ximage))) + (x int) (y int)) + +(extern int + x_set_pixel_in_image + (xi (* (struct ximage))) + (x int) (y int) (pixel ulong)) + +(extern void + x_destroy_image + (xi (* (struct ximage)))) + +(extern int + x_display_image + (xi (* (struct ximage))) + (x_offset uint) (y_offset uint) + (xw (* (struct xwindow))) + (window_xoff uint) (window_yoff uint) + (width uint) (height uint)) + +(extern void + x_read_image + (xi (* (struct ximage))) + (XImageOffset long) (YImageOffset long) + (xw (* (struct xwindow))) + (XWindowOffset long) (YWindowOffset long) + (Width long) (Height long)) + +(extern int + x_window_depth + (xw (* (struct xwindow)))) + +(extern float + x_graphics_map_x_coordinate + (xw (* (struct xwindow))) + (signed_xp int)) + +(extern float + x_graphics_map_y_coordinate + (xw (* (struct xwindow))) + (signed_yp int)) + +;;; x11term.c + +(extern void + xterm_erase_cursor + (xw (* (struct xwindow)))) + +(extern void + xterm_draw_cursor + (xw (* (struct xwindow)))) + +(extern void + xterm_dump_rectangle + (xw (* (struct xwindow))) + (signed_x int) (signed_y int) + (width uint) (height uint)) + +(extern void + xterm_reconfigure + (xw (* (struct xwindow))) + (x_csize uint) (y_csize uint)) + +(extern long + xterm_map_x_coordinate + (xw (* (struct xwindow))) + (signed_xp int)) + +(extern long + xterm_map_y_coordinate + (xw (* (struct xwindow))) + (signed_yp int)) + +(extern uint + xterm_map_x_size + (xw (* (struct xwindow))) + (width uint)) + +(extern uint + xterm_map_y_size + (xw (* (struct xwindow))) + (height uint)) + +(extern (* (struct xwindow)) + xterm_open_window + (xd (* (struct xdisplay))) + (geometry (* char)) + (resource_name (* (const char))) + (resource_class (* (const char))) + (map_p int)) + +(extern uint + xterm_x_size + (xw (* (struct xwindow)))) + +(extern uint + xterm_y_size + (xw (* (struct xwindow)))) + +(extern void + xterm_set_size + (xw (* (struct xwindow))) + (width uint) (height uint)) + +(extern void + xterm_enable_cursor + (xw (* (struct xwindow))) + (enable_p int)) + +(extern int + xterm_write_cursor + (xw (* (struct xwindow))) + (x uint) (y uint)) + +(extern int + xterm_write_char + (xw (* (struct xwindow))) + (x uint) (y uint) + (c int) (hl uint)) + +(extern int + xterm_write_substring + (xw (* (struct xwindow))) + (x uint) (y uint) + (string (* char)) (start uint) (end uint) + (hl uint)) + +(extern int + xterm_clear_rectangle + (xw (* (struct xwindow))) + (x_start uint) (x_end uint) + (y_start uint) (y_end uint) + (hl uint)) + +(extern int + xterm_scroll_lines_up + (xw (* (struct xwindow))) + (x_start uint) (x_end uint) + (y_start uint) (y_end uint) + (lines uint)) + +(extern int + xterm_scroll_lines_down + (xw (* (struct xwindow))) + (x_start uint) (x_end uint) + (y_start uint) (y_end uint) + (lines uint)) + +(extern int + xterm_save_contents + (xw (* (struct xwindow))) + (x_start uint) (x_end uint) + (y_start uint) (y_end uint) + (contents (* char))) + +(extern int + xterm_restore_contents + (xw (* (struct xwindow))) + (x_start uint) (x_end uint) + (y_start uint) (y_end uint) + (contents (* char))) \ No newline at end of file diff --git a/src/x11/x11.h b/src/x11/x11.h new file mode 100644 index 000000000..ae11660f4 --- /dev/null +++ b/src/x11/x11.h @@ -0,0 +1,353 @@ +/* -*-C-*- + +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 + 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. + +*/ + +#ifndef SCHEME_X11_H +#define SCHEME_X11_H + +typedef unsigned long SCM; + +#include +#include +#include +#include +#include +#include + +enum event_type +{ + event_type_button_down, + event_type_button_up, + event_type_configure, + event_type_enter, + event_type_focus_in, + event_type_focus_out, + event_type_key_press, + event_type_leave, + event_type_motion, + event_type_expose, + event_type_delete_window, + event_type_map, + event_type_unmap, + event_type_take_focus, + event_type_visibility, + event_type_selection_clear, + event_type_selection_notify, + event_type_selection_request, + event_type_property_notify, + event_type_supremum +}; + +struct xdisplay +{ + unsigned int allocation_index; + Display * display; + unsigned int server_ping_timer; + Atom wm_protocols; + Atom wm_delete_window; + Atom wm_take_focus; + XEvent cached_event; + char cached_event_p; + + /* X key events have 8-bit modifier masks, three bits of which are + defined to be Shift, Lock, and Control, identified with ShiftMask, + LockMask, and ControlMask; and five bits of which are unspecified + named only mod1 to mod5. Which ones mean Meta, Super, Hyper, &c., + vary from system to system, however, so, on initializing the display + record, we grovel through some tables (XGetKeyboardMapping and + XGetModifierMapping) to find which ones the various modifier + keysyms are assigned to, and cache them here. + + Scheme knows about Shift, Control, Meta, Super, and Hyper. Of + these, only Meta, Super, and Hyper are identified by numbered + modifier masks. All other modifiers are ignored. */ + int modifier_mask_meta; + int modifier_mask_super; + int modifier_mask_hyper; + + /* The type of window manager we have. If we move FRAME_OUTER_WINDOW + to x/y 0/0, some window managers (type A) puts the window manager + decorations outside the screen and FRAME_OUTER_WINDOW exactly at 0/0. + Other window managers (type B) puts the window including decorations + at 0/0, so FRAME_OUTER_WINDOW is a bit below 0/0. + Record the type of WM in use so we can compensate for type A WMs. */ + enum + { + X_WMTYPE_UNKNOWN, + X_WMTYPE_A, + X_WMTYPE_B + } wm_type; +}; + +#define XD_ALLOCATION_INDEX(xd) ((xd) -> allocation_index) +#define XD_DISPLAY(xd) ((xd) -> display) +#define XD_SERVER_PING_TIMER(xd) ((xd) -> server_ping_timer) +#define XD_WM_PROTOCOLS(xd) ((xd) -> wm_protocols) +#define XD_WM_DELETE_WINDOW(xd) ((xd) -> wm_delete_window) +#define XD_WM_TAKE_FOCUS(xd) ((xd) -> wm_take_focus) +#define XD_MODIFIER_MASK_SHIFT(xd) (ShiftMask) +#define XD_MODIFIER_MASK_CONTROL(xd) (ControlMask) +#define XD_MODIFIER_MASK_LOCK(xd) (LockMask) +#define XD_MODIFIER_MASK_META(xd) ((xd) -> modifier_mask_meta) +#define XD_MODIFIER_MASK_SUPER(xd) ((xd) -> modifier_mask_super) +#define XD_MODIFIER_MASK_HYPER(xd) ((xd) -> modifier_mask_hyper) +#define XD_WM_TYPE(xd) ((xd) -> wm_type) + +#define X_MODIFIER_MASK_SHIFT_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_SHIFT (xd))) +#define X_MODIFIER_MASK_CONTROL_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_CONTROL (xd))) +#define X_MODIFIER_MASK_LOCK_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_LOCK (xd))) +#define X_MODIFIER_MASK_META_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_META (xd))) +#define X_MODIFIER_MASK_SUPER_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_SUPER (xd))) +#define X_MODIFIER_MASK_HYPER_P(modifier_mask, xd) \ + ((modifier_mask) & (XD_MODIFIER_MASK_HYPER (xd))) + +extern struct xdisplay * x_display_arg (unsigned int arg); + +struct drawing_attributes +{ + /* Width of the borders, in pixels. */ + int border_width; + int internal_border_width; + + /* The primary font. */ + XFontStruct * font; + + /* Standard pixel values. */ + unsigned long background_pixel; + unsigned long foreground_pixel; + unsigned long border_pixel; + unsigned long cursor_pixel; + unsigned long mouse_pixel; +}; + +/* This incomplete type definition is needed because the scope of the + implicit definition in the following typedefs is incorrect. */ +struct xwindow; + +typedef void (*x_deallocator_t) (struct xwindow *); +typedef void (*x_event_processor_t) (struct xwindow *, XEvent *); +typedef float (*x_coordinate_map_t) (struct xwindow *, unsigned int); +typedef void (*x_update_normal_hints_t) (struct xwindow *); + +struct xwindow_methods +{ + /* Deallocation procedure to do window-specific deallocation. */ + x_deallocator_t deallocator; + + /* Procedure to call on each received event. */ + x_event_processor_t event_processor; + + /* Procedures to map coordinates to Scheme objects. */ + x_coordinate_map_t x_coordinate_map; + x_coordinate_map_t y_coordinate_map; + + /* Procedure that is called to inform the window manager of + adjustments to the window's internal border or font. */ + x_update_normal_hints_t update_normal_hints; +}; + +struct xwindow +{ + unsigned int allocation_index; + Window window; + struct xdisplay * xd; + + /* Dimensions of the drawing region in pixels. */ + unsigned int x_size; + unsigned int y_size; + + /* The clip rectangle. */ + unsigned int clip_x; + unsigned int clip_y; + unsigned int clip_width; + unsigned int clip_height; + + struct drawing_attributes attributes; + + /* Standard graphics contexts. */ + GC normal_gc; + GC reverse_gc; + GC cursor_gc; + + /* The mouse cursor. */ + Cursor mouse_cursor; + + struct xwindow_methods methods; + + unsigned long event_mask; + + /* Geometry parameters for window-manager decoration window. */ + int wm_decor_x; + int wm_decor_y; + unsigned int wm_decor_pixel_width; + unsigned int wm_decor_pixel_height; + unsigned int wm_decor_border_width; + + /* The latest move we made to the window. Saved so we can + compensate for type A WMs (see wm_type above). */ + int expected_x; + int expected_y; + + /* Nonzero if we have made a move and need to check if the WM placed + us at the right position. */ + int check_expected_move_p; + + /* The offset we need to add to compensate for type A WMs. */ + int move_offset_x; + int move_offset_y; +}; + +#define XW_ALLOCATION_INDEX(xw) ((xw) -> allocation_index) +#define XW_XD(xw) ((xw) -> xd) +#define XW_WINDOW(xw) ((xw) -> window) +#define XW_X_SIZE(xw) ((xw) -> x_size) +#define XW_Y_SIZE(xw) ((xw) -> y_size) +#define XW_CLIP_X(xw) ((xw) -> clip_x) +#define XW_CLIP_Y(xw) ((xw) -> clip_y) +#define XW_CLIP_WIDTH(xw) ((xw) -> clip_width) +#define XW_CLIP_HEIGHT(xw) ((xw) -> clip_height) +#define XW_BORDER_WIDTH(xw) (((xw) -> attributes) . border_width) +#define XW_INTERNAL_BORDER_WIDTH(xw) \ + (((xw) -> attributes) . internal_border_width) +#define XW_FONT(xw) (((xw) -> attributes) . font) +#define XW_BACKGROUND_PIXEL(xw) (((xw) -> attributes) . background_pixel) +#define XW_FOREGROUND_PIXEL(xw) (((xw) -> attributes) . foreground_pixel) +#define XW_BORDER_PIXEL(xw) (((xw) -> attributes) . border_pixel) +#define XW_CURSOR_PIXEL(xw) (((xw) -> attributes) . cursor_pixel) +#define XW_MOUSE_PIXEL(xw) (((xw) -> attributes) . mouse_pixel) +#define XW_NORMAL_GC(xw) ((xw) -> normal_gc) +#define XW_REVERSE_GC(xw) ((xw) -> reverse_gc) +#define XW_CURSOR_GC(xw) ((xw) -> cursor_gc) +#define XW_MOUSE_CURSOR(xw) ((xw) -> mouse_cursor) +#define XW_DEALLOCATOR(xw) (((xw) -> methods) . deallocator) +#define XW_EVENT_PROCESSOR(xw) (((xw) -> methods) . event_processor) +#define XW_UPDATE_NORMAL_HINTS(xw) (((xw) -> methods) . update_normal_hints) +#define XW_EVENT_MASK(xw) ((xw) -> event_mask) +#define XW_WM_DECOR_X(xw) ((xw) -> wm_decor_x) +#define XW_WM_DECOR_Y(xw) ((xw) -> wm_decor_y) +#define XW_WM_DECOR_PIXEL_WIDTH(xw) ((xw) -> wm_decor_pixel_width) +#define XW_WM_DECOR_PIXEL_HEIGHT(xw) ((xw) -> wm_decor_pixel_height) +#define XW_WM_DECOR_BORDER_WIDTH(xw) ((xw) -> wm_decor_border_width) +#define XW_EXPECTED_X(xw) ((xw) -> expected_x) +#define XW_EXPECTED_Y(xw) ((xw) -> expected_y) +#define XW_CHECK_EXPECTED_MOVE_P(xw) ((xw) -> check_expected_move_p) +#define XW_MOVE_OFFSET_X(xw) ((xw) -> move_offset_x) +#define XW_MOVE_OFFSET_Y(xw) ((xw) -> move_offset_y) + +#define XW_DISPLAY(xw) (XD_DISPLAY (XW_XD (xw))) +#define XW_WM_TYPE(xw) (XD_WM_TYPE (XW_XD (xw))) + +#define FONT_WIDTH(f) (((f) -> max_bounds) . width) +#define FONT_HEIGHT(f) (((f) -> ascent) + ((f) -> descent)) +#define FONT_BASE(f) ((f) -> ascent) + +extern struct xwindow * x_window_arg (unsigned int arg); + +struct ximage +{ + unsigned int allocation_index; + XImage * image; +}; + +#define XI_ALLOCATION_INDEX(xi) ((xi) -> allocation_index) +#define XI_IMAGE(xi) ((xi) -> image) + +extern struct ximage * x_image_arg (unsigned int arg); +extern struct ximage * allocate_x_image (XImage * image); +extern void deallocate_x_image (struct ximage * xi); + +struct xvisual +{ + unsigned int allocation_index; + Visual * visual; +}; + +#define XV_ALLOCATION_INDEX(xv) ((xv) -> allocation_index) +#define XV_VISUAL(xv) ((xv) -> visual) + +extern struct xvisual * x_visual_arg (unsigned int arg); +extern struct xvisual * allocate_x_visual (Visual * visual); +extern void x_visual_deallocate (struct xvisual * xv); + +struct xcolormap +{ + unsigned int allocation_index; + Colormap colormap; + struct xdisplay * xd; +}; + +#define XCM_ALLOCATION_INDEX(xcm) ((xcm) -> allocation_index) +#define XCM_COLORMAP(xcm) ((xcm) -> colormap) +#define XCM_XD(xcm) ((xcm) -> xd) +#define XCM_DISPLAY(xcm) (XD_DISPLAY (XCM_XD (xcm))) + +extern struct xcolormap * x_colormap_arg (unsigned int arg); +extern struct xcolormap * allocate_x_colormap + (Colormap colormap, struct xdisplay * xd); +extern void deallocate_x_colormap (struct xcolormap * xcm); + +extern int x_debug; + +extern const char * x_get_default + (Display * display, + const char * resource_name, + const char * resource_class, + const char * property_name, + const char * property_class, + const char * sdefault); + +extern int x_default_attributes + (Display * display, + const char * resource_name, + const char * resource_class, + struct drawing_attributes * attributes); + +extern struct xwindow * x_make_window + (struct xdisplay * xd, + Window window, + int x_size, + int y_size, + struct drawing_attributes * attributes, + struct xwindow_methods * methods, + unsigned int size); + +extern void x_close_window (struct xwindow * xw); + +extern int xw_set_wm_input_hint (struct xwindow * xw, int input_hint); +extern int xw_set_wm_name (struct xwindow * xw, const char * name); +extern int xw_set_wm_icon_name (struct xwindow * xw, const char * name); + +extern int xw_make_window_map + (struct xwindow * xw, + const char * resource_name, + const char * resource_class, + int map_p); + +#endif /* defined (SCHEME_X11_H) */ diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg new file mode 100644 index 000000000..e8d71ca66 --- /dev/null +++ b/src/x11/x11.pkg @@ -0,0 +1,320 @@ +#| -*-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 + 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. + +|# + +;;;; X11 Graphics Packaging + +(global-definitions runtime/) + +(define-package (x11) + (parent ())) + +(define-package (x11 base) + (files "x11base") + (parent (x11)) + (export (x11) + x-visual-deallocate + x-close-display + x-close-all-displays + x-window-set-input-hint + x-window-set-name + x-window-set-icon-name + x-open-display + x-display-get-size + x-close-window + x-set-default-font + x-display-descriptor + x-max-request-size + x-display-process-events + x-select-input + x-window-event-mask + x-window-set-event-mask + x-window-or-event-mask + x-window-andc-event-mask + event-type:button-down + event-type:button-up + event-type:configure + event-type:enter + event-type:focus-in + event-type:focus-out + event-type:key-press + event-type:leave + event-type:motion + event-type:expose + event-type:delete-window + event-type:map + event-type:unmap + event-type:take-focus + event-type:visibility + event-type:selection-clear + event-type:selection-notify + event-type:selection-request + event-type:property-notify + number-of-event-types + x-window-display + x-window-x-size + x-window-y-size + x-window-beep + x-window-clear + x-display-flush + x-window-flush + x-display-sync + x-display-get-default + x-window-query-pointer + x-window-id + x-window-set-foreground-color + x-window-set-background-color + x-window-set-border-color + x-window-set-cursor-color + x-window-set-mouse-color + x-window-set-mouse-shape + x-window-set-font + x-window-set-border-width + x-window-set-internal-border-width + x-window-set-input-focus + x-window-map + x-window-iconify + x-window-withdraw + x-window-set-size + x-window-raise + x-window-lower + x-window-get-size + x-window-get-position + x-window-set-position + x-font-structure + x-free-font + x-list-fonts + x-intern-atom + x-get-atom-name + x-get-window-property + x-change-property + x-delete-property + x-set-selection-owner + x-get-selection-owner + x-convert-selection + x-send-selection-notify)) + +(define-package (x11 color) + (files "x11color") + (parent (x11)) + (export (x11) + x-window-visual + x-get-visual-info + x-window-colormap + x-set-window-colormap + x-create-colormap + x-free-colormap + x-allocate-color + x-store-color + x-store-colors + x-query-color) + (import (x11 base) + add-alien-cleanup! + cleanup-alien!)) + +(define-package (x11 graphics) + (files "x11graph") + (parent (x11)) + (export (x11) + x-graphics-set-vdc-extent + x-graphics-vdc-extent + x-graphics-reset-clip-rectangle + x-graphics-set-clip-rectangle + x-graphics-reconfigure + x-graphics-open-window + x-graphics-draw-line + x-graphics-move-cursor + x-graphics-drag-cursor + x-graphics-draw-point + x-graphics-draw-arc + x-graphics-draw-string + x-graphics-draw-image-string + x-graphics-set-function + x-graphics-draw-points + x-graphics-draw-lines + x-graphics-set-fill-style + x-graphics-set-line-style + x-graphics-set-dashes + x-graphics-copy-area + x-graphics-fill-polygon + x-create-image + x-bytes-into-image + x-get-pixel-from-image + x-set-pixel-in-image + x-destroy-image + x-display-image + x-read-image + x-window-depth + x-graphics-map-x-coordinate + x-graphics-map-y-coordinate)) + +(define-package (x11 device) + (files "x11device") + (parent (x11)) + (export (x11) + create-x-colormap + create-x-image + x-character-bounds/ascent + x-character-bounds/descent + x-character-bounds/lbearing + x-character-bounds/rbearing + x-character-bounds/width + x-colormap/allocate-color + x-colormap/free + x-colormap/query-color + x-colormap/store-color + x-colormap/store-colors + x-colormap? + x-display/name + x-display/properties + x-font-structure/all-chars-exist? + x-font-structure/character-bounds + x-font-structure/default-char + x-font-structure/direction + x-font-structure/max-ascent + x-font-structure/max-bounds + x-font-structure/max-descent + x-font-structure/min-bounds + x-font-structure/name + x-font-structure/start-index + x-geometry-string + x-graphics-default-display-name + x-graphics-default-geometry + x-graphics-device-type + x-graphics/available? + x-graphics/clear + x-graphics/close-display + x-graphics/close-window + x-graphics/color? + x-graphics/coordinate-limits + x-graphics/copy-area + x-graphics/device-coordinate-limits + x-graphics/disable-keyboard-focus + x-graphics/discard-events + x-graphics/display + x-graphics/drag-cursor + x-graphics/draw-arc + x-graphics/draw-circle + x-graphics/draw-line + x-graphics/draw-lines + x-graphics/draw-point + x-graphics/draw-points + x-graphics/draw-text + x-graphics/enable-keyboard-focus + x-graphics/fill-circle + x-graphics/flush + x-graphics/font-structure + x-graphics/get-colormap + x-graphics/get-default + x-graphics/iconify-window + x-graphics/image-depth + x-graphics/lower-window + x-graphics/map-window + x-graphics/move-cursor + x-graphics/move-window + x-graphics/open-display + x-graphics/open-display? + x-graphics/open-window? + x-graphics/query-pointer + x-graphics/raise-window + x-graphics/read-button + x-graphics/read-user-event + x-graphics/reset-clip-rectangle + x-graphics/resize-window + x-graphics/select-user-events + x-graphics/set-background-color + x-graphics/set-border-color + x-graphics/set-border-width + x-graphics/set-clip-rectangle + x-graphics/set-colormap + x-graphics/set-coordinate-limits + x-graphics/set-drawing-mode + x-graphics/set-font + x-graphics/set-foreground-color + x-graphics/set-icon-name + x-graphics/set-input-hint + x-graphics/set-internal-border-width + x-graphics/set-line-style + x-graphics/set-mouse-color + x-graphics/set-mouse-shape + x-graphics/set-window-name + x-graphics/starbase-filename + x-graphics/visual-info + x-graphics/window-id + x-graphics/withdraw-window + x-graphics:auto-raise? + x-image/destroy + x-image/draw + x-image/draw-subimage + x-image/fill-from-byte-vector + x-image/get-pixel + x-image/height + x-image/set-pixel + x-image/width + x-image? + x-visual-class:direct-color + x-visual-class:gray-scale + x-visual-class:pseudo-color + x-visual-class:static-color + x-visual-class:static-gray + x-visual-class:true-color + x-visual-info/bits-per-rgb + x-visual-info/blue-mask + x-visual-info/class + x-visual-info/colormap-size + x-visual-info/depth + x-visual-info/green-mask + x-visual-info/red-mask + x-visual-info/screen + x-visual-info/visual + x-visual-info/visual-id) + (import (runtime graphics) + make-image-type)) + +(define-package (x11 terminal) + (files "x11term") + (parent (x11)) + (export (x11) + xterm-erase-cursor + xterm-draw-cursor + xterm-dump-rectangle + xterm-reconfigure + xterm-map-x-coordinate + xterm-map-y-coordinate + xterm-map-x-size + xterm-map-y-size + xterm-open-window + xterm-x-size + xterm-y-size + xterm-set-size + xterm-enable-cursor + xterm-write-cursor! + xterm-write-char! + xterm-write-substring! + xterm-clear-rectangle! + xterm-scroll-lines-up + xterm-scroll-lines-down + xterm-save-contents + xterm-restore-contents)) \ No newline at end of file diff --git a/src/x11/x11base.c b/src/x11/x11base.c new file mode 100644 index 000000000..b3c22c756 --- /dev/null +++ b/src/x11/x11base.c @@ -0,0 +1,1839 @@ +/* -*-C-*- + +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 + 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. + +*/ + +/* Common X11 support. */ + +#include +#include +#include +#include "x11.h" +#include +#include + +extern void block_signals (void); +extern void unblock_signals (void); + +#ifndef X_DEFAULT_FONT +# define X_DEFAULT_FONT "fixed" +#endif + +int x_debug = 0; +static int initialization_done = 0; +static const char * x_default_font = 0; + +#define INITIALIZE_ONCE() \ +{ \ + if (!initialization_done) \ + initialize_once (); \ +} + +static void initialize_once (void); + +static void move_window (struct xwindow *, int, int); +static void check_expected_move (struct xwindow *); + +/* Allocation Tables */ + +struct allocation_table +{ + void ** items; + int length; +}; + +static struct allocation_table x_display_table; +static struct allocation_table x_window_table; +static struct allocation_table x_image_table; +static struct allocation_table x_visual_table; +static struct allocation_table x_colormap_table; + +static void +allocation_table_initialize (struct allocation_table * table) +{ + (table->length) = 0; +} + +static unsigned int +allocate_table_index (struct allocation_table * table, void * item) +{ + unsigned int length = (table->length); + unsigned int new_length; + void ** items = (table->items); + void ** new_items; + void ** scan; + void ** end; + if (length == 0) + { + new_length = 4; + new_items = (malloc ((sizeof (void *)) * new_length)); + } + else + { + scan = items; + end = (scan + length); + while (scan < end) + if ((*scan++) == 0) + { + (*--scan) = item; + return (scan - items); + } + new_length = (length * 2); + new_items = (realloc (items, ((sizeof (void *)) * new_length))); + } + scan = (new_items + length); + end = (new_items + new_length); + (*scan++) = item; + while (scan < end) + (*scan++) = 0; + (table->items) = new_items; + (table->length) = new_length; + return (length); +} + +static void * +allocation_item (unsigned int num, struct allocation_table * table) +{ + void * item; + if ((num < 0) || (num >= table->length)) + return (NULL); + return ((table->items) [num]); +} + +static struct xwindow * +x_window_to_xw (Display * display, Window window) +{ + struct xwindow ** scan = ((struct xwindow **) (x_window_table.items)); + struct xwindow ** end = (scan + (x_window_table.length)); + while (scan < end) + { + struct xwindow * xw = (*scan++); + if ((xw != 0) + && ((XW_DISPLAY (xw)) == display) + && ((XW_WINDOW (xw)) == window)) + return (xw); + } + return (0); +} + +struct ximage * +allocate_x_image (XImage * image) +{ + struct ximage * xi = (malloc (sizeof (struct ximage))); + unsigned int index = (allocate_table_index ((&x_image_table), xi)); + (XI_ALLOCATION_INDEX (xi)) = index; + (XI_IMAGE (xi)) = image; + return (xi); +} + +void +deallocate_x_image (struct ximage * xi) +{ + ((x_image_table.items) [XI_ALLOCATION_INDEX (xi)]) = 0; + free (xi); +} + +struct xvisual * +allocate_x_visual (Visual * visual) +{ + struct xvisual * xv = (malloc (sizeof (struct xvisual))); + unsigned int index = (allocate_table_index ((&x_visual_table), xv)); + (XV_ALLOCATION_INDEX (xv)) = index; + (XV_VISUAL (xv)) = visual; + return (xv); +} + +void +x_visual_deallocate (struct xvisual * xv) +{ + ((x_visual_table.items) [XV_ALLOCATION_INDEX (xv)]) = 0; + free (xv); +} + +struct xcolormap * +allocate_x_colormap (Colormap colormap, struct xdisplay * xd) +{ + struct xcolormap * xcm = (malloc (sizeof (struct xcolormap))); + unsigned int index = (allocate_table_index ((&x_colormap_table), xcm)); + (XCM_ALLOCATION_INDEX (xcm)) = index; + (XCM_COLORMAP (xcm)) = colormap; + (XCM_XD (xcm)) = xd; + return (xcm); +} + +void +deallocate_x_colormap (struct xcolormap * xcm) +{ + ((x_colormap_table.items) [XCM_ALLOCATION_INDEX (xcm)]) = 0; + free (xcm); +} + +/* Error Handlers */ + +static int +x_io_error_handler (Display * display) +{ + fprintf (stderr, "\nX IO Error\n"); + fflush (stderr); + return (0); +} + +typedef struct +{ + char message [2048]; + char terminate_p; + unsigned char code; +} x_error_info_t; + +static x_error_info_t x_error_info; + +static int +x_error_handler (Display * display, XErrorEvent * error_event) +{ + (x_error_info.code) = (error_event->error_code); + XGetErrorText (display, + (error_event->error_code), + (x_error_info.message), + (sizeof (x_error_info.message))); + if (x_error_info.terminate_p) + { + fprintf (stderr, "\nX Error: %s\n", (x_error_info.message)); + fprintf (stderr, " Request code: %d\n", + (error_event->request_code)); + fprintf (stderr, " Error serial: %lx\n", (error_event->serial)); + fflush (stderr); + } + return (0); +} + +static unsigned char +x_error_code (Display * display) +{ + XSync (display, False); + return (x_error_info.code); +} + +static int +any_x_errors_p (Display * display) +{ + return ((x_error_code (display)) != 0); +} + +/* Defaults and Attributes */ + +static int +x_decode_color (Display * display, + Colormap color_map, + const char * color_name, + unsigned long * color_return) +{ + XColor cdef; + if ((XParseColor (display, color_map, color_name, (&cdef))) + && (XAllocColor (display, color_map, (&cdef)))) + { + (*color_return) = (cdef.pixel); + return (1); + } + return (0); +} + +static int +xw_colormap (struct xwindow * xw, Colormap * cm) +{ + XWindowAttributes a; + if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) + return (0); + *cm = (a.colormap); + return (1); +} + +static int +color_pixel (char * color, Display * display, struct xwindow * xw, + unsigned long * result) +{ + Colormap cm; + if (! xw_colormap (xw, &cm)) + return (0); + if (! x_decode_color (display, cm, color, result)) + return (0); + return (1); +} + +static void +x_set_mouse_colors (Display * display, + Colormap color_map, + Cursor mouse_cursor, + unsigned long mouse_pixel, + unsigned long background_pixel) +{ + XColor mouse_color; + XColor background_color; + (mouse_color.pixel) = mouse_pixel; + XQueryColor (display, color_map, (&mouse_color)); + (background_color.pixel) = background_pixel; + XQueryColor (display, color_map, (&background_color)); + XRecolorCursor (display, mouse_cursor, (&mouse_color), (&background_color)); +} + +const char * +x_get_default (Display * display, + const char * resource_name, + const char * resource_class, + const char * property_name, + const char * property_class, + const char * sdefault) +{ + const char * result = (XGetDefault (display, resource_name, property_name)); + if (result != 0) + return (result); + result = (XGetDefault (display, resource_class, property_name)); + if (result != 0) + return (result); + result = (XGetDefault (display, resource_name, property_class)); + if (result != 0) + return (result); + result = (XGetDefault (display, resource_class, property_class)); + if (result != 0) + return (result); + return (sdefault); +} + +static unsigned long +x_default_color (Display * display, + const char * resource_name, + const char * resource_class, + const char * property_name, + const char * property_class, + unsigned long default_color) +{ + const char * color_name + = (x_get_default (display, resource_name, resource_class, + property_name, property_class, 0)); + unsigned long result; + return + (((color_name != 0) + && (x_decode_color (display, + (DefaultColormap (display, + (DefaultScreen (display)))), + color_name, + (&result)))) + ? result + : default_color); +} + +int +x_default_attributes (Display * display, + const char * resource_name, + const char * resource_class, + struct drawing_attributes * attributes) +{ + int screen_number = (DefaultScreen (display)); + (attributes->font) + = (XLoadQueryFont (display, + ((x_default_font != 0) + ? x_default_font + : (x_get_default (display, + resource_name, resource_class, + "font", "Font", + X_DEFAULT_FONT))))); + if ((attributes->font) == 0) + return (1); + { + const char * s + = (x_get_default (display, + resource_name, resource_class, + "borderWidth", "BorderWidth", + 0)); + (attributes->border_width) = ((s == 0) ? 0 : (atoi (s))); + } + { + const char * s + = (x_get_default (display, + resource_name, resource_class, + "internalBorder", "BorderWidth", + 0)); + (attributes->internal_border_width) + = ((s == 0) ? (attributes->border_width) : (atoi (s))); + } + { + unsigned long white_pixel = (WhitePixel (display, screen_number)); + unsigned long black_pixel = (BlackPixel (display, screen_number)); + unsigned long foreground_pixel; + (attributes->background_pixel) + = (x_default_color (display, + resource_name, resource_class, + "background", "Background", + white_pixel)); + foreground_pixel + = (x_default_color (display, + resource_name, resource_class, + "foreground", "Foreground", + black_pixel)); + (attributes->foreground_pixel) = foreground_pixel; + (attributes->border_pixel) + = (x_default_color (display, + resource_name, resource_class, + "borderColor", "BorderColor", + foreground_pixel)); + (attributes->cursor_pixel) + = (x_default_color (display, + resource_name, resource_class, + "cursorColor", "Foreground", + foreground_pixel)); + (attributes->mouse_pixel) + = (x_default_color (display, + resource_name, resource_class, + "pointerColor", "Foreground", + foreground_pixel)); + } + return (0); +} + +static int +get_wm_decor_geometry (struct xwindow * xw) +{ + Display * display = (XW_DISPLAY (xw)); + Window decor = (XW_WINDOW (xw)); + Window root; + unsigned int depth; + + { + Window parent; + Window * children; + unsigned int n_children; + while (1) + { + if ((!XQueryTree (display, decor, + (&root), (&parent), (&children), (&n_children))) + || (any_x_errors_p (display))) + { + fprintf (stderr, "\nXQueryTree failed!\n"); + fflush (stderr); + return (0); + } + if (children != 0) + XFree (children); + if (parent == root) + break; + decor = parent; + } + } + if ((!XGetGeometry (display, + decor, + (&root), + (& (XW_WM_DECOR_X (xw))), + (& (XW_WM_DECOR_Y (xw))), + (& (XW_WM_DECOR_PIXEL_WIDTH (xw))), + (& (XW_WM_DECOR_PIXEL_HEIGHT (xw))), + (& (XW_WM_DECOR_BORDER_WIDTH (xw))), + (&depth))) + || (any_x_errors_p (display))) + { + fprintf (stderr, "\nXGetGeometry failed!\n"); + fflush (stderr); + return (0); + } + /* Return true iff the window has been reparented by the WM. */ + return (decor != (XW_WINDOW (xw))); +} + +/* Open/Close Windows */ + +#define MAKE_GC(gc, fore, back) \ +{ \ + XGCValues gcv; \ + (gcv.font) = fid; \ + (gcv.foreground) = (fore); \ + (gcv.background) = (back); \ + (gc) = \ + (XCreateGC (display, \ + window, \ + (GCFont | GCForeground | GCBackground), \ + (& gcv))); \ +} + +struct xwindow * +x_make_window (struct xdisplay * xd, + Window window, + int x_size, + int y_size, + struct drawing_attributes * attributes, + struct xwindow_methods * methods, + unsigned int size) +{ + GC normal_gc; + GC reverse_gc; + GC cursor_gc; + struct xwindow * xw; + Display * display = (XD_DISPLAY (xd)); + Font fid = ((attributes->font) -> fid); + unsigned long foreground_pixel = (attributes->foreground_pixel); + unsigned long background_pixel = (attributes->background_pixel); + Cursor mouse_cursor = (XCreateFontCursor (display, XC_left_ptr)); + MAKE_GC (normal_gc, foreground_pixel, background_pixel); + MAKE_GC (reverse_gc, background_pixel, foreground_pixel); + MAKE_GC (cursor_gc, background_pixel, (attributes->cursor_pixel)); + x_set_mouse_colors + (display, + (DefaultColormap (display, (DefaultScreen (display)))), + mouse_cursor, + (attributes->mouse_pixel), + background_pixel); + XDefineCursor (display, window, mouse_cursor); + XSelectInput (display, window, 0); + if (size < (sizeof (struct xwindow))) + return (NULL); + xw = (malloc (size)); + (XW_ALLOCATION_INDEX (xw)) = (allocate_table_index ((&x_window_table), xw)); + (XW_XD (xw)) = xd; + (XW_WINDOW (xw)) = window; + (XW_X_SIZE (xw)) = x_size; + (XW_Y_SIZE (xw)) = y_size; + (XW_CLIP_X (xw)) = 0; + (XW_CLIP_Y (xw)) = 0; + (XW_CLIP_WIDTH (xw)) = x_size; + (XW_CLIP_HEIGHT (xw)) = y_size; + (xw->attributes) = (*attributes); + (xw->methods) = (*methods); + (XW_NORMAL_GC (xw)) = normal_gc; + (XW_REVERSE_GC (xw)) = reverse_gc; + (XW_CURSOR_GC (xw)) = cursor_gc; + (XW_MOUSE_CURSOR (xw)) = mouse_cursor; + (XW_EVENT_MASK (xw)) = 0; + (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0; + (XW_MOVE_OFFSET_X (xw)) = 0; + (XW_MOVE_OFFSET_Y (xw)) = 0; + return (xw); +} + +static jmp_buf x_close_window_jmp_buf; + +static int +x_close_window_io_error (Display * display) +{ + longjmp (x_close_window_jmp_buf, 1); + /*NOTREACHED*/ + return (0); +} + +void +x_close_window_internal (struct xwindow * xw) +{ + Display * display = (XW_DISPLAY (xw)); + ((x_window_table.items) [XW_ALLOCATION_INDEX (xw)]) = 0; + if ((setjmp (x_close_window_jmp_buf)) == 0) + { + XSetIOErrorHandler (x_close_window_io_error); + { + x_deallocator_t deallocator = (XW_DEALLOCATOR (xw)); + if (deallocator != 0) + (*deallocator) (xw); + } + { + XFontStruct * font = (XW_FONT (xw)); + if (font != 0) + XFreeFont (display, font); + } + XDestroyWindow (display, (XW_WINDOW (xw))); + /* Guarantee that the IO error occurs while the IO error handler + is rebound, if at all. */ + XFlush (display); + } + XSetIOErrorHandler (x_io_error_handler); + free (xw); +} + +/* Initialize/Close Displays */ + +#define MODIFIER_INDEX_TO_MASK(N) (1 << (N)) + +/* Grovel through the X server's keycode and modifier mappings to find + out what we ought to interpret as Meta, Hyper, and Super, based on + what modifiers are associated with keycodes that are associated with + keysyms Meta_L, Meta_R, Alt_L, Alt_R, Hyper_L, &c. + + Adapted from GNU Emacs. */ + +static void +x_initialize_display_modifier_masks (struct xdisplay * xd) +{ + int min_keycode; + int max_keycode; + XModifierKeymap * modifier_keymap; + KeyCode * modifier_to_keycodes_table; + int keycodes_per_modifier; + KeySym * keycode_to_keysyms_table; + int keysyms_per_keycode; + + (XD_MODIFIER_MASK_META (xd)) = 0; + (XD_MODIFIER_MASK_SUPER (xd)) = 0; + (XD_MODIFIER_MASK_HYPER (xd)) = 0; + + modifier_keymap = (XGetModifierMapping ((XD_DISPLAY (xd)))); + modifier_to_keycodes_table = (modifier_keymap->modifiermap); + keycodes_per_modifier = (modifier_keymap->max_keypermod); + + XDisplayKeycodes ((XD_DISPLAY (xd)), (& min_keycode), (& max_keycode)); + + keycode_to_keysyms_table + = (XGetKeyboardMapping ((XD_DISPLAY (xd)), + min_keycode, + (max_keycode - min_keycode + 1), + (& keysyms_per_keycode))); + + /* Go through each of the 8 non-preassigned modifiers, which start at + 3 (Mod1), after Shift, Control, and Lock. For each modifier, go + through all of the (non-zero) keycodes attached to it; for each + keycode, go through all of the keysyms attached to it; check each + keysym for the modifiers that we're interested in (Meta, Hyper, + and Super). */ + + { + int modifier_index; + + for (modifier_index = 3; (modifier_index < 8); modifier_index += 1) + { + int modifier_mask = (MODIFIER_INDEX_TO_MASK (modifier_index)); + KeyCode * keycodes + = (& (modifier_to_keycodes_table + [modifier_index * keycodes_per_modifier])); + + /* This is a flag specifying whether the modifier has already + been identified as Meta, which takes precedence over Hyper + and Super. (What about precedence between Hyper and + Super...? This is GNU Emacs's behaviour.) */ + int modifier_is_meta_p = 0; + + int keycode_index; + + for (keycode_index = 0; + (keycode_index < keycodes_per_modifier); + keycode_index += 1) + { + KeyCode keycode = (keycodes [keycode_index]); + + if (keycode == 0) + continue; + + { + int keysym_index; + KeySym * keysyms + = (& (keycode_to_keysyms_table + [(keycode - min_keycode) * keysyms_per_keycode])); + + for (keysym_index = 0; + (keysym_index < keysyms_per_keycode); + keysym_index += 1) + switch (keysyms [keysym_index]) + { + case XK_Meta_L: + case XK_Meta_R: + case XK_Alt_L: + case XK_Alt_R: + modifier_is_meta_p = 1; + (XD_MODIFIER_MASK_META (xd)) |= modifier_mask; + break; + + case XK_Hyper_L: + case XK_Hyper_R: + if (! modifier_is_meta_p) + (XD_MODIFIER_MASK_HYPER (xd)) |= modifier_mask; + goto next_modifier; + + case XK_Super_L: + case XK_Super_R: + if (! modifier_is_meta_p) + (XD_MODIFIER_MASK_SUPER (xd)) |= modifier_mask; + goto next_modifier; + } + } + } + + next_modifier: + continue; + } + } + + XFree (((char *) keycode_to_keysyms_table)); + XFreeModifiermap (modifier_keymap); +} + +void +x_close_display (struct xdisplay * xd) +{ + struct xwindow ** scan = ((struct xwindow **) (x_window_table.items)); + struct xwindow ** end = (scan + (x_window_table.length)); + while (scan < end) + { + struct xwindow * xw = (*scan++); + if ((xw != 0) && ((XW_XD (xw)) == xd)) + x_close_window_internal (xw); + } + ((x_display_table.items) [XD_ALLOCATION_INDEX (xd)]) = 0; + XCloseDisplay (XD_DISPLAY (xd)); +} + +void +x_close_all_displays (void) +{ + struct xdisplay ** scan = ((struct xdisplay **) (x_display_table.items)); + struct xdisplay ** end = (scan + (x_display_table.length)); + while (scan < end) + { + struct xdisplay * xd = (*scan++); + if (xd != 0) + x_close_display (xd); + } +} + +/* Window Manager Properties */ + +static int +xw_set_class_hint (struct xwindow * xw, const char * name, const char * class) +{ + XClassHint * class_hint = (XAllocClassHint ()); + if (class_hint == 0) + return (1); + /* This structure is misdeclared, so cast the args. */ + (class_hint->res_name) = ((char *) name); + (class_hint->res_class) = ((char *) class); + XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint); + XFree (class_hint); + return (0); +} + +int +xw_set_wm_input_hint (struct xwindow * xw, int input_hint) +{ + XWMHints * hints = (XAllocWMHints ()); + if (hints == 0) + return (1); + (hints->flags) = InputHint; + (hints->input) = (input_hint != 0); + XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints); + XFree (hints); + return (0); +} + +int +xw_set_wm_name (struct xwindow * xw, const char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) + return (1); + XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); + return (0); +} + +int +xw_set_wm_icon_name (struct xwindow * xw, const char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) + return (1); + XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); + return (0); +} + +int +x_window_set_input_hint (struct xwindow * xw, int input_hint) +{ + XWMHints * hints = (XAllocWMHints ()); + if (hints == 0) + return (1); + (hints->flags) = InputHint; + (hints->input) = (input_hint != 0); + XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints); + XFree (hints); + return (0); +} + +int +x_window_set_name (struct xwindow * xw, const char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) + return (1); + XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); + return (0); +} + +int +x_window_set_icon_name (struct xwindow * xw, const char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) + return (1); + XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); + return (0); +} + +int +xw_make_window_map (struct xwindow * xw, + const char * resource_name, + const char * resource_class, + int map_p) +{ + int code = xw_set_class_hint (xw, resource_name, resource_class); + if (code != 0) + return (code); + if (map_p) + { + XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + XFlush (XW_DISPLAY (xw)); + } + return (0); +} + +/* Event Processing */ + +/* Returns non-zero value if caller should ignore the event. */ + +#define EVENT_ENABLED(xw, type) \ + (((XW_EVENT_MASK (xw)) & (1 << ((unsigned int) (type)))) != 0) + +static int +xw_process_event (struct xwindow * xw, XEvent * event) +{ + int ignore_p = 0; + + if (x_debug > 0) + { + const char * type_name; + fprintf (stderr, "\nX event on 0x%lx: ", ((event->xany) . window)); + switch (event->type) + { + case ButtonPress: type_name = "ButtonPress"; break; + case ButtonRelease: type_name = "ButtonRelease"; break; + case CirculateNotify: type_name = "CirculateNotify"; break; + case CreateNotify: type_name = "CreateNotify"; break; + case DestroyNotify: type_name = "DestroyNotify"; break; + case EnterNotify: type_name = "EnterNotify"; break; + case Expose: type_name = "Expose"; break; + case FocusIn: type_name = "FocusIn"; break; + case FocusOut: type_name = "FocusOut"; break; + case GraphicsExpose: type_name = "GraphicsExpose"; break; + case GravityNotify: type_name = "GravityNotify"; break; + case KeyPress: type_name = "KeyPress"; break; + case KeyRelease: type_name = "KeyRelease"; break; + case LeaveNotify: type_name = "LeaveNotify"; break; + case MapNotify: type_name = "MapNotify"; break; + case MappingNotify: type_name = "MappingNotify"; break; + case MotionNotify: type_name = "MotionNotify"; break; + case NoExpose: type_name = "NoExpose"; break; + case ReparentNotify: type_name = "ReparentNotify"; break; + case SelectionClear: type_name = "SelectionClear"; break; + case SelectionRequest: type_name = "SelectionRequest"; break; + case UnmapNotify: type_name = "UnmapNotify"; break; + + case VisibilityNotify: + fprintf (stderr, "VisibilityNotify; state="); + switch ((event->xvisibility) . state) + { + case VisibilityUnobscured: + fprintf (stderr, "unobscured"); + break; + case VisibilityPartiallyObscured: + fprintf (stderr, "partially-obscured"); + break; + case VisibilityFullyObscured: + fprintf (stderr, "fully-obscured"); + break; + default: + fprintf (stderr, "%d", ((event->xvisibility) . state)); + break; + } + goto debug_done; + + case ConfigureNotify: + fprintf (stderr, "ConfigureNotify; x=%d y=%d width=%d height=%d", + ((event->xconfigure) . x), + ((event->xconfigure) . y), + ((event->xconfigure) . width), + ((event->xconfigure) . height)); + goto debug_done; + + case ClientMessage: + { + struct xdisplay * xd = (XW_XD (xw)); + if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event->xclient) . format) == 32)) + { + if (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_DELETE_WINDOW (xd))) + type_name = "WM_DELETE_WINDOW"; + else if (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_TAKE_FOCUS (xd))) + type_name = "WM_TAKE_FOCUS"; + else + type_name = "WM_PROTOCOLS"; + } + else + { + fprintf (stderr, "ClientMessage; message_type=0x%x format=%d", + ((unsigned int) ((event->xclient) . message_type)), + ((event->xclient) . format)); + goto debug_done; + } + } + break; + case PropertyNotify: + { + fprintf (stderr, "PropertyNotify; atom=%ld time=%ld state=%d", + ((event->xproperty) . atom), + ((event->xproperty) . time), + ((event->xproperty) . state)); + goto debug_done; + } + case SelectionNotify: + { + fprintf + (stderr, "SelectionNotify; sel=%ld targ=%ld prop=%ld t=%ld", + ((event->xselection) . selection), + ((event->xselection) . target), + ((event->xselection) . property), + ((event->xselection) . time)); + goto debug_done; + } + default: type_name = 0; break; + } + if (type_name != 0) + fprintf (stderr, "%s", type_name); + else + fprintf (stderr, "%d", (event->type)); + debug_done: + fprintf (stderr, "%s\n", + (((event->xany) . send_event) ? "; synthetic" : "")); + fflush (stderr); + } + switch (event->type) + { + case MappingNotify: + switch ((event->xmapping) . request) + { + case MappingModifier: + x_initialize_display_modifier_masks ((XW_XD (xw))); + /* Fall through. */ + case MappingKeyboard: + XRefreshKeyboardMapping (& (event->xmapping)); + break; + } + break; + } + if (xw != 0) + { + switch (event->type) + { + case ReparentNotify: + get_wm_decor_geometry (xw); + /* Perhaps reparented due to a WM restart. Reset this. */ + (XW_WM_TYPE (xw)) = X_WMTYPE_UNKNOWN; + ignore_p = 1; + break; + + case ConfigureNotify: + /* If the window has been reparented, don't check + non-synthetic events. */ + if ((XW_CHECK_EXPECTED_MOVE_P (xw)) + && (! ((get_wm_decor_geometry (xw)) + && (! ((event->xconfigure) . send_event))))) + check_expected_move (xw); + break; + + case ClientMessage: + { + struct xdisplay * xd = (XW_XD (xw)); + if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event->xclient) . format) == 32)) + { + if (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_DELETE_WINDOW (xd))) + { + if (! EVENT_ENABLED (xw, event_type_delete_window)) + ignore_p = 1; + } + else if (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_TAKE_FOCUS (xd))) + { + if (! EVENT_ENABLED (xw, event_type_take_focus)) + ignore_p = 1; + } + } + } + break; + } + (* (XW_EVENT_PROCESSOR (xw))) (xw, event); + } + return (ignore_p); +} + +int +x_event_delete_window_p (struct xwindow * xw, XEvent * event) +{ + struct xdisplay * xd = (XW_XD (xw)); + return ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event->xclient) . format) == 32) + && (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_DELETE_WINDOW (xd)))); +} + +int +x_event_take_focus_p (struct xwindow * xw, XEvent * event) +{ + struct xdisplay * xd = (XW_XD (xw)); + return ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event->xclient) . format) == 32) + && (((Atom) (((event->xclient) . data . l) [0])) + == (XD_WM_TAKE_FOCUS (xd)))); +} + +unsigned long +x_event_take_focus_time (XEvent * event) +{ + return (((event->xclient) . data . l) [1]); +} + +/* This handles only the modifier bits that Scheme supports. + At the moment, these are Control, Meta, Super, and Hyper. + This might want to change if the character abstraction were ever to + change, or if the X11 interface were to be changed to use something + other than Scheme characters to convey key presses. */ + +/* Copied from microcode/object.h(!): */ +#define CHAR_BITS_META 0x1 +#define CHAR_BITS_CONTROL 0x2 +#define CHAR_BITS_SUPER 0x4 +#define CHAR_BITS_HYPER 0x8 + +unsigned long +x_modifier_mask_to_bucky_bits (unsigned int mask, struct xwindow * xw) +{ + struct xdisplay * xd = (XW_XD (xw)); + unsigned long bucky = 0; + if (X_MODIFIER_MASK_CONTROL_P (mask, xd)) bucky |= CHAR_BITS_CONTROL; + if (X_MODIFIER_MASK_META_P (mask, xd)) bucky |= CHAR_BITS_META; + if (X_MODIFIER_MASK_SUPER_P (mask, xd)) bucky |= CHAR_BITS_SUPER; + if (X_MODIFIER_MASK_HYPER_P (mask, xd)) bucky |= CHAR_BITS_HYPER; + return (bucky); +} + +static XComposeStatus compose_status; + +int +x_lookup_string (XKeyEvent * event, char *buffer_return, int bytes_buffer, + KeySym * keysym_return) +{ + return (XLookupString (event, + buffer_return, + bytes_buffer, + keysym_return, + &compose_status)); +} + +static void +update_input_mask (struct xwindow * xw) +{ + { + unsigned long event_mask = 0; + if (EVENT_ENABLED (xw, event_type_expose)) + event_mask |= ExposureMask; + if ((EVENT_ENABLED (xw, event_type_configure)) + || (EVENT_ENABLED (xw, event_type_map)) + || (EVENT_ENABLED (xw, event_type_unmap))) + event_mask |= StructureNotifyMask; + if (EVENT_ENABLED (xw, event_type_button_down)) + event_mask |= ButtonPressMask; + if (EVENT_ENABLED (xw, event_type_button_up)) + event_mask |= ButtonReleaseMask; + if (EVENT_ENABLED (xw, event_type_key_press)) + event_mask |= KeyPressMask; + if (EVENT_ENABLED (xw, event_type_enter)) + event_mask |= EnterWindowMask; + if (EVENT_ENABLED (xw, event_type_leave)) + event_mask |= LeaveWindowMask; + if ((EVENT_ENABLED (xw, event_type_focus_in)) + || (EVENT_ENABLED (xw, event_type_focus_out))) + event_mask |= FocusChangeMask; + if (EVENT_ENABLED (xw, event_type_motion)) + event_mask |= (PointerMotionMask | PointerMotionHintMask); + if (EVENT_ENABLED (xw, event_type_visibility)) + event_mask |= VisibilityChangeMask; + if (EVENT_ENABLED (xw, event_type_property_notify)) + event_mask |= PropertyChangeMask; + XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask); + } + { + struct xdisplay * xd = (XW_XD (xw)); + Atom protocols [2]; + unsigned int n_protocols = 0; + if (EVENT_ENABLED (xw, event_type_delete_window)) + (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd)); + if (EVENT_ENABLED (xw, event_type_take_focus)) + (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd)); + if (n_protocols > 0) + XSetWMProtocols + ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols); + } +} + +static void +ping_server (struct xdisplay * xd) +{ + /* Periodically ping the server connection to see if it has died. */ + (XD_SERVER_PING_TIMER (xd)) += 1; + if ((XD_SERVER_PING_TIMER (xd)) >= 100) + { + (XD_SERVER_PING_TIMER (xd)) = 0; + XNoOp (XD_DISPLAY (xd)); + XFlush (XD_DISPLAY (xd)); + } +} + +static struct xwindow * +xd_process_events (struct xdisplay * xd, XEvent * result) +{ + Display * display = (XD_DISPLAY (xd)); + unsigned int events_queued; + XEvent event; + struct xwindow * retval = NULL; + if (x_debug > 1) + { + fprintf (stderr, "Enter xd_process_events\n"); + fflush (stderr); + } + ping_server (xd); + events_queued = (XEventsQueued (display, QueuedAfterReading)); + while (0 < events_queued) + { + struct xwindow * xw; + events_queued -= 1; + XNextEvent (display, (&event)); + if ((event.type) == KeymapNotify) + continue; + xw = (x_window_to_xw (display, (event.xany.window))); + if ((xw == 0) + && (! (((event.type) == PropertyNotify) + || ((event.type) == SelectionClear) + || ((event.type) == SelectionNotify) + || ((event.type) == SelectionRequest)))) + continue; + if (xw_process_event (xw, (&event))) + continue; + memcpy (result, &event, sizeof (XEvent)); + retval = xw; + break; + } + if (x_debug > 1) + { + fprintf (stderr, "Return from xd_process_events: 0x%lx\n", + ((unsigned long) retval)); + fflush (stderr); + } + return (retval); +} + +/* Open/Close Primitives */ + +static void +initialize_once (void) +{ + allocation_table_initialize (&x_display_table); + allocation_table_initialize (&x_window_table); + allocation_table_initialize (&x_image_table); + ((x_error_info.message) [0]) = '\0'; + (x_error_info.terminate_p) = 1; + (x_error_info.code) = 0; + XSetErrorHandler (x_error_handler); + XSetIOErrorHandler (x_io_error_handler); + initialization_done = 1; +} + +void +x_set_debug (int value) +{ + x_debug = value; +} + +struct xdisplay * +x_open_display (char * display_name) +{ + INITIALIZE_ONCE (); + { + struct xdisplay * xd = (malloc (sizeof (struct xdisplay))); + /* Added 7/95 by Nick in an attempt to fix problem Hal was having + with SWAT over PPP (i.e. slow connections). */ + block_signals (); + (XD_DISPLAY (xd)) = XOpenDisplay (display_name); + unblock_signals (); + if ((XD_DISPLAY (xd)) == 0) + { + free (xd); + return (NULL); + } + (XD_ALLOCATION_INDEX (xd)) + = (allocate_table_index ((&x_display_table), xd)); + (XD_SERVER_PING_TIMER (xd)) = 0; + (XD_WM_PROTOCOLS (xd)) + = (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False)); + (XD_WM_DELETE_WINDOW (xd)) + = (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False)); + (XD_WM_TAKE_FOCUS (xd)) + = (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False)); + x_initialize_display_modifier_masks (xd); + XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0, + ((unsigned char *) "\177"), 1); + return (xd); + } +} + +void +x_display_get_size (struct xdisplay * xd, long screen, int * results) +{ + Display * display = (XD_DISPLAY (xd)); + results[0] = (DisplayWidth (display, screen)); + results[1] = (DisplayHeight (display, screen)); +} + +void +x_close_window (struct xwindow * xw) +{ + Display * display = (XW_DISPLAY (xw)); + x_close_window_internal (xw); + XFlush (display); +} + +int +x_set_default_font (struct xdisplay * xd, const char * name) +{ + Display * display = (XD_DISPLAY (xd)); + XFontStruct * font = (XLoadQueryFont (display, name)); + char * copy; + if (font == 0) + return (1); + XFreeFont (display, font); + if (x_default_font != 0) + free ((void *)x_default_font); + copy = (malloc ((strlen (name)) + 1)); + strcpy (copy, name); + x_default_font = copy; + return (0); +} + +/* Event Processing Primitives */ + +int +x_display_descriptor (struct xdisplay * xd) +{ + Display * display = (XD_DISPLAY (xd)); + return (ConnectionNumber (display)); +} + +long +x_max_request_size (struct xdisplay * xd) +{ + Display * display = (XD_DISPLAY (xd)); + return (XMaxRequestSize (display)); +} + +struct xwindow * +x_display_process_events (struct xdisplay * xd, XEvent * event) +{ + return (xd_process_events (xd, event)); +} + +void +x_select_input (struct xdisplay * xd, Window window, long mask) +{ + Display * display = (XD_DISPLAY (xd)); + XSelectInput (display, window, mask); +} + +long +x_window_event_mask (struct xwindow * xw) +{ + return (XW_EVENT_MASK (xw)); +} + +int +x_window_set_event_mask (struct xwindow * xw, long mask) +{ + if (mask >= (1 << ((unsigned int) event_type_supremum))) + return (0); + (XW_EVENT_MASK (xw)) = mask; + update_input_mask (xw); + return (1); +} + +void +x_window_or_event_mask (struct xwindow * xw, long mask) +{ + (XW_EVENT_MASK (xw)) |= mask; + update_input_mask (xw); +} + +void +x_window_andc_event_mask (struct xwindow * xw, long mask) +{ + (XW_EVENT_MASK (xw)) &=~ mask; + update_input_mask (xw); +} + +/* Miscellaneous Primitives */ + +struct xdisplay * +x_window_display (struct xwindow * xw) +{ + return (XW_XD (xw)); +} + +long +x_window_screen_number (struct xwindow * xw) +{ + XWindowAttributes attrs; + XGetWindowAttributes((XW_DISPLAY (xw)), (XW_WINDOW(xw)), &attrs); + return (XScreenNumberOfScreen(attrs.screen)); +} + +int +x_window_x_size (struct xwindow * xw) +{ + return (XW_X_SIZE (xw)); +} + +int +x_window_y_size (struct xwindow * xw) +{ + return (XW_Y_SIZE (xw)); +} + +void +x_window_beep (struct xwindow * xw) +{ + XBell ((XW_DISPLAY (xw)), 0); /* base value */ +} + +void +x_window_clear (struct xwindow * xw) +{ + if (((XW_CLIP_X (xw)) == 0) + && ((XW_CLIP_Y (xw)) == 0) + && ((XW_CLIP_WIDTH (xw)) == (XW_X_SIZE (xw))) + && ((XW_CLIP_HEIGHT (xw)) == (XW_Y_SIZE (xw)))) + XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + else + XClearArea ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + ((XW_CLIP_X (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))), + ((XW_CLIP_Y (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))), + (XW_CLIP_WIDTH (xw)), + (XW_CLIP_HEIGHT (xw)), + False); +} + +void +x_display_flush (struct xdisplay * xd) +{ + XFlush (XD_DISPLAY (xd)); +} + +void +x_window_flush (struct xwindow * xw) +{ + XFlush (XW_DISPLAY (xw)); +} + +void +x_display_sync (struct xdisplay * xd, Bool discard) +{ + XSync ((XD_DISPLAY (xd)), discard); +} + +char * +x_display_get_default (struct xdisplay * xd, + char * resource_name, + char * class_name) +{ + return (XGetDefault ((XD_DISPLAY (xd)), resource_name, class_name)); +} + +int +x_window_query_pointer (struct xwindow * xw, int * result) +{ + Window root; + Window child; + int root_x; + int root_y; + int win_x; + int win_y; + unsigned int keys_buttons; + if (!XQueryPointer ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (&root), (&child), + (&root_x), (&root_y), + (&win_x), (&win_y), + (&keys_buttons))) + return (0); + result[0] = root_x; + result[1] = root_y; + result[2] = win_x; + result[3] = win_y; + result[4] = keys_buttons; + return (1); +} + +unsigned long +x_window_id (struct xwindow * xw) +{ + return (XW_WINDOW (xw)); +} + +/* Appearance Control Functions */ + +void +x_window_set_foreground_color_pixel (struct xwindow * xw, unsigned long pixel) +{ + Display * display = (XW_DISPLAY (xw)); + (XW_FOREGROUND_PIXEL (xw)) = pixel; + XSetForeground (display, (XW_NORMAL_GC (xw)), pixel); + XSetBackground (display, (XW_REVERSE_GC (xw)), pixel); +} + +void +x_window_set_foreground_color_name (struct xwindow * xw, char * color) +{ + Display * display = (XW_DISPLAY (xw)); + unsigned long pixel; + if (! color_pixel (color, display, xw, &pixel)) + return; + x_window_set_foreground_color_pixel (xw, pixel); +} + +int +x_window_set_background_color_pixel (struct xwindow * xw, unsigned long pixel) +{ + Display * display = (XW_DISPLAY (xw)); + Colormap cm; + if (! xw_colormap (xw, &cm)) + return (0); + (XW_BACKGROUND_PIXEL (xw)) = pixel; + XSetWindowBackground (display, (XW_WINDOW (xw)), pixel); + XSetBackground (display, (XW_NORMAL_GC (xw)), pixel); + XSetForeground (display, (XW_REVERSE_GC (xw)), pixel); + XSetForeground (display, (XW_CURSOR_GC (xw)), pixel); + x_set_mouse_colors (display, cm, + (XW_MOUSE_CURSOR (xw)), + (XW_MOUSE_PIXEL (xw)), + pixel); + return (1); +} + +void +x_window_set_background_color_name (struct xwindow * xw, char * color) +{ + Display * display = (XW_DISPLAY (xw)); + unsigned long pixel; + if (! color_pixel (color, display, xw, &pixel)) + return; + x_window_set_background_color_pixel (xw, pixel); +} + +void +x_window_set_border_color_pixel (struct xwindow * xw, unsigned long pixel) +{ + (XW_BORDER_PIXEL (xw)) = pixel; + XSetWindowBorder ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), pixel); +} + +void +x_window_set_border_color_name (struct xwindow * xw, char * color) +{ + Display * display = (XW_DISPLAY (xw)); + unsigned long pixel; + if (! color_pixel (color, display, xw, &pixel)) + return; + x_window_set_border_color_pixel (xw, pixel); +} + +void +x_window_set_cursor_color_pixel (struct xwindow * xw, unsigned long pixel) +{ + Display * display = (XW_DISPLAY (xw)); + (XW_CURSOR_PIXEL (xw)) = pixel; + XSetBackground (display, (XW_CURSOR_GC (xw)), pixel); +} + +void +x_window_set_cursor_color_name (struct xwindow * xw, char * color) +{ + Display * display = (XW_DISPLAY (xw)); + unsigned long pixel; + if (! color_pixel (color, display, xw, &pixel)) + return; + x_window_set_cursor_color_pixel (xw, pixel); +} + +int +x_window_set_mouse_color_pixel (struct xwindow * xw, unsigned long pixel) +{ + Display * display = (XW_DISPLAY (xw)); + Colormap cm; + if (! xw_colormap (xw, &cm)) + return (0); + (XW_MOUSE_PIXEL (xw)) = pixel; + x_set_mouse_colors (display, cm, + (XW_MOUSE_CURSOR (xw)), + pixel, + (XW_BACKGROUND_PIXEL (xw))); + return (1); +} + +void +x_window_set_mouse_color_name (struct xwindow * xw, char * color) +{ + Display * display = (XW_DISPLAY (xw)); + unsigned long pixel; + if (! color_pixel (color, display, xw, &pixel)) + return; + x_window_set_mouse_color_pixel (xw, pixel); +} + +int +x_window_set_mouse_shape (struct xwindow * xw, int shape) +{ + Display * display = (XW_DISPLAY (xw)); + Colormap cm; + Window window = (XW_WINDOW (xw)); + if (shape >= (XC_num_glyphs / 2)) + return (0); + if (! xw_colormap (xw, &cm)) + return (0); + { + Cursor old_cursor = (XW_MOUSE_CURSOR (xw)); + Cursor mouse_cursor = (XCreateFontCursor (display, (2 * shape))); + x_set_mouse_colors (display, cm, + mouse_cursor, + (XW_MOUSE_PIXEL (xw)), + (XW_BACKGROUND_PIXEL (xw))); + (XW_MOUSE_CURSOR (xw)) = mouse_cursor; + XDefineCursor (display, window, mouse_cursor); + XFreeCursor (display, old_cursor); + } + return (1); +} + +int +x_window_set_font (struct xwindow * xw, char * font_name) +{ + Display * display = (XW_DISPLAY (xw)); + XFontStruct * font = XLoadQueryFont (display, font_name); + if (font == 0) + return (0); + XFreeFont (display, (XW_FONT (xw))); + (XW_FONT (xw)) = font; + { + Font fid = (font->fid); + XSetFont (display, (XW_NORMAL_GC (xw)), fid); + XSetFont (display, (XW_REVERSE_GC (xw)), fid); + XSetFont (display, (XW_CURSOR_GC (xw)), fid); + } + if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) + (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); + return (1); +} + +void +x_window_set_border_width (struct xwindow * xw, uint border_width) +{ + Display * display = (XW_DISPLAY (xw)); + (XW_BORDER_WIDTH (xw)) = border_width; + XSetWindowBorderWidth (display, (XW_WINDOW (xw)), border_width); +} + +void +x_window_set_internal_border_width (struct xwindow * xw, + uint internal_border_width) +{ + (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width; + if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) + (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); + XResizeWindow ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + ((XW_X_SIZE (xw)) + (2 * internal_border_width)), + ((XW_Y_SIZE (xw)) + (2 * internal_border_width))); +} + +/* WM Communication Primitives */ + +int +x_window_set_input_focus (struct xwindow * xw, Time time) +{ + Display * display = (XW_DISPLAY (xw)); + XSetInputFocus (display, (XW_WINDOW (xw)), RevertToParent, time); + if (any_x_errors_p (display)) + return (1); + return (0); +} + +/* WM Control Primitives */ + +void +x_window_map (struct xwindow * xw) +{ + XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); +} + +void +x_window_iconify (struct xwindow * xw) +{ + Display * display = (XW_DISPLAY (xw)); + XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); +} + +void +x_window_withdraw (struct xwindow * xw) +{ + Display * display = (XW_DISPLAY (xw)); + XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); +} + +void +x_window_set_size (struct xwindow * xw, int width, int height) +{ + unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); + XResizeWindow ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + width + extra, + height + extra); +} + +void +x_window_raise (struct xwindow * xw) +{ + XRaiseWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); +} + +void +x_window_lower (struct xwindow * xw) +{ + XLowerWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); +} + +void +x_window_get_size (struct xwindow * xw, int * dimens) +{ + unsigned int extra; + + get_wm_decor_geometry (xw); + extra = (2 * (XW_WM_DECOR_BORDER_WIDTH (xw))); + dimens[0] = (XW_WM_DECOR_PIXEL_WIDTH (xw)) + extra; + dimens[1] = (XW_WM_DECOR_PIXEL_HEIGHT (xw)) + extra; +} + +void +x_window_get_position (struct xwindow * xw, int * coord_return) +{ + get_wm_decor_geometry (xw); + coord_return[0] = (XW_WM_DECOR_X (xw)); + coord_return[1] = (XW_WM_DECOR_Y (xw)); +} + +void +x_window_set_position (struct xwindow * xw, int x, int y) +{ + if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) + (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); + if ((XW_WM_TYPE (xw)) == X_WMTYPE_A) + { + x += (XW_MOVE_OFFSET_X (xw)); + y += (XW_MOVE_OFFSET_Y (xw)); + } + XMoveWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), x, y); + if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN) + { + (XW_EXPECTED_X (xw)) = x; + (XW_EXPECTED_Y (xw)) = y; + (XW_CHECK_EXPECTED_MOVE_P (xw)) = 1; + } +} + +static void +check_expected_move (struct xwindow * xw) +{ + if (((XW_WM_DECOR_X (xw)) == (XW_EXPECTED_X (xw))) + && ((XW_WM_DECOR_Y (xw)) == (XW_EXPECTED_Y (xw)))) + { + if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN) + (XW_WM_TYPE (xw)) = X_WMTYPE_B; + } + else + { + (XW_WM_TYPE (xw)) = X_WMTYPE_A; + (XW_MOVE_OFFSET_X (xw)) = ((XW_EXPECTED_X (xw)) - (XW_WM_DECOR_X (xw))); + (XW_MOVE_OFFSET_Y (xw)) = ((XW_EXPECTED_Y (xw)) - (XW_WM_DECOR_Y (xw))); + x_window_set_position (xw, (XW_EXPECTED_X (xw)), (XW_EXPECTED_Y (xw))); + } + (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0; +} + +/* Font Structure Primitive */ + +XFontStruct * +x_font_structure_by_name (struct xdisplay * xd, const char * font_name) +{ + Display * display = XD_DISPLAY (xd); + return (XLoadQueryFont (display, font_name)); +} + +XFontStruct * +x_font_structure_by_id (struct xdisplay * xd, XID id) +{ + Display * display = (XD_DISPLAY (xd)); + return (XQueryFont (display, id)); +} + +void +x_free_font (struct xdisplay * xd, XFontStruct *font) +{ + Display * display = (XD_DISPLAY (xd)); + XFreeFont (display, font); +} + +char * * +x_list_fonts (struct xdisplay * xd, char * pattern, long limit, + int * actual_count) +{ + return (XListFonts ((XD_DISPLAY (xd)), pattern, limit, actual_count)); +} + +/* Atoms */ + +Atom +x_intern_atom (struct xdisplay * xd, const char * name, int soft_p) +{ + return (XInternAtom ((XD_DISPLAY (xd)), name, soft_p)); +} + +int +x_get_atom_name (struct xdisplay * xd, Atom atom, char * * name_return) +{ + Display * display = (XD_DISPLAY (xd)); + *name_return = (XGetAtomName (display, atom)); + return (x_error_code (display)); +} + +/* Window Properties */ + +int +x_get_window_property (struct xdisplay * xd, Window window, Atom property, + long long_offset, long long_length, Bool delete, + Atom req_type, + Atom * actual_type_return, int * actual_format_return, + unsigned long * nitems_return, + unsigned long * bytes_after_return, + unsigned char * * prop_return) +{ + Display * display = (XD_DISPLAY (xd)); + + Atom actual_type; + int actual_format; + unsigned long nitems; + unsigned long bytes_after; + unsigned char * data; + + if ((XGetWindowProperty (display, window, property, long_offset, + long_length, delete, req_type, + (&actual_type), (&actual_format), + (&nitems), (&bytes_after), (&data))) + != Success) + return (1); + if (actual_format == 0) + { + XFree (data); + return (2); + } + if (! ((actual_format == 8) + || (actual_format == 16) + || (actual_format == 32))) + return (3); + return (0); +} + +int +x_change_property (struct xdisplay * xd, Window window, + Atom property, Atom type, int format, int mode, + char * data, unsigned long dlen) +{ + Display * display = (XD_DISPLAY (xd)); + + if (mode >= 3) + return (0); + XChangeProperty (display, window, property, type, format, mode, data, dlen); + return (x_error_code (display)); +} + +void +x_delete_property (struct xdisplay * xd, Window window, Atom property) +{ + XDeleteProperty ((XD_DISPLAY (xd)), window, property); +} + +/* Selections */ + +void +x_set_selection_owner (struct xdisplay * xd, Atom selection, + Window owner, Time time) +{ + Display * display = (XD_DISPLAY (xd)); + XSetSelectionOwner (display, selection, owner, time); +} + +Window +x_get_selection_owner (struct xdisplay * xd, Atom selection) +{ + return (XGetSelectionOwner ((XD_DISPLAY (xd)), selection)); +} + +void +x_convert_selection (struct xdisplay * xd, Atom selection, Atom target, + Atom property, Window requestor, Time time) +{ + XConvertSelection ((XD_DISPLAY (xd)), selection, target, property, + requestor, time); +} + +void +x_send_selection_notify (struct xdisplay * xd, Window requestor, + Atom selection, Atom target, Atom property, Time time) +{ + Display * display = (XD_DISPLAY (xd)); + XSelectionEvent event; + (event.type) = SelectionNotify; + (event.display) = display; + (event.requestor) = requestor; + (event.selection) = selection; + (event.target) = target; + (event.property) = property; + (event.time) = time; + XSendEvent (display, requestor, False, 0, ((XEvent *) (&event))); +} diff --git a/src/x11/x11base.scm b/src/x11/x11base.scm new file mode 100644 index 000000000..a98d29a53 --- /dev/null +++ b/src/x11/x11base.scm @@ -0,0 +1,987 @@ +#| -*-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 + 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. + +|# + +;;;; X11 interface +;;; package: (x11) +;;; +;;; These were once primitives created by x11base.c in umodule prx11. + +(C-include "x11") + +(define (x-visual-deallocate xvisual) + (guarantee-xvisual xvisual 'x-visual-deallocate) + (C-call "x_visual_deallocate" xvisual) + (alien-null! xvisual)) + +;;; Initialize/Close Displays + +(define (x-close-display xd) + (guarantee-xdisplay xd 'x-close-display) + (C-call "x_close_display" xd)) + +(define (x-close-all-displays) + (C-call "x_close_all_displays")) + +;;; Window Manager Properties + +(define (x-window-set-input-hint window hint) + (guarantee-xwindow window 'x-window-set-input-hint) + (if (not (zero? (C-call "x_window_set_input_hint" window hint))) + (error "XAllocWMHints failed."))) + +(define (x-window-set-name window name) + (guarantee-xwindow window 'x-window-set-name) + (if (not (zero? (C-call "x_window_set_name" window name))) + (error "XStringListToTextProperty failed."))) + +(define (x-window-set-icon-name window name) + (guarantee-xwindow window 'x-window-set-icon-name) + (if (not (zero? (C-call "x_window_set_icon_name" window name))) + (error "XStringListToTextProperty failed."))) + +;;; Open/Close + +(define (x-open-display display-name) + (let ((alien (make-alien '(struct |xdisplay|)))) + (C-call "x_open_display" alien (if (eq? #f display-name) 0 display-name)) + (if (alien-null? alien) + (error "Could not open display:" display-name) + alien))) + +(define (x-display-get-size display screen) + (guarantee-xdisplay display 'x-display-get-size) + (let ((results (malloc (* 2 (c-sizeof "int"))))) + (c-call "x_display_get_size" display screen results) + (let ((width (c-> results "int")) + (height (c-> (c-array-loc results "int" 1) "int"))) + (free results) + (cons width height)))) + +(define (x-close-window xw) + (guarantee-xwindow xw 'x-close-window) + (C-call "x_close_window" xw)) + +(define (x-set-default-font display font-name) + (guarantee-xdisplay display 'x-set-default-font) + (if (not (zero? (c-call "x_set_default_font" display font-name))) + (error "Could not load font:" font-name))) + +;;; Event Processing + +(define (x-display-descriptor display) + (guarantee-xdisplay display 'x-display-descriptor) + (C-call "x_display_descriptor" display)) + +(define (x-max-request-size display) + (guarantee-xdisplay display 'x-max-request-size) + (c-call "x_max_request_size" display)) + +(define (x-display-process-events display how) + (declare (ignore how)) + (guarantee-xdisplay display 'x-display-process-events) + (let* ((event (malloc (C-sizeof "XEvent") '|XEvent|)) + (window (C-call "x_display_process_events" + (make-alien '(struct |xwindow|)) + display event))) + (let ((obj (if (alien-null? window) + #f + (make-event-object window event)))) + (free event) + obj))) + +(define (event-type xtype window xevent) + (cond + ((eq? xtype (C-enum "KeyPress")) event-type:key-press) + ((eq? xtype (C-enum "ButtonPress")) event-type:button-down) + ((eq? xtype (C-enum "ButtonRelease")) event-type:button-up) + ((eq? xtype (C-enum "MotionNotify")) event-type:motion) + ((eq? xtype (C-enum "ConfigureNotify")) event-type:configure) + ((eq? xtype (C-enum "Expose")) event-type:expose) + ((eq? xtype (C-enum "GraphicsExpose")) event-type:expose) + ((eq? xtype (C-enum "ClientMessage")) + (cond ((not (zero? (C-call "x_event_delete_window_p" + window xevent))) + event-type:delete-window) + ((not (zero? (C-call "x_event_take_focus_p" + window xevent))) + event-type:take-focus) + (else + (warn "Unexpected ClientMessage.") + #f))) + ((eq? xtype (C-enum "VisibilityNotify")) event-type:visibility) + ((eq? xtype (C-enum "SelectionClear")) event-type:selection-clear) + ((eq? xtype (C-enum "SelectionNotify")) event-type:selection-notify) + ((eq? xtype (C-enum "SelectionRequest")) event-type:selection-request) + ((eq? xtype (C-enum "PropertyNotify")) event-type:property-notify) + ((eq? xtype (C-enum "EnterNotify")) event-type:enter) + ((eq? xtype (C-enum "LeaveNotify")) event-type:leave) + ((eq? xtype (C-enum "FocusIn")) event-type:focus-in) + ((eq? xtype (C-enum "FocusOut")) event-type:focus-out) + ((eq? xtype (C-enum "MapNotify")) event-type:map) + ((eq? xtype (C-enum "UnmapNotify")) event-type:unmap) + (else (warn "Unexpected XEvent.") #f))) + +(define (event-name scmtype) + (let ((sym (C-enum "ScmEventType" scmtype))) + (if (not sym) + "" + (symbol-name sym)))) + +(define (make-event-object window xevent) + (let* ((xtype (C-> xevent "XEvent type")) + (scmtype (event-type xtype window xevent))) + + (define (event . slots) + (apply vector scmtype window slots)) + + (and + (not (eq? #f scmtype)) + (not (zero? (bitwise-and scmtype (C-call "x_window_event_mask" window)))) + (cond + + ((eq? scmtype event-type:key-press) ; xtype = KeyPress + (key-event window xevent event-type:key-press)) + + ((eq? scmtype event-type:button-down) ; xtype = ButtonPress + (button-event window xevent event-type:button-down)) + + ((eq? scmtype event-type:button-up) ; xtype = ButtonRelease + (button-event window xevent event-type:button-up)) + + ((eq? scmtype event-type:motion) ; xtype = MotionNotify + (event (C-> xevent "XMotionEvent x") + (C-> xevent "XMotionEvent y") + (x-key-button-mask-to-scheme + (C-> xevent "XMotionEvent state")))) + + ((eq? scmtype event-type:configure) ; xtype = ConfigureNotif + (event (C-> xevent "XConfigureEvent width") + (C-> xevent "XConfigureEvent height"))) + + ((eq? scmtype event-type:expose) + (if (eq? xtype (C-enum "GraphicsExpose")) + (event (C-> xevent "XGraphicsExposeEvent x") ; xtype = GraphicsExpose + (C-> xevent "XGraphicsExposeEvent y") + (C-> xevent "XGraphicsExposeEvent width") + (C-> xevent "XGraphicsExposeEvent height") + 1) + (event (C-> xevent "XExposeEvent x") ; xtype = Expose + (C-> xevent "XExposeEvent y") + (C-> xevent "XExposeEvent width") + (C-> xevent "XExposeEvent height") + 0))) + + ((eq? scmtype event-type:delete-window) ; xtype = ClientMessage + (event)) + + ((eq? scmtype event-type:take-focus) ; xtype = ClientMessage + (event (C-call "x_event_take_focus_time" window xevent))) + + ((eq? scmtype event-type:visibility) ; xtype = VisibilityNoti + (event + (let ((state (C-> xevent "XVisibilityEvent state"))) + (cond ((eq? state (C-enum "VisibilityUnobscured")) 0) + ((eq? state (C-enum "VisibilityPartiallyObscured")) 1) + ((eq? state (C-enum "VisibilityFullyObscured")) 2) + (else 3))))) + + ((eq? scmtype event-type:selection-clear) ; xtype = SelectionClear + (event (C-> xevent "XSelectionClearEvent selection") + (C-> xevent "XSelectionClearEvent time"))) + + ((eq? scmtype event-type:selection-notify) ; xtype = SelectionNotif + (event (C-> xevent "XSelectionEvent requestor") + (C-> xevent "XSelectionEvent selection") + (C-> xevent "XSelectionEvent target") + (C-> xevent "XSelectionEvent property") + (C-> xevent "XSelectionEvent time"))) + + ((eq? scmtype event-type:selection-request) ; xtype = SelectionReque + (event (C-> xevent "XSelectionRequestEvent requestor") + (C-> xevent "XSelectionRequestEvent selection") + (C-> xevent "XSelectionRequestEvent target") + (C-> xevent "XSelectionRequestEvent property") + (C-> xevent "XSelectionRequestEvent time"))) + + ((eq? scmtype event-type:property-notify) ; xtype = PropertyNotify + (event + ;; Must be an alien Window because this window + ;; might not have a corresponding XW object. + (C-> xevent "XPropertyEvent window") + (C-> xevent "XPropertyEvent atom") + (C-> xevent "XPropertyEvent time") + (C-> xevent "XPropertyEvent state"))) + + ((or (eq? scmtype event-type:enter) ; xtype = EnterNotify + (eq? scmtype event-type:leave) ; xtype = LeaveNotify + (eq? scmtype event-type:focus-in) ; xtype = FocusIn + (eq? scmtype event-type:focus-out) ; xtype = FocusOut + (eq? scmtype event-type:map) ; xtype = MapNotify + (eq? scmtype event-type:unmap)) ; xtype = UnmapNotify + (event)) + + (else + (warn "Mistranslated XEvent type.") + #f))))) + +(define (key-event window event type) + (define-integrable buffer-size 80) + (let ((buffer (malloc buffer-size 'char)) + (keysym-buffer (malloc (C-sizeof "KeySym") '|KeySym|))) + ;; Make ShiftLock modifier not affect keys with other modifiers. + (let ((state (C-> event "XKeyEvent state"))) + (if (and (not (zero? (bitwise-and state key-event-state-mask))) + (not (zero? (bitwise-and state (C-enum "LockMask"))))) + (C->= event "XKeyEvent state" (bitwise-nand state + (C-enum "LockMask")))) + (let* ((nbytes (C-call "x_lookup_string" + event buffer buffer-size keysym-buffer)) + (keysym (C-> keysym-buffer "KeySym"))) + (and (not (= keysym (C-enum "NoSymbol"))) + (not (= (C-enum "True") (C-call "IsModifierKey" keysym))) + (vector type + window + ;; If the BackSpace keysym is received, and + ;; XLookupString has translated it into ASCII + ;; backspace, substitute ASCII DEL instead. + (if (and (= keysym (C-enum "XK_BackSpace")) + (= nbytes 1) + (= (C-> buffer "char") (char->ascii #\b))) + (char->string #\Delete) + (let ((string (make-string nbytes))) + (c-peek-bytes buffer 0 nbytes string 0) + string)) + ;; Create Scheme bucky bits (kept independent of + ;; the character). X has already controlified, so + ;; Scheme may choose to ignore the control bucky + ;; bit. + (C-call "x_modifier_mask_to_bucky_bits" state window) + keysym + (C-> event "XKeyEvent time"))))))) + +(define key-event-state-mask + (+ (C-enum "ShiftMask") + (C-enum "ControlMask") + (C-enum "Mod1Mask") (C-enum "Mod2Mask") (C-enum "Mod3Mask") + (C-enum "Mod4Mask") (C-enum "Mod5Mask"))) + +(define (button-event window event type) + (vector type + window + (C-> event "XButtonEvent x") + (C-> event "XButtonEvent y") + (let ((button (C-> event "XButtonEvent button")) + (state (C-> event "XButtonEvent state"))) + (if (and (<= 1 button) (<= button 256)) + (+ (-1+ button) + (* 256 (C-call "x_modifier_mask_to_bucky_bits" + state window))) + #f)) + (C-> event "XButtonEvent time"))) + +(define (x-key-button-mask-to-scheme xstate) + ;; I'm not sure why we have a function for this. + (+ (if (eq? xstate (C-enum "ControlMask")) #x0001 0) + (if (eq? xstate (C-enum "Mod1Mask")) #x0002 0) + (if (eq? xstate (C-enum "Mod2Mask")) #x0004 0) + (if (eq? xstate (C-enum "Mod3Mask")) #x0008 0) + (if (eq? xstate (C-enum "ShiftMask")) #x0010 0) + (if (eq? xstate (C-enum "LockMask")) #x0020 0) + (if (eq? xstate (C-enum "Mod4Mask")) #x0040 0) + (if (eq? xstate (C-enum "Mod5Mask")) #x0080 0) + (if (eq? xstate (C-enum "Button1Mask")) #x0100 0) + (if (eq? xstate (C-enum "Button2Mask")) #x0200 0) + (if (eq? xstate (C-enum "Button3Mask")) #x0400 0) + (if (eq? xstate (C-enum "Button4Mask")) #x0800 0) + (if (eq? xstate (C-enum "Button5Mask")) #x1000 0))) + +(define (x-select-input display window event-mask) + (guarantee-xdisplay display 'x-select-input) + (guarantee-xwindow window 'x-select-input) + (c-call "x_select_input" display window event-mask)) + +(define (x-window-event-mask window) + (guarantee-xwindow window 'x-window-event-mask) + (C-call "x_window_event_mask" window)) + +(define (x-window-set-event-mask window mask) + (guarantee-xwindow window 'x-window-set-event-mask) + (if (zero? (C-call "x_window_set_event_mask" window mask)) + (error "Bad mask:" mask))) + +(define (x-window-or-event-mask window event-mask) + (guarantee-xwindow window 'x-window-or-event-mask) + (if (>= event-mask (c-enum "event_type_supremum")) + (error:bad-range-argument event-mask 'x-window-andc-event-mask)) + (c-call "x_window_or_event_mask" window event-mask)) + +(define (x-window-andc-event-mask window event-mask) + (guarantee-xwindow window 'x-window-andc-event-mask) + (if (>= event-mask (c-enum "event_type_supremum")) + (error:bad-range-argument event-mask 'x-window-andc-event-mask)) + (c-call "x_window_andc_event_mask" window event-mask)) + +(define event-type:button-down (C-enum "event_type_button_down")) +(define event-type:button-up (C-enum "event_type_button_up")) +(define event-type:configure (C-enum "event_type_configure")) +(define event-type:enter (C-enum "event_type_enter")) +(define event-type:focus-in (C-enum "event_type_focus_in")) +(define event-type:focus-out (C-enum "event_type_focus_out")) +(define event-type:key-press (C-enum "event_type_key_press")) +(define event-type:leave (C-enum "event_type_leave")) +(define event-type:motion (C-enum "event_type_motion")) +(define event-type:expose (C-enum "event_type_expose")) +(define event-type:delete-window (C-enum "event_type_delete_window")) +(define event-type:map (C-enum "event_type_map")) +(define event-type:unmap (C-enum "event_type_unmap")) +(define event-type:take-focus (C-enum "event_type_take_focus")) +(define event-type:visibility (C-enum "event_type_visibility")) +(define event-type:selection-clear (C-enum "event_type_selection_clear")) +(define event-type:selection-notify (C-enum "event_type_selection_notify")) +(define event-type:selection-request (C-enum "event_type_selection_request")) +(define event-type:property-notify (C-enum "event_type_property_notify")) +(define number-of-event-types (C-enum "event_type_supremum")) + +;;; Miscellaneous + +(define (x-window-display window) + (guarantee-xwindow window 'x-window-display) + (c-call "x_window_display" (make-alien '(struct xdisplay)) window)) + +(define (x-window-x-size window) + (guarantee-xwindow window 'x-window-x-size) + (C-call "x_window_x_size" window)) + +(define (x-window-y-size window) + (guarantee-xwindow window 'x-window-y-size) + (C-call "x_window_y_size" window)) + +(define (x-window-beep window) + (guarantee-xwindow window 'x-window-beep) + (C-call "x_window_beep" window)) + +(define (x-window-clear window) + (guarantee-xwindow window 'x-window-clear) + (C-call "x_window_clear" window)) + +(define (x-display-flush xd) + (guarantee-xdisplay xd 'x-display-flush) + (C-call "x_display_flush" xd)) + +(define (x-window-flush window) + (guarantee-xwindow window 'x-window-flush) + (C-call "x_window_flush" window)) + +(define (x-display-sync display discard?) + (guarantee-xdisplay display 'x-display-sync) + (c-call "x_display_sync" display (if discard? 1 0))) + +(define (x-display-get-default display resource-name class-name) + (guarantee-xdisplay display 'x-display-get-default) + (c-peek-cstring + (C-call "x_display_get_default" (make-alien 'char) + display resource-name class-name))) + +(define (x-window-query-pointer window) + (guarantee-xwindow window 'x-window-query-pointer) + (let ((result (malloc (* 5 (c-sizeof "int"))))) + (if (zero? (C-call "x_window_query_pointer" window result)) + (error "XQueryPointer failed:" window)) + (let ((v (make-vector 5)) + (scan (copy-alien result))) + (vector-set! v 0 (C-> scan "int")) + (alien-byte-increment! scan (C-sizeof "int")) + (vector-set! v 1 (C-> scan "int")) + (alien-byte-increment! scan (C-sizeof "int")) + (vector-set! v 2 (C-> scan "int")) + (alien-byte-increment! scan (C-sizeof "int")) + (vector-set! v 3 (C-> scan "int")) + (alien-byte-increment! scan (C-sizeof "int")) + (vector-set! v 4 (map-key-state (C-> scan "int"))) + (free result) + v))) + +(define map-key-state + (let ((translations (list (cons (C-enum "ControlMask") #x0001) + (cons (C-enum "Mod1Mask") #x0002) + (cons (C-enum "Mod2Mask") #x0004) + (cons (C-enum "Mod3Mask") #x0008) + (cons (C-enum "ShiftMask") #x0010) + (cons (C-enum "LockMask") #x0020) + (cons (C-enum "Mod4Mask") #x0040) + (cons (C-enum "Mod5Mask") #x0080) + (cons (C-enum "Button1Mask") #x0100) + (cons (C-enum "Button2Mask") #x0200) + (cons (C-enum "Button3Mask") #x0400) + (cons (C-enum "Button4Mask") #x0800) + (cons (C-enum "Button5Mask") #x1000)))) + (named-lambda (map-key-state state) + (reduce bitwise-ior 0 + (map (lambda (from.to) + (if (zero? (bitwise-and state (car from.to))) + 0 + (cdr from.to))) + translations))))) + +(define (x-window-id window) + (guarantee-xwindow window 'x-window-id) + (C-call "x_window_id" window)) + +;;; Appearance Control Functions + +(define (x-window-set-foreground-color window color) + (guarantee-xwindow window 'x-window-set-foreground-color) + (cond ((string? color) + (C-call "x_window_set_foreground_color_name" window color)) + ((integer? color) + (C-call "x_window_set_foreground_color_pixel" window color)) + (else + (error:wrong-type-argument color "an X color (string or integer)" + 'x-window-set-border-color)))) + +(define (x-window-set-background-color window color) + (guarantee-xwindow window 'x-window-set-background-color) + (cond ((string? color) + (C-call "x_window_set_background_color_name" window color)) + ((integer? color) + (C-call "x_window_set_background_color_pixel" window color)) + (else + (error:wrong-type-argument color "an X color (string or integer)" + 'x-window-set-background-color)))) + +(define (x-window-set-border-color window color) + (guarantee-xwindow window 'x-window-set-border-color) + (cond ((string? color) + (C-call "x_window_set_border_color_name" window color)) + ((integer? color) + (C-call "x_window_set_border_color_pixel" window color)) + (else + (error:wrong-type-argument color "an X color (string or integer)" + 'x-window-set-border-color)))) + +(define (x-window-set-cursor-color window color) + (guarantee-xwindow window 'x-window-set-cursor-color) + (cond ((string? color) + (C-call "x_window_set_cursor_color_name" window color)) + ((integer? color) + (C-call "x_window_set_cursor_color_pixel" window color)) + (else + (error:wrong-type-argument color "an X color (string or integer)" + 'x-window-set-border-color)))) + +(define (x-window-set-mouse-color window color) + (guarantee-xwindow window 'x-window-set-mouse-color) + (cond ((string? color) + (C-call "x_window_set_mouse_color_name" window color)) + ((integer? color) + (C-call "x_window_set_mouse_color_pixel" window color)) + (else + (error:wrong-type-argument color "an X color (string or integer)" + 'x-window-set-border-color)))) + +(define (x-window-set-mouse-shape window shape) + (guarantee-xwindow window 'x-window-set-mouse-shape) + (if (zero? (C-call "x_window_set_mouse_shape" window shape)) + (error "Bad shape:" shape))) + +(define (x-window-set-font window font) + (guarantee-xwindow window 'x-window-set-font) + (guarantee-string font 'x-window-set-font) + (not (zero? (C-call "x_window_set_font" window font)))) + +(define (x-window-set-border-width window width) + (guarantee-xwindow window 'x-window-set-border-width) + (C-call "x_window_set_border_width" window width)) + +(define (x-window-set-internal-border-width window width) + (guarantee-xwindow window 'x-window-set-internal-border-width) + (C-call "x_window_set_internal_border_width" window width)) + +;;; WM Communication + +(define (x-window-set-input-focus window time) + (guarantee-xwindow window 'x-window-set-input-focus) + (if (not (zero? (c-call "x_window_set_input_focus" window time))) + (error:bad-range-argument window 'x-window-set-input-focus))) + +;;; WM Control + +(define (x-window-map window) + (guarantee-xwindow window 'x-window-map) + (C-call "x_window_map" window)) + +(define (x-window-iconify window) + (guarantee-xwindow window 'x-window-iconify) + (C-call "x_window_iconify" window)) + +(define (x-window-withdraw window) + (guarantee-xwindow window 'x-window-withdraw) + (C-call "x_window_withdraw" window)) + +(define (x-window-set-size window width height) + (guarantee-xwindow window 'x-window-set-size) + (C-call "x_window_set_size" window width height)) + +(define (x-window-raise window) + (guarantee-xwindow window 'x-window-raise) + (C-call "x_window_raise" window)) + +(define (x-window-lower window) + (guarantee-xwindow window 'x-window-lower) + (C-call "x_window_lower" window)) + +(define (x-window-get-size window) + (guarantee-xwindow window 'x-window-get-size) + (let ((dimensions (malloc (* 2 (c-sizeof "int")) 'int))) + (c-call "x_window_get_size" window dimensions) + (let ((width (c-> dimensions "int")) + (height (c-> (c-array-loc dimensions "int" 1) "int"))) + (free dimensions) + (cons width height)))) + +(define (x-window-get-position window) + (guarantee-xwindow window 'x-window-get-position) + (let ((coords (malloc (* 2 (c-sizeof "int")) 'int))) + (c-call "x_window_get_position" window coords) + (let ((x (c-> coords "int")) + (y (c-> (c-array-loc coords "int" 1) "int"))) + (free coords) + (cons x y)))) + +(define (x-window-set-position window x y) + (guarantee-xwindow window 'x-window-set-position) + (C-call "x_window_set_position" window x y)) + +;;; Font Structure + +(define (x-font-structure display name/id) + + (define (font-struct-cleanup! copy) + (if (not (alien-null? copy)) + (begin + (C-call "x_free_font" display copy) + (alien-null! copy)))) + + (guarantee-xdisplay display 'x-font-structure) + (let ((font-struct (make-alien '(struct |XFontStruct|)))) + (cond ((string? name/id) + (add-alien-cleanup! + font-struct + (named-lambda (font-struct-init-by-name! copy) + (C-call "x_font_structure_by_name" copy display name/id)) + font-struct-cleanup!)) + ((integer? name/id) + (add-alien-cleanup! + font-struct + (named-lambda (font-struct-init-by-id! copy) + (C-call "x_font_structure_by_id" copy display name/id)) + font-struct-cleanup!)) + (else + (error:wrong-type-argument name/id "a string or integer" + 'x-font-structure))) + (if (alien-null? font-struct) + (error "Could not load font:" name/id display)) + (let ((vector (copy-x-font-struct name/id font-struct))) + (cleanup-alien! font-struct) + vector))) + +(define (copy-x-font-struct font-name font) + (if (alien-null? font) + #f + ;; Handle only 8-bit fonts because of laziness. + (if (or (not (zero? (C-> font "XFontStruct min_byte1"))) + (not (zero? (C-> font "XFontStruct max_byte1")))) + #f + (let ((result (make-vector 10)) + (per-char (C-> font "XFontStruct per_char"))) + (if (zero? per-char) + (vector-set! result 6 #f) + (let* ((start-index (C-> font "XFontStruct min_char_or_byte2")) + (length (- (C-> font "XFontStruct max_char_or_byte2") + start-index -1)) + (character-vector (make-vector length))) + (let loop ((index 0)) + (if (< index length) + (begin + (vector-set! character-vector index + (copy-x-char-struct + (alien-byte-increment + per-char + (* index (C-sizeof "XCharStruct"))))) + (loop (1+ index))))) + (vector-set! result 6 start-index) + (vector-set! result 7 character-vector))) + (vector-set! result 0 font-name) + (vector-set! result 1 (C-> font "XFontStruct direction")) + (vector-set! result 2 + (not (zero? (C-> font "XFontStruct all_chars_exist")))) + (vector-set! result 3 (C-> font "XFontStruct default_char")) + (vector-set! result 4 (copy-x-char-struct + (alien-byte-increment + font (C-offset "XFontStruct min_bounds")))) + (vector-set! result 5 (copy-x-char-struct + (alien-byte-increment + font (C-offset "XFontStruct max_bounds")))) + (vector-set! result 8 (C-> font "XFontStruct ascent")) + (vector-set! result 9 (C-> font "XFontStruct descent")) + result)))) + +(define (copy-x-char-struct char-struct) + (let ((lbearing (C-> char-struct "XCharStruct lbearing")) + (rbearing (C-> char-struct "XCharStruct rbearing")) + (width (C-> char-struct "XCharStruct width")) + (ascent (C-> char-struct "XCharStruct ascent")) + (descent (C-> char-struct "XCharStruct descent"))) + (if (and (zero? lbearing) (zero? rbearing) + (zero? width) (zero? ascent) (zero? descent)) + #f + (vector lbearing rbearing width ascent descent)))) + +(define (x-free-font display alien) + (declare (ignore display)) + (cleanup-alien! alien)) + +(define (x-list-fonts display pattern limit) + ;; LIMIT is an exact non-negative integer or #F for no limit. + ;; Returns #F or a vector of at least one string. + (guarantee-xdisplay display 'x-list-fonts) + (let ((actual-count-return (malloc "int" 'int))) + + (define (cleanup-names! copy) + (if (not (alien-null? copy)) + (begin + (c-call "XFreeFontNames" copy) + (alien-null! copy)))) + + (define (init-names! copy) + (c-call "x_list_fonts" copy display pattern limit actual-count-return)) + + (let ((names (make-alien '(* char)))) + (add-alien-cleanup! names cleanup-names! init-names!) + (if (alien-null? names) + (begin + (cleanup-alien! names) + (free actual-count-return) + #f) + (let ((actual-count (c-> actual-count-return "int")) + (scan (copy-alien names))) + (let ((result (make-vector actual-count))) + (let loop ((i 0)) + (if (< i actual-count) + (begin + (vector-set! result i (c-peek-cstringp! scan 0)) + (loop (1+ i))))) + (cleanup-alien! names) + (free actual-count-return) + result)))))) + +;;; Atoms + +(define (x-intern-atom display name soft?) + (guarantee-xdisplay display 'x-intern-atom) + (c-call "x_intern_atom" display name soft?)) + +(define (x-get-atom-name display atom) + + (define (cleanup-name-return! copy) + (if (not (alien-null? copy)) + (let ((cstr (c-> copy "* char"))) + (if (not (alien-null? cstr)) + (begin + (c-call "XFree" cstr) + (alien-null! cstr))) + ((ucode-primitive c-free 1) copy) + (alien-null! copy)))) + + (define (init-name-return! copy) + ((ucode-primitive c-malloc 2) copy (c-sizeof "* char"))) + + (guarantee-xdisplay display 'x-get-atom-name) + (let ((name-return (make-alien '(* char)))) + (add-alien-cleanup! name-return cleanup-name-return! init-name-return!) + (let ((code (c-call "x_get_atom_name" display atom name-return))) + (if (zero? code) + (let ((name (c-peek-cstringp name-return))) + (cleanup-alien! name-return) + name) + (error "XGetAtomName failed:" code))))) + +;;; Window Properties + +(define (x-get-window-property display window property long-offset + long-length delete? req-type) + (guarantee-xdisplay display 'x-get-window-property) + (guarantee-xwindow window 'x-get-window-property) + (let ((actual-type-return (malloc (c-sizeof "Atom") '|Atom|)) + (actual-format-return (malloc (c-sizeof "int") 'int)) + (nitems-return (malloc (c-sizeof "ulong") 'ulong)) + (bytes-after-return (malloc (c-sizeof "ulong") 'ulong))) + + (define (cleanup-data-return! copy) + (if (not (alien-null? copy)) + (let ((cstr (c-> copy "* char"))) + (if (not (alien-null? cstr)) + (begin + (c-call "XFree" cstr) + (alien-null! cstr))) + ((ucode-primitive c-free 1) copy) + (alien-null! copy)))) + + (define (init-data-return! copy) + ((ucode-primitive c-malloc 2) copy (c-sizeof "* char"))) + + (let ((data-return (make-alien '(* char)))) + (add-alien-cleanup! data-return cleanup-data-return! init-data-return!) + (let ((code (c-call "x_get_window_property" display window property + long-offset long-length delete? req-type + actual-type-return actual-format-return + nitems-return bytes-after-return data-return))) + (if (not (zero? code)) + (error "XGetWindowProperty failed.")) + (let ((actual-type (c-> actual-type-return "Atom")) + (actual-format (c-> actual-format-return "int"))) + (let ((result + (vector actual-type + actual-format + (c-> bytes-after-return "ulong") + (cond ((and (not (= req-type + (c-enum "AnyPropertyType"))) + (not (= req-type actual-type))) + #f) + ((= 32 actual-format) + (char-ptr-to-prop-data-32 + (c-> data-return "* char") + (c-> nitems-return "ulong"))) + ((= 16 actual-format) + (char-ptr-to-prop-data-16 + (c-> data-return "* char") + (c-> nitems-return "ulong"))) + ((= 8 actual-format) + (c-peek-cstringp data-return)) + (else + (error "Unexpected format:" actual-format)))))) + (cleanup-alien! data-return) + (free actual-type-return) + (free actual-format-return) + (free nitems-return) + (free bytes-after-return) + result)))))) + +(define (char-ptr-to-prop-data-32 data length) + (let ((scan (copy-alien data)) + (result (make-vector length))) + (let loop ((index 0)) + (if (< index length) + (begin + (vector-set! result index (c-> scan "CARD32")) + (alien-byte-increment! scan (c-sizeof "CARD32")) + (loop (1+ index))))) + result)) + +(define (char-ptr-to-prop-data-16 data length) + (let ((scan (copy-alien data)) + (result (make-vector length))) + (let loop ((index 0)) + (if (< index length) + (begin + (vector-set! result index (c-> scan "CARD16")) + (alien-byte-increment! scan (c-sizeof "CARD16")) + (loop (1+ index))))) + result)) + +(define (x-change-property display window property type format mode data) + (guarantee-xdisplay display 'x-change-property) + (guarantee-xwindow window 'x-change-property) + (let* ((bytes.length + (case format + ((8) + (guarantee-string data 'x-change-property) + data) + ((16) + (guarantee-vector data 'x-change-property) + (prop-data-16->bytes.length data)) + ((32) + (guarantee-vector data 'x-change-property) + (prop-data-32->bytes.length data)) + (else + (error:bad-range-argument format 'x-change-property)))) + (code + (c-call "x_change_property" display window property type format mode + (car bytes.length) (cdr bytes.length)))) + (free (car bytes.length)) + (if (not (zero? code)) + (error "XChangeProperty failed:" property)))) + +(define (prop-data-32->bytes.length vector) + (let* ((nitems (vector-length vector)) + (length (* 4 nitems)) + (bytes (malloc length 'uchar)) + (scan (copy-alien bytes))) + (let loop ((index 0)) + (if (< index nitems) + (let ((n (vector-ref vector index))) + (guarantee-integer n 'prop-data-32->bytes.length) + (c->= scan "CARD32" n) + (alien-byte-increment scan (c-sizeof "CARD32")) + (loop (1+ index))))) + (cons bytes length))) + +(define (prop-data-16->bytes.length vector) + (let* ((nitems (vector-length vector)) + (length (* (c-sizeof "CARD16") nitems)) + (bytes (malloc length 'uchar)) + (scan (copy-alien bytes))) + (let loop ((index 0)) + (if (< index nitems) + (let ((n (vector-ref vector index))) + (guarantee-integer n 'prop-data-16->bytes.length) + (if (or (< n 0) (<= 65536 n)) + (error:bad-range-argument vector 'prop-data-16->bytes.length)) + (c->= scan "CARD16" n) + (alien-byte-increment scan (c-sizeof "CARD16")) + (loop (1+ index))))) + (cons bytes length))) + +(define (prop-data-8->bytes.length string) + (let* ((length (string-length string)) + (bytes (malloc length 'uchar))) + (c-poke-bytes bytes 0 length string 0) + (cons bytes length))) + +(define (x-delete-property display window property) + (guarantee-xdisplay display 'x-delete-property) + (guarantee-xwindow window 'x-delete-property) + (c-call "x_delete_property" display window property)) + +;;; Selections + +(define (x-set-selection-owner display selection owner time) + (guarantee-xdisplay display 'x-set-selection-owner) + (c-call "x_set_selection_owner" display selection owner time)) + +(define (x-get-selection-owner display selection) + (guarantee-xdisplay display 'x-get-selection-owner) + (c-call "x_get_selection_owner" display selection)) + +(define (x-convert-selection display selection target property requestor time) + (guarantee-xdisplay display 'x-convert-selection) + (c-call "x_convert_selection" + display selection target property requestor time)) + +(define (x-send-selection-notify display requestor + selection target property time) + (guarantee-xdisplay display 'x-send-selection-notify) + (c-call "x_send_selection_notify" + display requestor selection target property time)) + +;;; Guarantors + +(define-integrable (guarantee-xvisual object operator) + (if (not (and (alien? object) + (equal? '(struct |xvisual|) (alien/ctype object)))) + (error:wrong-type-argument object "an xvisual alien" operator) + object)) + +(define-integrable (guarantee-xdisplay object operator) + (if (not (and (alien? object) + (equal? '(struct |xdisplay|) (alien/ctype object)))) + (error:wrong-type-argument object "an xdisplay alien" operator))) + +(define-integrable (guarantee-xwindow object operator) + (if (not (and (alien? object) + (equal? '(struct |xwindow|) (alien/ctype object)))) + (error:wrong-type-argument object "an xwindow alien" operator))) + +;;;; Cleanups + +;;; This weak list ensures that allocated memory is freed. It +;;; associates an alien with a cleanup procedure. If the alien is +;;; garbage collected, the procedure is applied to a copy of the +;;; alien. The cleanup procedure should apply the correct library +;;; function, e.g. XFree or XFreeFont. When the alien is to be freed, +;;; alien-cleanup! should be used to do the cleanup. + +(define cleanups) +(define cleanups-mutex) + +(define (reset-x11-cleanups!) + (set! cleanups-mutex (make-thread-mutex)) + (set! cleanups '())) + +(define (initialize-package!) + (reset-x11-cleanups!) + (add-gc-daemon! cleanup-x11!) + (add-event-receiver! event:after-restore reset-x11-cleanups!)) + +(define (add-alien-cleanup! alien cleanup! init!) + (let* ((copy (copy-alien alien)) + (entry (weak-cons alien (make-cleanup copy cleanup!)))) + (with-thread-mutex-lock cleanups-mutex + (lambda () + (set! cleanups (cons entry cleanups)))) + (init! copy) + (copy-alien-address! alien copy) + alien)) + +(define (make-cleanup copy cleanup!) + (named-lambda (cleanup-thunk) + (cleanup! copy))) + +(define (cleanup-alien! alien) + (with-thread-mutex-lock cleanups-mutex + (lambda () + (let ((entry (weak-assq alien cleanups))) + (if (not entry) + (warn "Could not cleanup:" alien) + (begin + ((weak-cdr entry)) + (set! cleanups (delq! entry cleanups)))))))) + +(define (cleanup-x11!) + (with-thread-mutex-try-lock cleanups-mutex + (lambda () + (let loop ((entries cleanups) + (prev #f)) + (if (pair? entries) + (let ((entry (car entries)) + (next (cdr entries))) + (if (weak-pair/car? entry) + (loop next entries) + (begin + ((weak-cdr entry)) + (loop next prev))))))) + (lambda () + unspecific))) + +(define (weak-assq obj alist) + (let loop ((alist alist)) + (if (null? alist) #f + (let* ((entry (car alist)) + (key (weak-car entry))) + (if (eq? obj key) entry + (loop (cdr alist))))))) + +(initialize-package!) \ No newline at end of file diff --git a/src/x11/x11color.c b/src/x11/x11color.c new file mode 100644 index 000000000..87065d57f --- /dev/null +++ b/src/x11/x11color.c @@ -0,0 +1,180 @@ +/* -*-C-*- + +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 + 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. + +*/ + +/* Functions for dealing with colors and color maps */ + +#include "x11.h" + +/* Visuals */ + +struct xvisual * +x_window_visual (struct xwindow * xw) +{ + XWindowAttributes a; + if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) + return (NULL); + return (allocate_x_visual (a . visual)); +} + +void +x_get_visual_info (struct xdisplay * xd, + long mask, + XVisualInfo * info, + XVisualInfo * * items_return, + int * nitems_return) +{ + Display * dpy = (XD_DISPLAY(xd)); + *items_return = XGetVisualInfo(dpy, mask, info, nitems_return); +} + +/* Colormaps */ + +struct xcolormap * +x_window_colormap (struct xwindow * xw) +{ + XWindowAttributes a; + if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) + return (NULL); + return (allocate_x_colormap ((a . colormap), (XW_XD (xw)))); +} + +void +x_set_window_colormap (struct xwindow * xw, struct xcolormap * xcm) +{ + XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), + (XCM_COLORMAP (xcm))); +} + +struct xcolormap * +x_create_colormap (struct xwindow * xw, struct xvisual * visual, + int writable_p) +{ + return (allocate_x_colormap + ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), + (XV_VISUAL (visual)), writable_p)), + (XW_XD (xw)))); +} + +void +x_free_colormap (struct xcolormap * xcm) +{ + XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm))); + deallocate_x_colormap (xcm); +} + +long +x_allocate_color (struct xcolormap * xcm, + unsigned int red, unsigned int green, unsigned int blue) +{ + XColor c; + if ((red >= 65536) + || (green >= 65536) + || (blue >= 65536)) + return (-1); + (c . red) = red; + (c . green) = green; + (c . blue) = blue; + return ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c))) + ? (c . pixel) + : -1); +} + +void +x_store_color (struct xcolormap * xcm, + int pixel, int red, int green, int blue) +{ + XColor c; + (c . pixel) = pixel; + (c . flags) = 0; + if (red != -1) + { + (c . red) = red; + (c . flags) |= DoRed; + } + if (green != -1) + { + (c . green) = green; + (c . flags) |= DoGreen; + } + if (blue != -1) + { + (c . blue) = blue; + (c . flags) |= DoBlue; + } + XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)); +} + +void +x_store_colors (struct xcolormap * xcm, + unsigned int * color_vector, + unsigned int n_colors) +{ + XColor * colors = malloc (n_colors * (sizeof (XColor))); + unsigned int * vector_scan = color_vector; + XColor * colors_scan = colors; + XColor * colors_end = (colors + n_colors); + while (colors_scan < colors_end) + { + (colors_scan -> pixel) = (*vector_scan++); + (colors_scan -> flags) = 0; + { + int red = *vector_scan++; + int green = *vector_scan++; + int blue = *vector_scan++; + if (red != -1) + { + (colors_scan -> red) = red; + (colors_scan -> flags) |= DoRed; + } + if (green != -1) + { + (colors_scan -> green) = green; + (colors_scan -> flags) |= DoGreen; + } + if (blue != -1) + { + (colors_scan -> blue) = blue; + (colors_scan -> flags) |= DoBlue; + } + colors_scan += 1; + } + } + XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors); + free (colors); +} + +void +x_query_color (struct xcolormap * xcm, + unsigned long pixel, + unsigned int * results) +{ + XColor c; + c . pixel = pixel; + XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)); + results[0] = (c . red); + results[1] = (c . green); + results[2] = (c . blue); +} diff --git a/src/x11/x11color.scm b/src/x11/x11color.scm new file mode 100644 index 000000000..522724828 --- /dev/null +++ b/src/x11/x11color.scm @@ -0,0 +1,189 @@ +#| -*-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 + 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. + +|# + +;;;; X11 interface +;;; package: (x11) +;;; +;;; These were once primitives created by x11color.c in umodule prx11. + +(C-include "x11") + +;;; Visuals + +(define (x-window-visual window) + (let ((alien (C-call "x_window_visual" (make-alien '(struct |xvisual|)) + window))) + (if (alien-null? alien) + (error "XGetWindowAttributes failed.") + alien))) + +(define (x-get-visual-info window/display visual-id screen-number depth class + red-mask green-mask blue-mask colormap-size + bits-per-rgb) + ;; Returns a vector of vectors, each of which has the following format: + ;; Visual (Scheme format, for use in later calls) + ;; Visual-ID + ;; Screen number + ;; Depth + ;; Class + ;; Red-mask (integer) + ;; Green-mask (integer) + ;; Blue-mask (integer) + ;; Colormap size + ;; Bits per RGB + (let ((display (if (not screen-number) + (C-call "x_window_display" window/display) + window/display)) + (screen-number (if (not screen-number) + (C-call "x_window_screen_number" window/display) + screen-number)) + (mask (C-enum "VisualNoMask")) + (info (malloc (C-sizeof "XVisualInfo") '|XVisualInfo|)) + (items-return (make-alien '(* |XVisualInfo|))) + (nitems-return (malloc (C-sizeof "int") 'int))) + (C->= info "XVisualInfo screen" screen-number) + (if visual-id (begin (set! mask (+ mask (C-enum "VisualIDMask"))) + (C->= info "XVisualInfo visualid" visual-id))) + (if depth (begin (set! mask (+ mask (C-enum "VisualDepthMask"))) + (C->= info "XVisualInfo depth" depth))) + (if class (begin (set! mask (+ mask (C-enum "VisualClassMask"))) + (C->= info "XVisualInfo class" class))) + (if red-mask (begin (set! mask (+ mask (C-enum "VisualRedMaskMask"))) + (C->= info "XVisualInfo red_mask" red-mask))) + (if green-mask (begin (set! mask (+ mask (C-enum "VisualGreenMaskMask"))) + (C->= info "XVisualInfo green_mask" green-mask))) + (if blue-mask (begin (set! mask (+ mask (C-enum "VisualBlueMaskMask"))) + (C->= info "XVisualInfo blue_mask" blue-mask))) + (if colormap-size + (begin (set! mask (+ mask (C-enum "VisualColormapSizeMask"))) + (C->= info "XVisualInfo colormap_size" colormap-size))) + (if bits-per-rgb + (begin (set! mask (+ mask (C-enum "VisualBitsPerRGBMask"))) + (C->= info "XVisualInfo bits_per_rgb" bits-per-rgb))) + (add-alien-cleanup! items-return cleanup-visual-infos! init-visual-infos!) + (C-call "x_get_visual_info" display mask info items-return nitems-return) + (free info) + (let ((nitems (C-> nitems-return "int")) + (items (C-> items-return "*" (make-alien '|XVisualInfo|)))) + (free nitems-return) + (let loop ((i 0) (infos '())) + (if (< i nitems) + (let ((info (vector (C-call "allocate_x_visual" + (make-alien '(struct |xvisual|)) + (C-> items "XVisualInfo visual")) + (C-> items "XVisualInfo visualid") + (C-> items "XVisualInfo screen") + (C-> items "XVisualInfo depth") + (C-> items "XVisualInfo class") + (C-> items "XVisualInfo red_mask") + (C-> items "XVisualInfo green_mask") + (C-> items "XVisualInfo blue_mask") + (C-> items "XVisualInfo colormap_size") + (C-> items "XVisualInfo bits_per_rgb")))) + (alien-byte-increment! items (C-sizeof "XVisualInfo")) + (loop (1+ i) (cons info infos))) + (begin + (cleanup-alien! items-return) + (list->vector (reverse! infos)))))))) + +(define (init-visual-infos! copy) + ((ucode-primitive c-malloc 2) copy (C-sizeof "* XVisualInfo"))) + +(define (cleanup-visual-infos! copy) + (if (not (alien-null? copy)) + (let ((items (C-> copy "* XVisualInfo"))) + (if (not (alien-null? items)) + (C-call "XFree" items)) + ((ucode-primitive c-free 1) copy) + (alien-null! copy)))) + +;;; Colormap + +(define (x-window-colormap window) + (C-call "x_window_colormap" (make-alien '(struct |xcolormap|)) window)) + +(define (x-set-window-colormap window colormap) + (C-call "x_set_window_colormap" window colormap)) + +(define (x-create-colormap window visual writable?) + (C-call "x_create_colormap" (make-alien '(struct |xcolormap|)) + window visual (if writable? 1 0))) + +(define (x-free-colormap colormap) + (C-call "x_free_colormap" colormap) + (alien-null! colormap)) + +(define (x-allocate-color colormap red green blue) + (let ((pixel (C-call "x_allocate_color" colormap red green blue))) + (if (= -1 pixel) + (error "Could to allocate color:" colormap)) + pixel)) + +(define (x-store-color colormap pixel red green blue) + (let ((r (or red -1)) + (g (or green -1)) + (b (or blue -1))) + (if (or (< r -1) (< 65536 r)) + (error:bad-range-argument r 'x-store-color)) + (if (or (< r -1) (< 65536 g)) + (error:bad-range-argument g 'x-store-color)) + (if (or (< r -1) (< 65536 b)) + (error:bad-range-argument b 'x-store-color)) + (C-call "x_store_color" colormap pixel r g b))) + +(define (x-store-colors colormap array) + ;; Input: colormap, vector of vectors, each of + ;; which contains pixel, r, g, b (where r/g/b can be #f or integer). + (let* ((length (vector-length array)) + (ints (malloc (* (* 4 length) (C-sizeof "int")) 'int)) + (scan (copy-alien ints))) + (let loop ((i 0)) + (if (< i length) + (let ((prgb (vector-ref array i))) + (C->= scan "int" (vector-ref prgb 0)) + (alien-byte-increment! scan (C-sizeof "int")) + (C->= scan "int" (vector-ref prgb 1)) + (alien-byte-increment! scan (C-sizeof "int")) + (C->= scan "int" (vector-ref prgb 2)) + (alien-byte-increment! scan (C-sizeof "int")) + (C->= scan "int" (vector-ref prgb 3)) + (alien-byte-increment! scan (C-sizeof "int")) + (loop (1+ i))))) + (C-call "x_store_colors" colormap ints length) + (free ints))) + +(define (x-query-color colormap pixel) + (let ((vec (make-vector 3)) + (rgb (malloc (* 3 (C-sizeof "long"))))) + (C-call "x_query_color" colormap pixel rgb) + (let ((scan (copy-alien rgb))) + (vector-set! vec 0 (C-> scan "long")) + (alien-byte-increment! (C-sizeof "long")) + (vector-set! vec 1 (C-> scan "long")) + (alien-byte-increment! (C-sizeof "long")) + (vector-set! vec 2 (C-> scan "long"))) + (free rgb) + vec)) \ No newline at end of file diff --git a/src/x11/x11device.scm b/src/x11/x11device.scm new file mode 100644 index 000000000..33baa03b7 --- /dev/null +++ b/src/x11/x11device.scm @@ -0,0 +1,944 @@ +#| -*-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 + 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. + +|# + +;;;; X11 Graphics Interface +;;; package: (x11 graphics) + +(declare (usual-integrations)) + +(define event-mask:normal + (apply + + + (map (lambda (nth) (shift-left 1 nth)) + (list event-type:button-down event-type:button-up event-type:configure + event-type:enter event-type:focus-in event-type:focus-out + event-type:key-press event-type:leave event-type:motion + event-type:delete-window event-type:map event-type:unmap + event-type:visibility)))) + +(define event-mask:ignore-focus + (+ event-mask:normal (shift-left 1 event-type:take-focus))) + +(define user-event-mask:default (shift-left 1 event-type:button-down)) + +;;;; X11 graphics device + +(define (initialize-package!) + (set! x-graphics-device-type + (make-graphics-device-type + 'X11 + `((available? ,x-graphics/available?) + (clear ,x-graphics/clear) + (close ,x-graphics/close-window) + (color? ,x-graphics/color?) + (coordinate-limits ,x-graphics/coordinate-limits) + (copy-area ,x-graphics/copy-area) + (create-colormap ,create-x-colormap) + (create-image ,x-graphics/create-image) + (device-coordinate-limits ,x-graphics/device-coordinate-limits) + (drag-cursor ,x-graphics/drag-cursor) + (draw-arc ,x-graphics/draw-arc) + (draw-circle ,x-graphics/draw-circle) + (draw-image ,image/draw) + (draw-line ,x-graphics/draw-line) + (draw-lines ,x-graphics/draw-lines) + (draw-point ,x-graphics/draw-point) + (draw-points ,x-graphics/draw-points) + (draw-subimage ,image/draw-subimage) + (draw-text ,x-graphics/draw-text) + (draw-text-opaque ,x-graphics/draw-text-opaque) + (fill-circle ,x-graphics/fill-circle) + (fill-polygon ,x-graphics/fill-polygon) + (flush ,x-graphics/flush) + (font-structure ,x-graphics/font-structure) + (get-colormap ,x-graphics/get-colormap) + (get-default ,x-graphics/get-default) + (iconify-window ,x-graphics/iconify-window) + (image-depth ,x-graphics/image-depth) + (lower-window ,x-graphics/lower-window) + (map-window ,x-graphics/map-window) + (move-cursor ,x-graphics/move-cursor) + (move-window ,x-graphics/move-window) + (open ,x-graphics/open) + (open? ,x-graphics/open-window?) + (query-pointer ,x-graphics/query-pointer) + (raise-window ,x-graphics/raise-window) + (reset-clip-rectangle ,x-graphics/reset-clip-rectangle) + (resize-window ,x-graphics/resize-window) + (set-background-color ,x-graphics/set-background-color) + (set-border-color ,x-graphics/set-border-color) + (set-border-width ,x-graphics/set-border-width) + (set-clip-rectangle ,x-graphics/set-clip-rectangle) + (set-colormap ,x-graphics/set-colormap) + (set-coordinate-limits ,x-graphics/set-coordinate-limits) + (set-drawing-mode ,x-graphics/set-drawing-mode) + (set-font ,x-graphics/set-font) + (set-foreground-color ,x-graphics/set-foreground-color) + (set-icon-name ,x-graphics/set-icon-name) + (set-input-hint ,x-graphics/set-input-hint) + (set-internal-border-width ,x-graphics/set-internal-border-width) + (set-line-style ,x-graphics/set-line-style) + (set-mouse-color ,x-graphics/set-mouse-color) + (set-mouse-shape ,x-graphics/set-mouse-shape) + (set-window-name ,x-graphics/set-window-name) + (starbase-filename ,x-graphics/starbase-filename) + (visual-info ,x-graphics/visual-info) + (withdraw-window ,x-graphics/withdraw-window)))) + (set! display-finalizer + (make-gc-finalizer x-close-display + x-display? + x-display/xd + set-x-display/xd!)) + (initialize-image-datatype) + (initialize-colormap-datatype)) + +(define (x-graphics/available?) + (ignore-errors (lambda () (load-option 'x11)) + (lambda (condition) condition #f))) + +(define x-graphics-device-type) + +;;;; Open/Close Displays + +(define display-finalizer) + +(define-structure (x-display + (conc-name x-display/) + (constructor make-x-display (name xd)) + (print-procedure + (simple-unparser-method 'X-DISPLAY + (lambda (display) + (list (x-display/name display)))))) + (name #f read-only #t) + xd + (window-finalizer (make-gc-finalizer x-close-window + x-window? + x-window/xw + set-x-window/xw!) + read-only #t) + (previewer-registration #f) + (event-queue (make-queue)) + (properties (make-1d-table) read-only #t)) + +(define (x-graphics/open-display name) + (let ((name + (cond ((not name) + (or x-graphics-default-display-name + (let ((name (get-environment-variable "DISPLAY"))) + (if (not name) + (error "No DISPLAY environment variable.")) + name))) + ((string? name) + name) + (else + (error:wrong-type-argument name + "string or #f" + x-graphics/open-display))))) + (or (search-gc-finalizer display-finalizer + (lambda (display) + (string=? (x-display/name display) name))) + (let ((xd (x-open-display name))) + (if (not xd) + (error "Unable to open display:" name)) + (let ((display (make-x-display name xd))) + (add-to-gc-finalizer! display-finalizer display) + (register-event-previewer! display) + display))))) + +(define (x-graphics/close-display display) + (without-interruption + (lambda () + (if (x-display/xd display) + (begin + (remove-all-from-gc-finalizer! (x-display/window-finalizer display)) + (let ((registration (x-display/previewer-registration display))) + (if registration + (begin + (deregister-io-thread-event registration) + (set-x-display/previewer-registration! display #f)))) + (remove-from-gc-finalizer! display-finalizer display)))))) + +(define (x-graphics/open-display? display) + (if (x-display/xd display) #t #f)) + +(define (register-event-previewer! display) + (let ((registration)) + (set! registration + (permanently-register-io-thread-event + (x-display-descriptor (x-display/xd display)) + 'READ + (current-thread) + (lambda (mode) + mode + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler + (list condition-type:bad-range-argument + condition-type:wrong-type-argument) + (lambda (condition) + ;; If X-DISPLAY-PROCESS-EVENTS or + ;; X-DISPLAY-DESCRIPTOR signals an argument error + ;; on its display argument, that means the + ;; display has been closed. + condition + (deregister-io-thread-event registration) + (continuation unspecific)) + (lambda () + (let loop () + (let ((event + (x-display-process-events (x-display/xd display) + 2))) + (if event + (begin (process-event display event) + (loop)))))))))))) + (set-x-display/previewer-registration! display registration))) + +(define (read-event display) + (letrec ((loop + (let ((queue (x-display/event-queue display))) + (lambda () + (if (queue-empty? queue) + (begin + (%read-and-process-event display) + (loop)) + (dequeue! queue)))))) + (with-thread-events-blocked loop))) + +(define (%read-and-process-event display) + (let ((event + (or (x-display-process-events (x-display/xd display) 2) + (and (eq? 'READ + (test-for-io-on-descriptor + (x-display-descriptor (x-display/xd display)) + #t + 'READ)) + (x-display-process-events (x-display/xd display) 1))))) + (if event + (process-event display event)))) + +(define (discard-events display) + (letrec ((loop + (let ((queue (x-display/event-queue display))) + (lambda () + (cond ((not (queue-empty? queue)) + (dequeue! queue) + (loop)) + ((x-display-process-events (x-display/xd display) 2) + => + (lambda (event) + (process-event display event) + (loop)))))))) + (with-thread-events-blocked loop))) + +(define (process-event display event) + (without-interruption + (lambda () + (let ((window + (search-gc-finalizer (x-display/window-finalizer display) + (let ((xw (vector-ref event 1))) + (lambda (window) + (alien=? (x-window/xw window) xw)))))) + (if window + (let ((type (vector-ref event 0))) + (let ((handler (vector-ref event-handlers type))) + (if handler + (handler window event))) + (if (or (fix:= event-type:delete-window type) + (not (fix:= 0 + (fix:and (fix:lsh 1 type) + (x-window/user-event-mask window))))) + (begin + ;; This would prefer to be the graphics device, but + ;; that's not available from here. + (vector-set! event 1 window) + (enqueue!/unsafe (x-display/event-queue display) + event))))))))) + +(define event-handlers + (make-vector number-of-event-types #f)) + +(define-integrable (define-event-handler event-type handler) + (vector-set! event-handlers event-type handler)) + +(define-event-handler event-type:configure + (lambda (window event) + (x-graphics-reconfigure (vector-ref event 1) + (vector-ref event 2) + (vector-ref event 3)) + (if (eq? 'NEVER (x-window/mapped? window)) + (set-x-window/mapped?! window #t)))) + +(define-event-handler event-type:delete-window + (lambda (window event) + event + (close-x-window window))) + +(define-event-handler event-type:map + (lambda (window event) + event + (set-x-window/mapped?! window #t))) + +(define-event-handler event-type:unmap + (lambda (window event) + event + (set-x-window/mapped?! window #f))) + +(define-event-handler event-type:visibility + (lambda (window event) + (case (vector-ref event 2) + ((0) (set-x-window/visibility! window 'UNOBSCURED)) + ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED)) + ((2) (set-x-window/visibility! window 'OBSCURED))))) + +(let ((mouse-event-handler + (lambda (window event) + window + (let ((xw (vector-ref event 1))) + (vector-set! event 2 + (x-graphics-map-x-coordinate xw + (vector-ref event 2))) + (vector-set! event 3 + (x-graphics-map-y-coordinate xw + (vector-ref event 3))))))) + ;; ENTER and LEAVE events should be modified to have X,Y coordinates. + (define-event-handler event-type:button-down mouse-event-handler) + (define-event-handler event-type:button-up mouse-event-handler) + (define-event-handler event-type:motion mouse-event-handler)) + +;;;; Standard Operations + +(define x-graphics:auto-raise? #f) + +(define-structure (x-window (conc-name x-window/) + (constructor make-x-window (xw display))) + xw + (display #f read-only #t) + (mapped? 'NEVER) + (visibility #f) + (user-event-mask user-event-mask:default)) + +(define-integrable (x-graphics-device/xw device) + (x-window/xw (graphics-device/descriptor device))) + +(define (x-graphics/display device) + (x-window/display (graphics-device/descriptor device))) + +(define-integrable (x-graphics-device/xd device) + (x-display/xd (x-window/display (graphics-device/descriptor device)))) + +(define-integrable (x-graphics-device/mapped? device) + (eq? #t (x-window/mapped? (graphics-device/descriptor device)))) + +(define-integrable (x-graphics-device/visibility device) + (x-window/visibility (graphics-device/descriptor device))) + +(define (x-graphics/open-window? device) + (if (x-graphics-device/xw device) #t #f)) + +(define (x-graphics/close-window device) + (without-interruption + (lambda () + (close-x-window (graphics-device/descriptor device))))) + +(define (close-x-window window) + (remove-from-gc-finalizer! + (x-display/window-finalizer (x-window/display window)) + window)) + +(define (x-geometry-string x y width height) + (string-append (if (and width height) + (string-append (number->string width) + "x" + (number->string height)) + "") + (if (and x y) + (string-append (if (negative? x) "" "+") + (number->string x) + (if (negative? y) "" "+") + (number->string y)) + ""))) + +(define x-graphics-default-geometry "512x512") +(define x-graphics-default-display-name #f) + +(define (x-graphics/open descriptor->device + #!optional display geometry suppress-map?) + (let ((display + (let ((display + (and (not (default-object? display)) + display))) + (if (x-display? display) + display + (x-graphics/open-display display))))) + (call-with-values + (lambda () + (decode-suppress-map-arg (and (not (default-object? suppress-map?)) + suppress-map?) + 'MAKE-GRAPHICS-DEVICE)) + (lambda (map? resource class) + (let ((xw + (x-graphics-open-window + (x-display/xd display) + (if (default-object? geometry) + x-graphics-default-geometry + geometry) + (vector #f resource class)))) + (x-window-set-event-mask xw event-mask:normal) + (let ((window (make-x-window xw display))) + (add-to-gc-finalizer! (x-display/window-finalizer display) window) + (if map? (map-window window)) + (descriptor->device window))))))) + +(define (map-window window) + (let ((xw (x-window/xw window))) + (x-window-map xw) + ;; If this is the first time that this window has been mapped, we + ;; need to wait for a MAP event before continuing. + (if (not (boolean? (x-window/mapped? window))) + (begin + (x-window-flush xw) + (letrec ((loop + (let ((display (x-window/display window))) + (lambda () + (if (not (eq? #t (x-window/mapped? window))) + (begin + (%read-and-process-event display) + (loop))))))) + (with-thread-events-blocked loop)))))) + +(define (decode-suppress-map-arg suppress-map? procedure) + (cond ((boolean? suppress-map?) + (values (not suppress-map?) "schemeGraphics" "SchemeGraphics")) + ((and (pair? suppress-map?) + (string? (car suppress-map?)) + (string? (cdr suppress-map?))) + (values #f (car suppress-map?) (cdr suppress-map?))) + ((and (vector? suppress-map?) + (fix:= (vector-length suppress-map?) 3) + (boolean? (vector-ref suppress-map? 0)) + (string? (vector-ref suppress-map? 1)) + (string? (vector-ref suppress-map? 2))) + (values (vector-ref suppress-map? 0) + (vector-ref suppress-map? 1) + (vector-ref suppress-map? 2))) + (else + (error:wrong-type-argument suppress-map? + "X suppress-map arg" + procedure)))) + +(define (x-graphics/clear device) + (x-window-clear (x-graphics-device/xw device))) + +(define (x-graphics/coordinate-limits device) + (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device)))) + (values (vector-ref limits 0) (vector-ref limits 1) + (vector-ref limits 2) (vector-ref limits 3)))) + +(define (x-graphics/device-coordinate-limits device) + (let ((xw (x-graphics-device/xw device))) + (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0))) + +(define (x-graphics/drag-cursor device x y) + (x-graphics-drag-cursor (x-graphics-device/xw device) + (->flonum x) + (->flonum y))) + +(define (x-graphics/draw-line device x-start y-start x-end y-end) + (x-graphics-draw-line (x-graphics-device/xw device) + (->flonum x-start) + (->flonum y-start) + (->flonum x-end) + (->flonum y-end))) + +(define (x-graphics/draw-lines device xv yv) + (x-graphics-draw-lines (x-graphics-device/xw device) xv yv)) + +(define (x-graphics/draw-point device x y) + (x-graphics-draw-point (x-graphics-device/xw device) + (->flonum x) + (->flonum y))) + +(define (x-graphics/draw-points device xv yv) + (x-graphics-draw-points (x-graphics-device/xw device) xv yv)) + +(define (x-graphics/draw-text device x y string) + (x-graphics-draw-string (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + string)) + +(define (x-graphics/draw-text-opaque device x y string) + (x-graphics-draw-image-string (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + string)) + +(define (x-graphics/flush device) + (if (and x-graphics:auto-raise? + (x-graphics-device/mapped? device) + (not (eq? 'UNOBSCURED (x-graphics-device/visibility device)))) + (x-graphics/raise-window device)) + (x-display-flush (x-graphics-device/xd device))) + +(define (x-graphics/move-cursor device x y) + (x-graphics-move-cursor (x-graphics-device/xw device) + (->flonum x) + (->flonum y))) + +(define (x-graphics/reset-clip-rectangle device) + (x-graphics-reset-clip-rectangle (x-graphics-device/xw device))) + +(define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top) + (x-graphics-set-clip-rectangle (x-graphics-device/xw device) + (->flonum x-left) + (->flonum y-bottom) + (->flonum x-right) + (->flonum y-top))) + +(define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top) + (x-graphics-set-vdc-extent (x-graphics-device/xw device) + (->flonum x-left) + (->flonum y-bottom) + (->flonum x-right) + (->flonum y-top))) + +(define (x-graphics/set-drawing-mode device mode) + (x-graphics-set-function (x-graphics-device/xw device) mode)) + +(define (x-graphics/set-line-style device line-style) + (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8))) + (error:wrong-type-argument line-style "graphics line style" + 'SET-LINE-STYLE)) + (let ((xw (x-graphics-device/xw device))) + (if (zero? line-style) + (x-graphics-set-line-style xw 0) + (begin + (x-graphics-set-line-style xw 2) + (x-graphics-set-dashes xw + 0 + (vector-ref '#("\010\010" + "\001\001" + "\015\001\001\001" + "\013\001\001\001\001\001" + "\013\005" + "\014\001\002\001" + "\011\001\002\001\002\001") + (- line-style 1))))))) + +;;;; Appearance Operations + +(define (x-graphics/set-background-color device color) + (x-window-set-background-color (x-graphics-device/xw device) color)) + +(define (x-graphics/set-border-color device color) + (x-window-set-border-color (x-graphics-device/xw device) color)) + +(define (x-graphics/set-border-width device width) + (x-window-set-border-width (x-graphics-device/xw device) width)) + +(define (x-graphics/set-font device font) + (x-window-set-font (x-graphics-device/xw device) font)) + +(define (x-graphics/set-foreground-color device color) + (x-window-set-foreground-color (x-graphics-device/xw device) color)) + +(define (x-graphics/set-internal-border-width device width) + (x-window-set-internal-border-width (x-graphics-device/xw device) width)) + +(define (x-graphics/set-mouse-color device color) + (x-window-set-mouse-color (x-graphics-device/xw device) color)) + +(define (x-graphics/set-mouse-shape device shape) + (x-window-set-mouse-shape (x-graphics-device/xw device) shape)) + +;;;; Miscellaneous Operations + +(define (x-graphics/draw-arc device x y radius-x radius-y + angle-start angle-sweep fill?) + (x-graphics-draw-arc (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + (->flonum radius-x) + (->flonum radius-y) + (->flonum angle-start) + (->flonum angle-sweep) + fill?)) + +(define (x-graphics/draw-circle device x y radius) + (x-graphics-draw-arc (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + (->flonum radius) + (->flonum radius) + 0. + 360. + #f)) + +(define (x-graphics/fill-circle device x y radius) + (x-graphics-draw-arc (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + (->flonum radius) + (->flonum radius) + 0. + 360. + #t)) + +(define (x-graphics/fill-polygon device point-vector) + (x-graphics-fill-polygon (x-graphics-device/xw device) + (vector-map ->flonum point-vector))) + +(define (x-graphics/copy-area device source-x-left source-y-top width height + destination-x-left destination-y-top) + (let ((xw (x-graphics-device/xw device))) + (x-graphics-copy-area xw xw + (->flonum source-x-left) + (->flonum source-y-top) + (->flonum width) + (->flonum height) + (->flonum destination-x-left) + (->flonum destination-y-top)))) + +(define (x-graphics/get-default device resource-name class-name) + (x-display-get-default (x-graphics-device/xd device) + resource-name class-name)) + +(define (x-graphics/starbase-filename device) + (x-window-starbase-filename (x-graphics-device/xw device))) + +(define (x-window-starbase-filename window) + window + (error "Unimplemented.")) + +(define (x-graphics/window-id device) + (x-window-id (x-graphics-device/xw device))) + +;;;; Event-Handling Operations + +(define (x-graphics/set-input-hint device input?) + (x-window-set-input-hint (x-graphics-device/xw device) input?)) + +(define (x-graphics/disable-keyboard-focus device) + ;; Tell the window to participate in the TAKE-FOCUS protocol. Since + ;; there is no handler for this event, focus will never be given to + ;; the window. + (x-window-set-event-mask (x-graphics-device/xw device) + event-mask:ignore-focus)) + +(define (x-graphics/enable-keyboard-focus device) + (x-window-set-event-mask (x-graphics-device/xw device) event-mask:normal)) + +(define (x-graphics/select-user-events device mask) + (set-x-window/user-event-mask! (graphics-device/descriptor device) mask)) + +(define (x-graphics/query-pointer device) + (let* ((window (x-graphics-device/xw device)) + (result (x-window-query-pointer window))) + (values (x-graphics-map-x-coordinate window (vector-ref result 2)) + (x-graphics-map-y-coordinate window (vector-ref result 3)) + (vector-ref result 4)))) + +(define (x-graphics/read-button device) + (let ((event (read-event-of-type device event-type:button-down))) + (values (vector-ref event 2) + (vector-ref event 3) + (vector-ref event 4)))) + +(define (read-event-of-type device event-type) + (let ((window (graphics-device/descriptor device)) + (display (x-graphics/display device))) + (let loop () + (let ((event (read-event display))) + (if (eq? window (vector-ref event 1)) + (begin + (if (fix:= (vector-ref event 0) event-type:delete-window) + (error "Window closed while waiting to read event.")) + (if (fix:= (vector-ref event 0) event-type) + event + (loop))) + (loop)))))) + +(define (x-graphics/read-user-event device) + (read-event (x-graphics/display device))) + +(define (x-graphics/discard-events device) + (discard-events (x-graphics/display device))) + +;;;; Font Operations + +(define (x-graphics/font-structure device string) + (x-font-structure (x-graphics-device/xd device) string)) + +(define-structure (x-font-structure (conc-name x-font-structure/) + (type vector)) + (name #f read-only #t) + (direction #f read-only #t) + (all-chars-exist? #f read-only #t) + (default-char #f read-only #t) + (min-bounds #f read-only #t) + (max-bounds #f read-only #t) + (start-index #f read-only #t) + (character-bounds #f read-only #t) + (max-ascent #f read-only #t) + (max-descent #f read-only #t)) + +(define-structure (x-character-bounds (conc-name x-character-bounds/) + (type vector)) + (lbearing #f read-only #t) + (rbearing #f read-only #t) + (width #f read-only #t) + (ascent #f read-only #t) + (descent #f read-only #t)) + +;;;; Window Management Operations + +(define (x-graphics/map-window device) + (map-window (graphics-device/descriptor device))) + +(define (x-graphics/withdraw-window device) + (x-window-withdraw (x-graphics-device/xw device))) + +(define (x-graphics/iconify-window device) + (x-window-iconify (x-graphics-device/xw device))) + +(define (x-graphics/raise-window device) + (x-window-raise (x-graphics-device/xw device))) + +(define (x-graphics/lower-window device) + (x-window-lower (x-graphics-device/xw device))) + +(define (x-graphics/set-icon-name device name) + (x-window-set-icon-name (x-graphics-device/xw device) name)) + +(define (x-graphics/set-window-name device name) + (x-window-set-name (x-graphics-device/xw device) name)) + +(define (x-graphics/move-window device x y) + (x-window-set-position (x-graphics-device/xw device) x y)) + +(define (x-graphics/resize-window device width height) + (x-window-set-size (x-graphics-device/xw device) width height)) + +;;;; Images + +;; X-IMAGE is the descriptor of the generic images. + +(define-structure (x-image (conc-name x-image/)) + descriptor + window + width + height) + +(define image-list) + +(define (initialize-image-datatype) + (1d-table/put! + (graphics-type-properties x-graphics-device-type) + 'IMAGE-TYPE + (make-image-type + `((create ,create-x-image) + (destroy ,x-graphics-image/destroy) + (width ,x-graphics-image/width) + (height ,x-graphics-image/height) + (draw ,x-graphics-image/draw) + (draw-subimage ,x-graphics-image/draw-subimage) + (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector)))) + (set! image-list + (make-gc-finalizer x-destroy-image + x-image? + x-image/descriptor + set-x-image/descriptor!)) + unspecific) + +(define (create-x-image device width height) + (let ((window (x-graphics-device/xw device))) + (add-to-gc-finalizer! image-list + (make-x-image (x-create-image window width height) + window width height)))) + +(define (x-image/destroy image) + (remove-from-gc-finalizer! image-list image)) + +(define (x-image/get-pixel image x y) + (x-get-pixel-from-image (x-image/descriptor image) x y)) + +(define (x-image/set-pixel image x y value) + (x-set-pixel-in-image (x-image/descriptor image) x y value)) + +(define (x-image/draw image window-x window-y) + (x-display-image (x-image/descriptor image) + 0 + 0 + (x-image/window image) + (->flonum window-x) + (->flonum window-y) + (x-image/width image) + (x-image/height image))) + +(define (x-image/draw-subimage image x y width height window-x window-y) + (x-display-image (x-image/descriptor image) + x + y + (x-image/window image) + (->flonum window-x) + (->flonum window-y) + width + height)) + +(define (x-image/fill-from-byte-vector image byte-vector) + (x-bytes-into-image byte-vector (x-image/descriptor image))) + +;; Abstraction layer for generic images + +(define (x-graphics/create-image device width height) + (image/create device width height)) + +;;(define x-graphics-image/create create-x-image) + +(define (x-graphics-image/destroy image) + (x-image/destroy (image/descriptor image))) + +(define (x-graphics-image/width image) + (x-image/width (image/descriptor image))) + +(define (x-graphics-image/height image) + (x-image/height (image/descriptor image))) + +(define (x-graphics-image/draw device x y image) + (let* ((x-image (image/descriptor image)) + (w (x-image/width x-image)) + (h (x-image/height x-image))) + (x-display-image (x-image/descriptor x-image) + 0 + 0 + (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + w + h))) + +(define (x-graphics-image/draw-subimage device x y image im-x im-y w h) + (let ((x-image (image/descriptor image))) + (x-display-image (x-image/descriptor x-image) + im-x + im-y + (x-graphics-device/xw device) + (->flonum x) + (->flonum y) + w + h))) + +(define (x-graphics-image/fill-from-byte-vector image byte-vector) + (x-image/fill-from-byte-vector (image/descriptor image) byte-vector)) + +;;;; Colormaps + +(define-record-type + (%make-colormap descriptor) + x-colormap? + (descriptor colormap/descriptor set-colormap/descriptor!)) + +(define colormap-list) + +(define (initialize-colormap-datatype) + (set! colormap-list + (make-gc-finalizer x-free-colormap + x-colormap? + colormap/descriptor + set-colormap/descriptor!)) + unspecific) + +(define (make-colormap descriptor) + (add-to-gc-finalizer! colormap-list (%make-colormap descriptor))) + +(define (x-graphics/get-colormap device) + (make-colormap (x-window-colormap (x-graphics-device/xw device)))) + +(define (x-graphics/set-colormap device colormap) + (x-set-window-colormap (x-graphics-device/xw device) + (colormap/descriptor colormap))) + +(define (create-x-colormap device writeable?) + (let ((window (x-graphics-device/xw device))) + (let ((visual (x-window-visual window))) + (let ((descriptor (x-create-colormap window visual writeable?))) + (x-visual-deallocate visual) + (make-colormap descriptor))))) + +(define (x-colormap/free colormap) + (remove-from-gc-finalizer! colormap-list colormap)) + +(define (x-colormap/allocate-color colormap r g b) + (x-allocate-color (colormap/descriptor colormap) r g b)) + +(define (x-colormap/query-color colormap position) + (x-query-color (colormap/descriptor colormap) position)) + +(define (x-colormap/store-color colormap position r g b) + (x-store-color (colormap/descriptor colormap) position r g b)) + +(define (x-colormap/store-colors colormap color-vector) + (x-store-colors (colormap/descriptor colormap) color-vector)) + +(define (x-graphics/color? device) + (let ((info (x-graphics/visual-info device))) + (let ((n (vector-length info))) + (let loop ((index 0)) + (and (not (fix:= index n)) + (or (let ((class (x-visual-info/class (vector-ref info index)))) + (or (eq? x-visual-class:static-color class) + (eq? x-visual-class:pseudo-color class) + (eq? x-visual-class:true-color class) + (eq? x-visual-class:direct-color class))) + (loop (fix:+ index 1)))))))) + +(define (x-graphics/image-depth device) + (x-window-depth (x-graphics-device/xw device))) + +(define (x-graphics/visual-info device) + (x-get-visual-info (x-graphics-device/xw device) + #f #f #f #f #f #f #f #f #f)) + +(define-structure (visual-info (type vector) (conc-name x-visual-info/)) + (visual #f read-only #t) + (visual-id #f read-only #t) + (screen #f read-only #t) + (depth #f read-only #t) + (class #f read-only #t) + (red-mask #f read-only #t) + (green-mask #f read-only #t) + (blue-mask #f read-only #t) + (colormap-size #f read-only #t) + (bits-per-rgb #f read-only #t)) + +(define-integrable x-visual-class:static-gray 0) +(define-integrable x-visual-class:gray-scale 1) +(define-integrable x-visual-class:static-color 2) +(define-integrable x-visual-class:pseudo-color 3) +(define-integrable x-visual-class:true-color 4) +(define-integrable x-visual-class:direct-color 5) + +(initialize-package!) \ No newline at end of file diff --git a/src/x11/x11graph.c b/src/x11/x11graph.c new file mode 100644 index 000000000..b4d8a7907 --- /dev/null +++ b/src/x11/x11graph.c @@ -0,0 +1,918 @@ +/* -*-C-*- + +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 + 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. + +*/ + +/* Simple graphics for X11 */ + +#include "x11.h" +#include +#include +#include +#include + +#define RESOURCE_NAME "schemeGraphics" +#define RESOURCE_CLASS "SchemeGraphics" +#define DEFAULT_GEOMETRY "512x384+0+0" + +struct gw_extra +{ + float x_left; + float x_right; + float y_bottom; + float y_top; + float x_slope; + float y_slope; + int x_cursor; + int y_cursor; +}; + +struct xwindow_graphics +{ + struct xwindow xw; + struct gw_extra extra; +}; + +#define XW_EXTRA(xw) (& (((struct xwindow_graphics *) xw) -> extra)) + +#define XW_X_LEFT(xw) ((XW_EXTRA (xw)) -> x_left) +#define XW_X_RIGHT(xw) ((XW_EXTRA (xw)) -> x_right) +#define XW_Y_BOTTOM(xw) ((XW_EXTRA (xw)) -> y_bottom) +#define XW_Y_TOP(xw) ((XW_EXTRA (xw)) -> y_top) +#define XW_X_SLOPE(xw) ((XW_EXTRA (xw)) -> x_slope) +#define XW_Y_SLOPE(xw) ((XW_EXTRA (xw)) -> y_slope) +#define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor) +#define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor) + +#define ROUND_FLOAT(flonum) \ + ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5))) + +#define X_COORDINATE(virtual_device_x, xw, direction) \ + (((XW_X_SLOPE (xw)) == FLT_MAX) \ + ? ((direction <= 0) ? 0 : ((int) ((XW_X_SIZE (xw)) - 1))) \ + : (ROUND_FLOAT \ + (((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))))))) + +#define Y_COORDINATE(virtual_device_y, xw, direction) \ + (((XW_Y_SLOPE (xw)) == FLT_MAX) \ + ? ((direction <= 0) ? ((int) ((XW_Y_SIZE (xw)) - 1)) : 0) \ + : (((int) ((XW_Y_SIZE (xw)) - 1)) \ + + (ROUND_FLOAT \ + ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))))))) + +#define X_LENGTH(virtual_length, xw) \ + (((XW_X_SLOPE (xw)) == 0.0) \ + ? 0 \ + : ((XW_X_SLOPE (xw)) == FLT_MAX) \ + ? ((int) ((XW_X_SIZE (xw)) - 1)) \ + : (ROUND_FLOAT ((fabs (XW_X_SLOPE (xw))) * (virtual_length)))) + +#define Y_LENGTH(virtual_length, xw) \ + (((XW_Y_SLOPE (xw)) == 0.0) \ + ? 0 \ + : ((XW_Y_SLOPE (xw)) == FLT_MAX) \ + ? ((int) ((XW_Y_SIZE (xw)) - 1)) \ + : (ROUND_FLOAT ((fabs (XW_Y_SLOPE (xw))) * (virtual_length)))) + +static float +x_coordinate_map (struct xwindow * xw, unsigned int x) +{ + return + ((((XW_X_SLOPE (xw)) == 0.0) || ((XW_X_SLOPE (xw)) == FLT_MAX)) + ? (XW_X_LEFT (xw)) + : ((((float) x) / (XW_X_SLOPE (xw))) + (XW_X_LEFT (xw)))); +} + +static float +y_coordinate_map (struct xwindow * xw, unsigned int y) +{ + return + ((((XW_Y_SLOPE (xw)) == 0.0) || ((XW_Y_SLOPE (xw)) == FLT_MAX)) + ? (XW_Y_BOTTOM (xw)) + : (((((float) y) - ((XW_Y_SIZE (xw)) - 1)) / (XW_Y_SLOPE (xw))) + + (XW_Y_BOTTOM (xw)))); +} + +static void +set_clip_rectangle (struct xwindow * xw, + int x_left, + int y_bottom, + int x_right, + int y_top) +{ + XRectangle rectangles [1]; + Display * display = (XW_DISPLAY (xw)); + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + if (x_left > x_right) + { + unsigned int x = x_left; + x_left = x_right; + x_right = x; + } + if (y_top > y_bottom) + { + unsigned int y = y_top; + y_top = y_bottom; + y_bottom = y; + } + { + unsigned int width = ((x_right + 1) - x_left); + unsigned int height = ((y_bottom + 1) - y_top); + (XW_CLIP_X (xw)) = x_left; + (XW_CLIP_Y (xw)) = y_top; + (XW_CLIP_WIDTH (xw)) = width; + (XW_CLIP_HEIGHT (xw)) = height; + ((rectangles[0]) . x) = x_left; + ((rectangles[0]) . y) = y_top; + ((rectangles[0]) . width) = width; + ((rectangles[0]) . height) = height; + } + XSetClipRectangles + (display, + (XW_NORMAL_GC (xw)), + internal_border_width, + internal_border_width, + rectangles, 1, Unsorted); + XSetClipRectangles + (display, + (XW_REVERSE_GC (xw)), + internal_border_width, + internal_border_width, + rectangles, 1, Unsorted); +} + +static void +reset_clip_rectangle (struct xwindow * xw) +{ + set_clip_rectangle + (xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0); +} + +static void +reset_virtual_device_coordinates (struct xwindow * xw) +{ + /* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that + both limits of the device coordinates will be inside the window. */ + (XW_X_SLOPE (xw)) + = (((XW_X_RIGHT (xw)) == (XW_X_LEFT (xw))) + ? FLT_MAX + : ((XW_X_SIZE (xw)) <= 1) + ? 0.0 + : (((float) ((XW_X_SIZE (xw)) - 1)) + / ((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw))))); + (XW_Y_SLOPE (xw)) + = (((XW_Y_BOTTOM (xw)) == (XW_Y_TOP (xw))) + ? FLT_MAX + : ((XW_Y_SIZE (xw)) <= 1) + ? 0.0 + : (((float) ((XW_Y_SIZE (xw)) - 1)) + / ((XW_Y_BOTTOM (xw)) - (XW_Y_TOP (xw))))); + reset_clip_rectangle (xw); +} + +void +x_graphics_set_vdc_extent (struct xwindow * xw, + float x_left, float y_bottom, + float x_right, float y_top) +{ + (XW_X_LEFT (xw)) = x_left; + (XW_Y_BOTTOM (xw)) = y_bottom; + (XW_X_RIGHT (xw)) = x_right; + (XW_Y_TOP (xw)) = y_top; + reset_virtual_device_coordinates (xw); +} + +void +x_graphics_vdc_extent (struct xwindow * xw, float * results) +{ + results[0] = (XW_X_LEFT (xw)); + results[1] = (XW_Y_BOTTOM (xw)); + results[2] = (XW_X_RIGHT (xw)); + results[3] = (XW_Y_TOP (xw)); +} + +void +x_graphics_reset_clip_rectangle (struct xwindow * xw) +{ + reset_clip_rectangle (xw); +} + +void +x_graphics_set_clip_rectangle (struct xwindow * xw, + int x_left, int y_bottom, int x_right, int y_top) +{ + set_clip_rectangle (xw, + (X_COORDINATE (x_left, xw, -1)), + (Y_COORDINATE (y_bottom, xw, -1)), + (X_COORDINATE (x_right, xw, 1)), + (Y_COORDINATE (y_top, xw, 1))); +} + +static void +process_event (struct xwindow * xw, XEvent * event) +{ +} + +void +x_graphics_reconfigure (struct xwindow * xw, + unsigned int width, unsigned int height) +{ + unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); + unsigned int x_size = ((width < extra) ? 0 : (width - extra)); + unsigned int y_size = ((height < extra) ? 0 : (height - extra)); + if ((x_size != (XW_X_SIZE (xw))) || (y_size != (XW_Y_SIZE (xw)))) + { + (XW_X_SIZE (xw)) = x_size; + (XW_Y_SIZE (xw)) = y_size; + reset_virtual_device_coordinates (xw); + XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + } +} + +static void +wm_set_size_hint (struct xwindow * xw, int geometry_mask, int x, int y) +{ + unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); + XSizeHints * size_hints = (XAllocSizeHints ()); + if (size_hints == 0) + { + fprintf (stderr, "\nXAllocSizeHints failed!\n"); + fflush (stderr); + return; + } + (size_hints -> flags) = + (PResizeInc | PMinSize | PBaseSize + | (((geometry_mask & XValue) && (geometry_mask & YValue)) + ? USPosition : PPosition) + | (((geometry_mask & WidthValue) && (geometry_mask & HeightValue)) + ? USSize : PSize)); + (size_hints -> x) = x; + (size_hints -> y) = y; + (size_hints -> width) = ((XW_X_SIZE (xw)) + extra); + (size_hints -> height) = ((XW_Y_SIZE (xw)) + extra); + (size_hints -> width_inc) = 1; + (size_hints -> height_inc) = 1; + (size_hints -> min_width) = extra; + (size_hints -> min_height) = extra; + (size_hints -> base_width) = extra; + (size_hints -> base_height) = extra; + XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints); + XFree ((caddr_t) size_hints); +} + +struct xwindow * +x_graphics_open_window (struct xdisplay * xd, + char * geometry, + const char * resource_name, + const char * resource_class, + int map_p) +{ + Display * display = (XD_DISPLAY (xd)); + struct drawing_attributes attributes; + struct xwindow_methods methods; + XSetWindowAttributes wattributes; + + if (resource_name == NULL) resource_name = RESOURCE_NAME; + if (resource_class == NULL) resource_class = RESOURCE_CLASS; + + if (0 != x_default_attributes (display, resource_name, resource_class, + (&attributes))) + return (NULL); + (wattributes . background_pixel) = (attributes . background_pixel); + (wattributes . border_pixel) = (attributes . border_pixel); + (wattributes . backing_store) = Always; + (methods . deallocator) = 0; + (methods . event_processor) = process_event; + (methods . x_coordinate_map) = x_coordinate_map; + (methods . y_coordinate_map) = y_coordinate_map; + (methods . update_normal_hints) = 0; + { + unsigned int extra = (2 * (attributes . internal_border_width)); + int x_pos = (-1); + int y_pos = (-1); + int x_size = 512; + int y_size = 384; + int geometry_mask = + (XGeometry (display, (DefaultScreen (display)), + ((geometry == NULL) + ? (x_get_default + (display, resource_name, resource_class, + "geometry", "Geometry", 0)) + : geometry), + DEFAULT_GEOMETRY, (attributes . border_width), + 1, 1, extra, extra, + (&x_pos), (&y_pos), (&x_size), (&y_size))); + Window window = + (XCreateWindow + (display, + (RootWindow (display, (DefaultScreen (display)))), + x_pos, y_pos, (x_size + extra), (y_size + extra), + (attributes . border_width), + CopyFromParent, CopyFromParent, CopyFromParent, + (CWBackPixel | CWBorderPixel | CWBackingStore), + (&wattributes))); + if (window == 0) + return (NULL); + { + struct xwindow * xw; + xw = + (x_make_window + (xd, window, x_size, y_size, (&attributes), (&methods), + (sizeof (struct xwindow_graphics)))); + (XW_X_LEFT (xw)) = ((float) (-1)); + (XW_X_RIGHT (xw)) = ((float) 1); + (XW_Y_BOTTOM (xw)) = ((float) (-1)); + (XW_Y_TOP (xw)) = ((float) 1); + reset_virtual_device_coordinates (xw); + (XW_X_CURSOR (xw)) = 0; + (XW_Y_CURSOR (xw)) = 0; + wm_set_size_hint (xw, geometry_mask, x_pos, y_pos); + if ((0 != xw_set_wm_input_hint (xw, 0)) + || (0 != xw_set_wm_name (xw, "scheme-graphics")) + || (0 != xw_set_wm_icon_name (xw, "scheme-graphics")) + /* || (0 != XSelectInput (display, window, StructureNotifyMask)) + The above fails with BadRequest but may have always done + so. The umodule did not check the return code. */ + || (0 != xw_make_window_map (xw, resource_name, resource_class, + map_p))) + { + x_close_window (xw); + return (NULL); + } + return (xw); + } + } +} + +void +x_graphics_draw_line (struct xwindow * xw, + float x_start, float y_start, float x_end, float y_end) +{ + unsigned int new_x_cursor = (X_COORDINATE (x_end, xw, 0)); + unsigned int new_y_cursor = (Y_COORDINATE (y_end, xw, 0)); + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + XDrawLine + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (internal_border_width + (X_COORDINATE (x_start, xw, 0))), + (internal_border_width + (Y_COORDINATE (y_start, xw, 0))), + (internal_border_width + new_x_cursor), + (internal_border_width + new_y_cursor)); + (XW_X_CURSOR (xw)) = new_x_cursor; + (XW_Y_CURSOR (xw)) = new_y_cursor; +} + +void +x_graphics_move_cursor (struct xwindow * xw, float x, float y) +{ + (XW_X_CURSOR (xw)) = (X_COORDINATE (x, xw, 0)); + (XW_Y_CURSOR (xw)) = (Y_COORDINATE (y, xw, 0)); +} + +void +x_graphics_drag_cursor (struct xwindow * xw, float x, float y) +{ + unsigned int new_x_cursor = (X_COORDINATE (x, xw, 0)); + unsigned int new_y_cursor = (Y_COORDINATE (y, xw, 0)); + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + XDrawLine + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (internal_border_width + (XW_X_CURSOR (xw))), + (internal_border_width + (XW_Y_CURSOR (xw))), + (internal_border_width + new_x_cursor), + (internal_border_width + new_y_cursor)); + (XW_X_CURSOR (xw)) = new_x_cursor; + (XW_Y_CURSOR (xw)) = new_y_cursor; +} + +void +x_graphics_draw_point (struct xwindow * xw, float x, float y) +{ + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + XDrawPoint + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (internal_border_width + (X_COORDINATE (x, xw, 0))), + (internal_border_width + (Y_COORDINATE (y, xw, 0)))); +} + +void +x_graphics_draw_arc (struct xwindow * xw, + float virtual_device_x, + float virtual_device_y, + float radius_x, + float radius_y, + float angle_start, + float angle_sweep, + int fill_p) +{ + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + + /* we assume a virtual coordinate system with X increasing left to + * right and Y increasing top to bottom. If we are wrong then we + * have to flip the axes and adjust the angles */ + + int x1 = (X_COORDINATE (virtual_device_x - radius_x, xw, 0)); + int x2 = (X_COORDINATE (virtual_device_x + radius_x, xw, 0)); + int y1 = (Y_COORDINATE (virtual_device_y + radius_y, xw, 0)); + int y2 = (Y_COORDINATE (virtual_device_y - radius_y, xw, 0)); + int width, height; + int angle1 = ((int)(angle_start * 64)) % (64*360); + int angle2 = ((int)(angle_sweep * 64)); + if (angle1 < 0) + angle1 = (64*360) + angle1; + /* angle1 is now 0..359 */ + if (x2 a b2)) + (graphics-draw-text g (fx a) (fy a) "."))) + + (graphics-draw-text g (fx a1) (fy a1) ".Start") + (graphics-draw-text g (fx (+ a1 a2)) (fy (+ a1 a2)) ".End"))) + +;; Test axes +(test 1 1 30 90) +(test -1 1 30 90) +(test 1 -1 30 90) +(test -1 -1 30 90) + +;; Test angles +(test 1 1 30 90) +(test 1 1 30 -90) +(test 1 1 -30 90) +(test 1 1 -30 -90) + ***********************************************************************/ + +void +x_graphics_draw_string (struct xwindow * xw, + float x, float y, char * string) +{ + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + XDrawString + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (internal_border_width + (X_COORDINATE (x, xw, 0))), + (internal_border_width + (Y_COORDINATE (y, xw, 0))), + string, + strlen (string)); +} + +void +x_graphics_draw_image_string (struct xwindow * xw, + float x, float y, char * string) +{ + unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); + XDrawImageString + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (internal_border_width + (X_COORDINATE (x, xw, 0))), + (internal_border_width + (Y_COORDINATE (y, xw, 0))), + string, + strlen (string)); +} + +int +x_graphics_set_function (struct xwindow * xw, unsigned int function) +{ + Display * display = (XW_DISPLAY (xw)); + if (function >= 16) + return (1); + XSetFunction (display, (XW_NORMAL_GC (xw)), function); + XSetFunction (display, (XW_REVERSE_GC (xw)), function); + return (0); +} + +static void +transform_points (struct xwindow * xw, + double * x_vector, double * y_vector, + unsigned int n_points, + XPoint * points) +{ + double * scan_x = x_vector; + double * end_x = x_vector + n_points; + double * scan_y = y_vector; + XPoint * scan_points = points; + unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); + while (scan_x < end_x) + { + (scan_points -> x) = (border + (X_COORDINATE ((*scan_x++), xw, 0))); + (scan_points -> y) = (border + (X_COORDINATE ((*scan_y++), xw, 0))); + scan_points += 1; + } +} + +void +x_graphics_draw_points (struct xwindow * xw, + double * x_vector, double * y_vector, + unsigned int n_points, XPoint * points) +{ + transform_points (xw, x_vector, y_vector, n_points, points); + while (n_points > 0) + { + unsigned int this_send = ((n_points <= 4093) ? n_points : 4093); + n_points -= this_send; + XDrawPoints ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + points, + this_send, + CoordModeOrigin); + points += this_send; + } +} + +void +x_graphics_draw_lines (struct xwindow * xw, + double * x_vector, double * y_vector, + unsigned int n_points, XPoint * points) +{ + transform_points (xw, x_vector, y_vector, n_points, points); + while (n_points > 0) + { + unsigned int this_send = ((n_points <= 2047) ? n_points : 2047); + n_points -= this_send; + XDrawLines ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + points, + this_send, + CoordModeOrigin); + points += (this_send - 1); + } +} + +int +x_graphics_set_fill_style (struct xwindow * xw, unsigned int fill_style) +{ + Display * display = (XW_DISPLAY (xw)); + if (fill_style >= 4) + return (0); + XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style); + XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style); + return (1); +} + +int +x_graphics_set_line_style (struct xwindow * xw, unsigned int style) +{ + Display * display = (XW_DISPLAY (xw)); + if (style >= 3) + return (0); + XSetLineAttributes + (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter); + XSetLineAttributes + (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter); + return (1); +} + +int +x_graphics_set_dashes (struct xwindow * xw, int dash_offset, + char * dash_list, int dash_list_length) +{ + Display * display = (XW_DISPLAY (xw)); + if (dash_offset >= dash_list_length) + return (0); + XSetDashes + (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length); + XSetDashes + (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list, dash_list_length); + return (1); +} + +int +x_graphics_copy_area (struct xwindow * source_xw, + struct xwindow * destination_xw, + int source_x, int source_y, + int width, int height, + int dest_x, int dest_y) +{ + unsigned int source_internal_border_width + = (XW_INTERNAL_BORDER_WIDTH (source_xw)); + unsigned int destination_internal_border_width + = (XW_INTERNAL_BORDER_WIDTH (destination_xw)); + Display *source_display = XW_DISPLAY (source_xw); + Display *destination_display = XW_DISPLAY (destination_xw); + if (source_display != destination_display) + return (0); + XCopyArea (source_display, + (XW_WINDOW (source_xw)), + (XW_WINDOW (destination_xw)), + (XW_NORMAL_GC (source_xw)), + (source_internal_border_width + + (X_COORDINATE (source_x, source_xw, -1))), + (source_internal_border_width + + (Y_COORDINATE (source_y, source_xw, 1))), + (X_LENGTH (width, source_xw)), + (Y_LENGTH (height, source_xw)), + (destination_internal_border_width + + (X_COORDINATE (dest_x, destination_xw, -1))), + (destination_internal_border_width + + (Y_COORDINATE (dest_y, destination_xw, 1)))); + return (1); +} + +void +transform_polygon_points (struct xwindow * xw, double * vector, int length, + XPoint * result) +{ + unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); + { + XPoint * scan_result = result; + double * scan = vector; + double * end = (scan + length); + double coord; + while (scan < end) + { + coord = (*scan++); + (scan_result -> x) = (border + (X_COORDINATE (coord, xw, 0))); + coord = (*scan++); + (scan_result -> y) = (border + (Y_COORDINATE (coord, xw, 0))); + scan_result += 1; + } + } +} + +void +x_graphics_fill_polygon (struct xwindow * xw, + double * vector, unsigned int length, + XPoint * points) +{ + transform_polygon_points (xw, vector, length, points); + XFillPolygon ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + points, + (length / 2), + Nonconvex, + CoordModeOrigin); +} + +static int +find_pixmap_format (Display * dpy, int depth, XPixmapFormatValues * format) +{ + XPixmapFormatValues * pixmap_formats; + int n_pixmap_formats; + XPixmapFormatValues * scan_pixmap_formats; + XPixmapFormatValues * end_pixmap_formats; + + pixmap_formats = (XListPixmapFormats (dpy, (&n_pixmap_formats))); + if (pixmap_formats == 0) + return (0); + scan_pixmap_formats = pixmap_formats; + end_pixmap_formats = (pixmap_formats + n_pixmap_formats); + while (1) + { + if (scan_pixmap_formats >= end_pixmap_formats) + return (0); + if ((scan_pixmap_formats -> depth) == depth) + { + (*format) = (*scan_pixmap_formats); + XFree (pixmap_formats); + return (1); + } + scan_pixmap_formats += 1; + } +} + +struct ximage * +x_create_image (struct xwindow * xw, uint width, uint height) +{ + Window window = (XW_WINDOW (xw)); + Display * dpy = (XW_DISPLAY (xw)); + XWindowAttributes attrs; + XPixmapFormatValues pixmap_format; + unsigned int bits_per_line; + unsigned int bitmap_pad; + unsigned int bytes_per_line; + char * data; + + XGetWindowAttributes (dpy, window, (&attrs)); + if (!find_pixmap_format (dpy, (attrs . depth), (&pixmap_format))) + return (NULL); + bits_per_line = ((pixmap_format . bits_per_pixel) * width); + bitmap_pad = (pixmap_format . scanline_pad); + if ((bits_per_line % bitmap_pad) != 0) + bits_per_line += (bitmap_pad - (bits_per_line % bitmap_pad)); + bytes_per_line = ((bits_per_line + (CHAR_BIT - 1)) / CHAR_BIT); + data = malloc (height * bytes_per_line); + if (data == NULL) + return (NULL); + return (allocate_x_image + (XCreateImage + (dpy, + (DefaultVisualOfScreen (attrs . screen)), + (attrs . depth), + ZPixmap, + 0, + data, + width, + height, + bitmap_pad, + bytes_per_line))); +} + +int +x_bytes_into_image (char * vector, int length, struct ximage *ximage) +{ + XImage * image = (XI_IMAGE (ximage)); + unsigned long width = (image -> width); + unsigned long height = (image -> height); + unsigned char * vscan; + unsigned long x; + unsigned long y; + if (length != (width * height)) + return (0); + vscan = vector; + for (y = 0; (y < height); y += 1) + for (x = 0; (x < width); x += 1) + XPutPixel (image, x, y, ((unsigned long) (*vscan++))); +} + +long +x_get_pixel_from_image (struct ximage * xi, int x, int y) +{ + XImage * image = (XI_IMAGE (xi)); + if ((x >= (image -> width)) + || (y >= (image -> height))) + return (-1); + return (XGetPixel (image, x, y)); +} + +int +x_set_pixel_in_image (struct ximage * xi, int x, int y, unsigned long pixel) +{ + XImage * image = (XI_IMAGE (xi)); + if ((x >= (image -> width)) + || (y >= (image -> height))) + return (0); + XPutPixel (image, x, y, pixel); + return (1); +} + +void +x_destroy_image (struct ximage * xi) +{ + XDestroyImage (XI_IMAGE (xi)); + deallocate_x_image (xi); +} + +int +x_display_image (struct ximage * xi, + unsigned int x_offset, unsigned int y_offset, + struct xwindow * xw, + unsigned int window_xoff, unsigned int window_yoff, + unsigned int width, unsigned int height) +{ + XImage * image = (XI_IMAGE (xi)); + unsigned int image_width = (image -> width); + unsigned int image_height = (image -> height); + if ((x_offset >= image_width) + || (y_offset >= image_height) + || (width >= ((image_width - x_offset) + 1)) + || (height >= ((image_height - y_offset) + 1))) + return (0); + XPutImage + ((XW_DISPLAY (xw)),(XW_WINDOW (xw)),(XW_NORMAL_GC (xw)), + image, x_offset, y_offset, + (X_COORDINATE (window_xoff, xw, -1)), + (Y_COORDINATE (window_yoff, xw, 1)), + width, height); + return (1); +} + + +void +x_read_image (struct ximage * xi, + long XImageOffset, long YImageOffset, + struct xwindow * xw, + long XWindowOffset, long YWindowOffset, + long Width, long Height) +{ + XGetSubImage(XW_DISPLAY(xw), XW_WINDOW(xw), XWindowOffset, YWindowOffset, + Width, Height, -1, ZPixmap, + XI_IMAGE(xi), XImageOffset, YImageOffset); +} + +int +x_window_depth (struct xwindow * xw) +{ + XWindowAttributes attrs; + XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&attrs)); + return (attrs . depth); +} + +float +x_graphics_map_x_coordinate (struct xwindow * xw, int signed_xp) +{ + unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp)); + int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw))); + return (x_coordinate_map (xw, + ((bx < 0) ? 0 + : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1) + : bx))); +} + +float +x_graphics_map_y_coordinate (struct xwindow * xw, int signed_yp) +{ + unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp)); + int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw))); + return (y_coordinate_map (xw, + ((by < 0) ? 0 + : (by >= (XW_Y_SIZE (xw))) + ? ((XW_Y_SIZE (xw)) - 1) + : by))); +} diff --git a/src/x11/x11graph.scm b/src/x11/x11graph.scm new file mode 100644 index 000000000..8ce7a56e9 --- /dev/null +++ b/src/x11/x11graph.scm @@ -0,0 +1,228 @@ +#| -*-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 + 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. + +|# + +;;;; X11 interface +;;; package: (x11) +;;; +;;; These were once primitives created by x11base.c in umodule prx11. + +(C-include "x11") + +(define (x-graphics-set-vdc-extent window x-left y-bottom x-right y-top) + ;; Set the virtual device coordinates to the given values. + (C-call "x_graphics_set_vdc_extent" window x-left y-bottom x-right y-top)) + +(define (x-graphics-vdc-extent window vector) + (let* ((floats (malloc (* 4 (C-sizeof "float")) 'float)) + (scan (copy-alien floats))) + (C-call "x_graphics_vdc_extent" window floats) + (vector-set! vector 0 (C-> floats "float")) + (alien-byte-increment! scan (C-sizeof "float")) + (vector-set! vector 1 (C-> floats "float")) + (alien-byte-increment! scan (C-sizeof "float")) + (vector-set! vector 2 (C-> floats "float")) + (alien-byte-increment! scan (C-sizeof "float")) + (vector-set! vector 3 (C-> floats "float")) + (free floats))) + +(define (x-graphics-reset-clip-rectangle window) + (C-call "x_graphics_reset_clip_rectangle" window)) + +(define (x-graphics-set-clip-rectangle window x-left y-bottom x-right y-top) + ;; Set the clip rectangle to the given coordinates. + (C-call "x_graphics_set_clip_rectangle" + window x-left y-bottom x-right y-top)) + +(define (x-graphics-reconfigure window width height) + (C-call "x_graphics_reconfigure" window width height)) + +(define (x-graphics-open-window display geometry suppress-map) + ;; Open a window on DISPLAY using GEOMETRY. If GEOMETRY is false + ;; map window interactively. If third argument SUPPRESS-MAP? is + ;; true, do not map the window immediately. + (receive (name class map?) + (cond ((and (pair? suppress-map) + (string? (car suppress-map)) + (string? (cdr suppress-map))) + (values (car suppress-map) (cdr suppress-map) #t)) + ((and (vector? suppress-map) + (= 3 (vector-length suppress-map)) + (boolean? (vector-ref suppress-map 0)) + (string? (vector-ref suppress-map 1)) + (string? (vector-ref suppress-map 2))) + (values (vector-ref suppress-map 1) + (vector-ref suppress-map 2) + (vector-ref suppress-map 0))) + ((eq? #f suppress-map) + (values #f #f #t)) + (else + (values #f #f #f))) + (let ((window + (c-call "x_graphics_open_window" (make-alien '(struct |xwindow|)) + display geometry name class (if map? 1 0)))) + (if (alien-null? window) + (error "Could not open window:" geometry)) + window))) + +(define (x-graphics-draw-line window x-start y-start x-end y-end) + ;; Draw a line from the start coordinates to the end coordinates. + ;; Subsequently move the graphics cursor to the end coordinates. + (C-call "x_graphics_draw_line" window x-start y-start x-end y-end)) + +(define (x-graphics-move-cursor window x y) + ;; Move the graphics cursor to the given coordinates. + (C-call "x_graphics_move_cursor" window x y)) + +(define (x-graphics-drag-cursor window x y) + ;; Draw a line from the graphics cursor to the given coordinates. + ;; Subsequently move the graphics cursor to those coordinates. + (C-call "x_graphics_drag_cursor" window x y)) + +(define (x-graphics-draw-point window x y) + ;; Draw one point at the given coordinates. + ;; Subsequently move the graphics cursor to those coordinates. + (C-call "x_graphics_draw_point" window x y)) + +(define (x-graphics-draw-arc window x y start-angle sweep-angle fill?) + ;; Draw an arc at the given coordinates, with given X and Y radii. + ;; START-ANGLE and SWEEP-ANGLE are in degrees, anti-clocwise. + ;; START-ANGLE is from 3 o'clock, and SWEEP-ANGLE is relative to the + ;; START-ANGLE. If FILL? is true, the arc is filled. + (C-call "x_graphics_draw_arc" window + x y start-angle sweep-angle (if fill? 1 0))) + +(define (x-graphics-draw-string window x y string) + ;; Draw characters in the current font at the given coordinates, with + ;; transparent background. + (C-call "x_graphics_draw_string" window x y string)) + +(define (x-graphics-draw-image-string window x y string) + ;; Draw characters in the current font at the given coordinates, with + ;; solid background. + (C-call "x_graphics_draw_image_string" window x y string)) + +(define (x-graphics-set-function window function) + (if (not (zero? (C-call "x_graphics_set_function" window function))) + (error:bad-range-argument function 'x-graphics-set-function))) + +(define (x-graphics-draw-points window x-vector y-vector) + (let* ((n-points (flo:vector-length x-vector)) + (points (malloc (* n-points (C-sizeof "XPoint"))))) + (if (not (= n-points (flo:vector-length y-vector))) + (error:bad-range-argument y-vector 'x-graphics-draw-points)) + (C-call "x_graphics_draw_points" window x-vector y-vector n-points points) + (free points))) + +(define (x-graphics-draw-lines window x-vector y-vector) + (let* ((n-points (flo:vector-length x-vector)) + (points (malloc (* n-points (C-sizeof "XPoint"))))) + (if (not (= n-points (flo:vector-length y-vector))) + (error:bad-range-argument y-vector 'x-graphics-draw-lines)) + (C-call "x_graphics_draw_lines" window x-vector y-vector n-points points) + (free points))) + +(define (x-graphics-set-fill-style window style) + (if (zero? (C-call "x_graphics_set_fill_style" window style)) + (error:bad-range-argument style 'x-graphics-set-fill-style))) + +(define (x-graphics-set-line-style window style) + (if (zero? (C-call "x_graphics_set_line_style" window style)) + (error:bad-range-argument style 'x-graphics-set-line-style))) + +(define (x-graphics-set-dashes window dash-offset dash-list) + (if (zero? (C-call "x_graphics_set_dashes" + window dash-offset dash-list (string-length dash-list))) + (error:bad-range-argument dash-offset 'x-graphics-set-dashes))) + +(define (x-graphics-copy-area source-window destination-window + source-x-left source-y-top width height + destination-x-left destination-y-top) + (if (zero? (C-call "x_graphics_copy_area" + source-window destination-window + source-x-left source-y-top width height + destination-x-left destination-y-top)) + (error "Source and destination are not the same."))) + +(define (x-graphics-fill-polygon window vector) + (let ((length (flo:vector-length vector))) + (if (not (even? length)) + (error:bad-range-argument vector 'x-graphics-fill-polygon)) + (let ((points (malloc (* (/ length 2) (C-sizeof "XPoint"))))) + (C-call "x_graphics_fill_polygon" window vector length points) + (free points)))) + +(define (x-create-image window width height) + ;; Creates and returns an XImage object, of dimensions WIDTH by HEIGHT. + ;; WINDOW is used to set the Display, Visual, and Depth characteristics. + ;; The image is created by calling XCreateImage. + (let ((result (C-call "x_create_image" (make-alien '(struct |xwindow|)) + window width height))) + (if (alien-null? result) + (error "Could not create image:" window) + result))) + +(define (x-bytes-into-image vector image) + ;; VECTOR is a vector or vector-8b of pixel values stored in row-major + ;; order; it must have the same number of pixels as IMAGE. + ;; These pixels are written onto IMAGE by repeated calls to XPutPixel. + ;; This procedure is equivalent to calling X-SET-PIXEL-IN-IMAGE for each + ;; pixel in VECTOR. + (guarantee-string vector 'x-bytes-into-image) + (C-call "x_bytes_into_image" vector image)) + +(define (x-get-pixel-from-image image x y) + (let ((pixel (C-call "x_get_pixel_from_image" image x y))) + (if (negative? pixel) + (error "Invalid arguments.")) + pixel)) + +(define (x-set-pixel-in-image image x y pixel) + (if (zero? (C-call "x_set_pixel_in_image" image x y pixel)) + (error "Invalid arguments."))) + +(define (x-destroy-image image) + (C-call "x_destroy_image" image)) + +(define (x-display-image image x-offset y-offset + window window-xoff window-yoff width height) + (if (zero? (C-call "x_display_image" image x-offset y-offset + window window-xoff window-yoff width height)) + (error "Invalid args."))) + +(define (x-read-image image x-image-offset y-image-offset + window x-window-offset y-window-offset width height) + (C-call "x_read_image" image x-image-offset y-image-offset + window x-window-offset y-window-offset width height)) + +(define (x-window-depth window) + ;; Returns the pixel depth of WINDOW as an integer. + (C-call "x_window_depth" window)) + +(define (x-graphics-map-x-coordinate window x) + (C-call "x_graphics_map_x_coordinate" window x)) + +(define (x-graphics-map-y-coordinate window y) + (C-call "x_graphics_map_y_coordinate" window y)) \ No newline at end of file diff --git a/src/x11/x11term.c b/src/x11/x11term.c new file mode 100644 index 000000000..a543a7066 --- /dev/null +++ b/src/x11/x11term.c @@ -0,0 +1,958 @@ +/* -*-C-*- + +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 + 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. + +*/ + +/* X11 terminal for Edwin. */ + +#include +#include "x11.h" + +struct xterm_extra +{ + /* Dimensions of the window, in characters. Valid character + coordinates are nonnegative integers strictly less than these + limits. */ + unsigned int x_size; + unsigned int y_size; + + /* Position of the cursor, in character coordinates. */ + unsigned int cursor_x; + unsigned int cursor_y; + + /* Character map of the window's contents. See `XTERM_CHAR_LOC' for + the address arithmetic. */ + char * character_map; + + /* Bit map of the window's highlighting. */ + char * highlight_map; + + /* Nonzero iff the cursor is drawn on the window. */ + char cursor_visible_p; + + /* Nonzero iff the cursor should be drawn on the window. */ + char cursor_enabled_p; +}; + +struct xwindow_term +{ + struct xwindow xw; + struct xterm_extra extra; +}; + +#define XW_EXTRA(xw) (& (((struct xwindow_term *) xw) -> extra)) + +#define XW_X_CSIZE(xw) ((XW_EXTRA (xw)) -> x_size) +#define XW_Y_CSIZE(xw) ((XW_EXTRA (xw)) -> y_size) +#define XW_CURSOR_X(xw) ((XW_EXTRA (xw)) -> cursor_x) +#define XW_CURSOR_Y(xw) ((XW_EXTRA (xw)) -> cursor_y) +#define XW_CHARACTER_MAP(xw) ((XW_EXTRA (xw)) -> character_map) +#define XW_HIGHLIGHT_MAP(xw) ((XW_EXTRA (xw)) -> highlight_map) +#define XW_CURSOR_VISIBLE_P(xw) ((XW_EXTRA (xw)) -> cursor_visible_p) +#define XW_CURSOR_ENABLED_P(xw) ((XW_EXTRA (xw)) -> cursor_enabled_p) + +#define XTERM_CHAR_INDEX(xw, x, y) (((y) * (XW_X_CSIZE (xw))) + (x)) +#define XTERM_CHAR_LOC(xw, index) ((XW_CHARACTER_MAP (xw)) + (index)) +#define XTERM_CHAR(xw, index) (* (XTERM_CHAR_LOC (xw, index))) +#define XTERM_HL_LOC(xw, index) ((XW_HIGHLIGHT_MAP (xw)) + (index)) +#define XTERM_HL(xw, index) (* (XTERM_HL_LOC (xw, index))) + +#define XTERM_HL_GC(xw, hl) (hl ? (XW_REVERSE_GC (xw)) : (XW_NORMAL_GC (xw))) + +#define HL_ARG(arg) arg_index_integer (arg, 2) + +#define RESOURCE_NAME "schemeTerminal" +#define RESOURCE_CLASS "SchemeTerminal" +#define DEFAULT_GEOMETRY "80x40+0+0" +#define BLANK_CHAR ' ' +#define DEFAULT_HL 0 + +#define XTERM_X_PIXEL(xw, x) \ + (((x) * (FONT_WIDTH (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw))) + +#define XTERM_Y_PIXEL(xw, y) \ + (((y) * (FONT_HEIGHT (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw))) + +#define XTERM_DRAW_CHARS(xw, x, y, s, n, gc) \ + XDrawImageString \ + ((XW_DISPLAY (xw)), \ + (XW_WINDOW (xw)), \ + gc, \ + (XTERM_X_PIXEL (xw, x)), \ + ((XTERM_Y_PIXEL (xw, y)) + (FONT_BASE (XW_FONT (xw)))), \ + s, \ + n) + +#define CURSOR_IN_RECTANGLE(xw, x_start, x_end, y_start, y_end) \ + (((x_start) <= (XW_CURSOR_X (xw))) \ + && ((XW_CURSOR_X (xw)) < (x_end)) \ + && ((y_start) <= (XW_CURSOR_Y (xw))) \ + && ((XW_CURSOR_Y (xw)) < (y_end))) + +void +xterm_erase_cursor (struct xwindow * xw) +{ + if (XW_CURSOR_VISIBLE_P (xw)) + { + unsigned int x = (XW_CURSOR_X (xw)); + unsigned int y = (XW_CURSOR_Y (xw)); + unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); + XTERM_DRAW_CHARS + (xw, x, y, + (XTERM_CHAR_LOC (xw, index)), + 1, + (XTERM_HL_GC (xw, (XTERM_HL (xw, index))))); + (XW_CURSOR_VISIBLE_P (xw)) = 0; + } +} + +void +xterm_draw_cursor (struct xwindow * xw) +{ + if ((XW_CURSOR_ENABLED_P (xw)) && (! (XW_CURSOR_VISIBLE_P (xw)))) + { + unsigned int x = (XW_CURSOR_X (xw)); + unsigned int y = (XW_CURSOR_Y (xw)); + unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); + int hl = (XTERM_HL (xw, index)); + XTERM_DRAW_CHARS + (xw, x, y, + (XTERM_CHAR_LOC (xw, index)), + 1, + ((hl && ((XW_FOREGROUND_PIXEL (xw)) == (XW_CURSOR_PIXEL (xw)))) + ? (XW_NORMAL_GC (xw)) + : (XW_CURSOR_GC (xw)))); + (XW_CURSOR_VISIBLE_P (xw)) = 1; + } +} + +static void +xterm_process_event (struct xwindow * xw, XEvent * event) +{ +} + +static XSizeHints * +xterm_make_size_hints (XFontStruct * font, unsigned int extra) +{ + XSizeHints * size_hints = (XAllocSizeHints ()); + if (size_hints == 0) + return (NULL); + (size_hints -> flags) = (PResizeInc | PMinSize | PBaseSize); + (size_hints -> width_inc) = (FONT_WIDTH (font)); + (size_hints -> height_inc) = (FONT_HEIGHT (font)); + (size_hints -> min_width) = extra; + (size_hints -> min_height) = extra; + (size_hints -> base_width) = extra; + (size_hints -> base_height) = extra; + return (size_hints); +} + +static void +xterm_set_wm_normal_hints (struct xwindow * xw, XSizeHints * size_hints) +{ + XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints); + XFree (size_hints); +} + +static void +xterm_update_normal_hints (struct xwindow * xw) +{ + XSizeHints * hints = (xterm_make_size_hints + ((XW_FONT (xw)), + (2 * (XW_INTERNAL_BORDER_WIDTH (xw))))); + if (hints == NULL) + return; + xterm_set_wm_normal_hints (xw, hints); +} + +static void +xterm_deallocate (struct xwindow * xw) +{ + free (XW_CHARACTER_MAP (xw)); + free (XW_HIGHLIGHT_MAP (xw)); +} + +static float +xterm_x_coordinate_map (struct xwindow * xw, unsigned int x) +{ + return (x / (FONT_WIDTH (XW_FONT (xw)))); +} + +static float +xterm_y_coordinate_map (struct xwindow * xw, unsigned int y) +{ + return (y / (FONT_HEIGHT (XW_FONT (xw)))); +} + +static void +xterm_copy_map_line (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_from, + unsigned int y_to) +{ + { + char * from_scan = + (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from)))); + char * from_end = + (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from)))); + char * to_scan = + (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to)))); + while (from_scan < from_end) + (*to_scan++) = (*from_scan++); + } + { + char * from_scan = + (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from)))); + char * from_end = + (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from)))); + char * to_scan = + (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to)))); + while (from_scan < from_end) + (*to_scan++) = (*from_scan++); + } +} + +static void +xterm_dump_contents (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end) +{ + char * character_map = (XW_CHARACTER_MAP (xw)); + char * highlight_map = (XW_HIGHLIGHT_MAP (xw)); + if (x_start < x_end) + { + unsigned int yi; + for (yi = y_start; (yi < y_end); yi += 1) + { + unsigned int index = (XTERM_CHAR_INDEX (xw, 0, yi)); + char * line_char = (&character_map[index]); + char * line_hl = (&highlight_map[index]); + unsigned int xi = x_start; + while (1) + { + unsigned int hl = (line_hl[xi]); + unsigned int xj = (xi + 1); + while ((xj < x_end) && ((line_hl[xj]) == hl)) + xj += 1; + XTERM_DRAW_CHARS (xw, xi, yi, + (&line_char[xi]), + (xj - xi), + (XTERM_HL_GC (xw, hl))); + if (xj == x_end) + break; + xi = xj; + } + } + if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end)) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + } +} + +void +xterm_dump_rectangle (struct xwindow * xw, + int signed_x, + int signed_y, + unsigned int width, + unsigned int height) +{ + XFontStruct * font = (XW_FONT (xw)); + unsigned int x = ((signed_x < 0) ? 0 : ((unsigned int) signed_x)); + unsigned int y = ((signed_y < 0) ? 0 : ((unsigned int) signed_y)); + unsigned int fwidth = (FONT_WIDTH (font)); + unsigned int fheight = (FONT_HEIGHT (font)); + unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); + if (x < border) + { + width -= (border - x); + x = 0; + } + else + x -= border; + if ((x + width) > (XW_X_SIZE (xw))) + width = ((XW_X_SIZE (xw)) - x); + if (y < border) + { + height -= (border - y); + y = 0; + } + else + y -= border; + if ((y + height) > (XW_Y_SIZE (xw))) + height = ((XW_Y_SIZE (xw)) - y); + { + unsigned int x_start = (x / fwidth); + unsigned int x_end = (((x + width) + (fwidth - 1)) / fwidth); + unsigned int y_start = (y / fheight); + unsigned int y_end = (((y + height) + (fheight - 1)) / fheight); + if (x_end > (XW_X_CSIZE (xw))) + x_end = (XW_X_CSIZE (xw)); + if (y_end > (XW_Y_CSIZE (xw))) + y_end = (XW_Y_CSIZE (xw)); + xterm_dump_contents (xw, x_start, x_end, y_start, y_end); + } + XFlush (XW_DISPLAY (xw)); +} + +#define MIN(x, y) (((x) < (y)) ? (x) : (y)) + +int +xterm_reconfigure (struct xwindow * xw, + unsigned int x_csize, + unsigned int y_csize) +{ + if ((x_csize != (XW_X_CSIZE (xw))) || (y_csize != (XW_Y_CSIZE (xw)))) + { + char * new_char_map = (malloc (x_csize * y_csize)); + char * new_hl_map = (malloc (x_csize * y_csize)); + unsigned int old_x_csize = (XW_X_CSIZE (xw)); + unsigned int min_x_csize = (MIN (x_csize, old_x_csize)); + unsigned int min_y_csize = (MIN (y_csize, (XW_Y_CSIZE (xw)))); + int x_clipped = (old_x_csize - x_csize); + char * new_scan_char = new_char_map; + char * new_scan_hl = new_hl_map; + char * new_end; + char * old_scan_char = (XW_CHARACTER_MAP (xw)); + char * old_scan_hl = (XW_HIGHLIGHT_MAP (xw)); + char * old_end; + unsigned int new_y = 0; + if (new_char_map == NULL) return (1); + if (new_hl_map == NULL) return (1); + for (; (new_y < min_y_csize); new_y += 1) + { + old_end = (old_scan_char + min_x_csize); + while (old_scan_char < old_end) + { + (*new_scan_char++) = (*old_scan_char++); + (*new_scan_hl++) = (*old_scan_hl++); + } + if (x_clipped < 0) + { + new_end = (new_scan_char + ((unsigned int) (- x_clipped))); + while (new_scan_char < new_end) + { + (*new_scan_char++) = BLANK_CHAR; + (*new_scan_hl++) = DEFAULT_HL; + } + } + else if (x_clipped > 0) + { + old_scan_char += ((unsigned int) x_clipped); + old_scan_hl += ((unsigned int) x_clipped); + } + } + for (; (new_y < y_csize); new_y += 1) + { + new_end = (new_scan_char + x_csize); + while (new_scan_char < new_end) + { + (*new_scan_char++) = BLANK_CHAR; + (*new_scan_hl++) = DEFAULT_HL; + } + } + free (XW_CHARACTER_MAP (xw)); + free (XW_HIGHLIGHT_MAP (xw)); + { + unsigned int x_size = (XTERM_X_PIXEL (xw, x_csize)); + unsigned int y_size = (XTERM_Y_PIXEL (xw, x_csize)); + (XW_X_SIZE (xw)) = x_size; + (XW_Y_SIZE (xw)) = y_size; + (XW_CLIP_X (xw)) = 0; + (XW_CLIP_Y (xw)) = 0; + (XW_CLIP_WIDTH (xw)) = x_size; + (XW_CLIP_HEIGHT (xw)) = y_size; + } + (XW_X_CSIZE (xw)) = x_csize; + (XW_Y_CSIZE (xw)) = y_csize; + (XW_CHARACTER_MAP (xw))= new_char_map; + (XW_HIGHLIGHT_MAP (xw))= new_hl_map; + XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + xterm_dump_contents (xw, 0, 0, x_csize, y_csize); + xterm_update_normal_hints (xw); + XFlush (XW_DISPLAY (xw)); + } + return (0); +} + +long +xterm_map_x_coordinate (struct xwindow * xw, int signed_xp) +{ + unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp)); + int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw))); + return (((bx < 0) ? 0 + : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1) + : bx) + / (FONT_WIDTH (XW_FONT (xw)))); +} + +long +xterm_map_y_coordinate (struct xwindow * xw, int signed_yp) +{ + unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp)); + int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw))); + return (((by < 0) ? 0 + : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1) + : by) + / (FONT_HEIGHT (XW_FONT (xw)))); +} + +unsigned long +xterm_map_x_size (struct xwindow * xw, unsigned int width) +{ + int w = (width - (2 * (XW_INTERNAL_BORDER_WIDTH (xw)))); + return ((w < 0) ? 0 : (w / (FONT_WIDTH (XW_FONT (xw))))); +} + +unsigned long +xterm_map_y_size (struct xwindow * xw, unsigned int height) +{ + int h = (height - (2 * (XW_INTERNAL_BORDER_WIDTH (xw)))); + return ((h < 0) ? 0 : (h / (FONT_HEIGHT (XW_FONT (xw))))); +} + +struct xwindow * +xterm_open_window (struct xdisplay * xd, char * geometry, + const char * resource_name, + const char * resource_class, + int map_p) +{ + Display * display = (XD_DISPLAY (xd)); + struct drawing_attributes attributes; + struct xwindow_methods methods; + XSizeHints * size_hints; + int x_pos; + int y_pos; + int x_size; + int y_size; + unsigned int x_csize; + unsigned int y_csize; + Window window; + struct xwindow * xw; + unsigned int map_size; + char * charmap; + char * hlmap; + + if (resource_name == NULL) + resource_name = RESOURCE_NAME; + if (resource_class == NULL) + resource_class = RESOURCE_CLASS; + + if (0 != x_default_attributes (display, resource_name, resource_class, + (&attributes))) + return (NULL); + (methods.deallocator) = xterm_deallocate; + (methods.event_processor) = xterm_process_event; + (methods.x_coordinate_map) = xterm_x_coordinate_map; + (methods.y_coordinate_map) = xterm_y_coordinate_map; + (methods.update_normal_hints) = xterm_update_normal_hints; + + size_hints + = (xterm_make_size_hints ((attributes.font), + (2 * (attributes.internal_border_width)))); + if (size_hints == NULL) + return (NULL); + + XWMGeometry (display, + (DefaultScreen (display)), + ((geometry == NULL) + ? (x_get_default (display, resource_name, resource_class, + "geometry", "Geometry", 0)) + : geometry), + DEFAULT_GEOMETRY, + (attributes.border_width), + size_hints, + (&x_pos), (&y_pos), (&x_size), (&y_size), + (& (size_hints->win_gravity))); + x_csize + = ((x_size - (size_hints->base_width)) / (size_hints->width_inc)); + y_csize + = ((y_size - (size_hints->base_height)) / (size_hints->height_inc)); + + map_size = (x_csize * y_csize); + charmap = (malloc (map_size)); + if (charmap == NULL) + return (NULL); + hlmap = (malloc (map_size)); + if (hlmap == NULL) + { + free (charmap); + return (NULL); + } + + window = (XCreateSimpleWindow + (display, (RootWindow (display, (DefaultScreen (display)))), + x_pos, y_pos, x_size, y_size, + (attributes.border_width), + (attributes.border_pixel), + (attributes.background_pixel))); + if (window == 0) + return (NULL); + + xw = (x_make_window + (xd, + window, + (x_size - (size_hints->base_width)), + (y_size - (size_hints->base_height)), + (&attributes), + (&methods), + (sizeof (struct xwindow_term)))); + (XW_X_CSIZE (xw)) = x_csize; + (XW_Y_CSIZE (xw)) = y_csize; + (XW_CURSOR_X (xw)) = 0; + (XW_CURSOR_Y (xw)) = 0; + (XW_CURSOR_VISIBLE_P (xw)) = 0; + (XW_CURSOR_ENABLED_P (xw)) = 1; + + memset (charmap, BLANK_CHAR, map_size); + (XW_CHARACTER_MAP (xw)) = charmap; + memset (hlmap, DEFAULT_HL, map_size); + (XW_HIGHLIGHT_MAP (xw)) = hlmap; + + (size_hints->flags) |= PWinGravity; + xterm_set_wm_normal_hints (xw, size_hints); + if ((0 != xw_set_wm_input_hint (xw, 1)) + || (0 != xw_set_wm_name (xw, "scheme-terminal")) + || (0 != xw_set_wm_icon_name (xw, "scheme-terminal")) + || (0 != xw_make_window_map (xw, resource_name, resource_class, map_p))) + { + x_close_window (xw); + return (NULL); + } + return (xw); +} + +unsigned int +xterm_x_size (struct xwindow * xw) +{ + return (XW_X_CSIZE (xw)); +} + +unsigned int +xterm_y_size (struct xwindow * xw) +{ + return (XW_Y_CSIZE (xw)); +} + +void +xterm_set_size (struct xwindow * xw, unsigned int width, unsigned int height) +{ + int extra; + XFontStruct * font; + extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); +#ifdef __APPLE__ + extra += 1; +#endif + font = (XW_FONT (xw)); + XResizeWindow + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + ((width * (FONT_WIDTH (font))) + extra), + ((height * (FONT_HEIGHT (font))) + extra)); +} + +void +xterm_enable_cursor (struct xwindow * xw, int enable_p) +{ + (XW_CURSOR_ENABLED_P (xw)) = enable_p; +} + +int +xterm_write_cursor (struct xwindow * xw, unsigned int x, unsigned int y) +{ + if (x >= (XW_X_CSIZE (xw))) + return (1); + if (y >= (XW_Y_CSIZE (xw))) + return (2); + if ((x != (XW_CURSOR_X (xw))) || (y != (XW_CURSOR_Y (xw)))) + { + xterm_erase_cursor (xw); + (XW_CURSOR_X (xw)) = x; + (XW_CURSOR_Y (xw)) = y; + } + xterm_draw_cursor (xw); + return (0); +} + +int +xterm_write_char (struct xwindow * xw, unsigned int x, unsigned int y, + int c, unsigned int hl) +{ + unsigned int index; + char * map_ptr; + + if (x >= (XW_X_CSIZE (xw))) + return (1); + if (y >= (XW_Y_CSIZE (xw))) + return (2); + if (hl >= 2) + return (3); + index = (XTERM_CHAR_INDEX (xw, x, y)); + map_ptr = (XTERM_CHAR_LOC (xw, index)); + (*map_ptr) = c; + (XTERM_HL (xw, index)) = hl; + XTERM_DRAW_CHARS (xw, x, y, map_ptr, 1, (XTERM_HL_GC (xw, hl))); + if (((XW_CURSOR_X (xw)) == x) && ((XW_CURSOR_Y (xw)) == y)) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + return (0); +} + +int +xterm_write_substring (struct xwindow * xw, unsigned int x, unsigned int y, + char * string, unsigned int start, unsigned int end, + unsigned int hl) +{ + unsigned int length, index; + + if (x >= (XW_X_CSIZE (xw))) + return (1); + if (y >= (XW_Y_CSIZE (xw))) + return (2); + if (start >= (end + 1)) + return (3); + if (hl >= 2) + return (4); + + length = (end - start); + index = (XTERM_CHAR_INDEX (xw, x, y)); + if ((x + length) > (XW_X_CSIZE (xw))) + return (5); + { + unsigned char * string_scan = &string[start]; + unsigned char * string_end = &string[end]; + char * char_scan = (XTERM_CHAR_LOC (xw, index)); + char * hl_scan = (XTERM_HL_LOC (xw, index)); + while (string_scan < string_end) + { + (*char_scan++) = (*string_scan++); + (*hl_scan++) = hl; + } + } + XTERM_DRAW_CHARS + (xw, x, y, (XTERM_CHAR_LOC (xw, index)), length, (XTERM_HL_GC (xw, hl))); + if ((x <= (XW_CURSOR_X (xw))) && ((XW_CURSOR_X (xw)) < (x + length)) + && (y == (XW_CURSOR_Y (xw)))) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + return (0); +} + +static void +clear_rectangle (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int hl) +{ + unsigned int x_length = (x_end - x_start); + unsigned int y; + for (y = y_start; (y < y_end); y += 1) + { + unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); + { + char * scan = (XTERM_CHAR_LOC (xw, index)); + char * end = (scan + x_length); + while (scan < end) + (*scan++) = BLANK_CHAR; + } + { + char * scan = (XTERM_HL_LOC (xw, index)); + char * end = (scan + x_length); + while (scan < end) + (*scan++) = hl; + } + } + if (hl != 0) + { + GC hl_gc = (XTERM_HL_GC (xw, hl)); + for (y = y_start; (y < y_end); y += 1) + XTERM_DRAW_CHARS + (xw, x_start, y, + (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y)))), + x_length, hl_gc); + } + else if ((x_start == 0) + && (y_start == 0) + && (x_end == (XW_X_CSIZE (xw))) + && (y_end == (XW_Y_CSIZE (xw)))) + XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + else + XClearArea ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XTERM_X_PIXEL (xw, x_start)), + (XTERM_Y_PIXEL (xw, y_start)), + (x_length * (FONT_WIDTH (XW_FONT (xw)))), + ((y_end - y_start) * (FONT_HEIGHT (XW_FONT (xw)))), + False); +} + +int +xterm_clear_rectangle (struct xwindow * xw, + unsigned int x_start, unsigned int x_end, + unsigned int y_start, unsigned int y_end, + unsigned int hl) +{ + if (((XW_X_CSIZE (xw)) + 1) <= x_end) + return (1); + if (((XW_Y_CSIZE (xw)) + 1) <= y_end) + return (2); + if ((x_end + 1) <= x_start) + return (3); + if ((y_end + 1) <= y_start) + return (4); + if (hl >= 2) + return (5); + if ((x_start < x_end) && (y_start < y_end)) + { + clear_rectangle (xw, x_start, x_end, y_start, y_end, hl); + if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end)) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + } + return (0); +} + +static void +scroll_lines_up (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines) +{ + { + unsigned int y_to = y_start; + unsigned int y_from = (y_to + lines); + while (y_from < y_end) + xterm_copy_map_line (xw, x_start, x_end, (y_from++), (y_to++)); + } + XCopyArea ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (XTERM_X_PIXEL (xw, x_start)), + (XTERM_Y_PIXEL (xw, (y_start + lines))), + ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))), + (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))), + (XTERM_X_PIXEL (xw, x_start)), + (XTERM_Y_PIXEL (xw, y_start))); +} + +int +xterm_scroll_lines_up (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines) +{ + if (x_end >= ((XW_X_CSIZE (xw)) + 1)) + return (1); + if (y_end >= ((XW_Y_CSIZE (xw)) + 1)) + return (2); + if (x_start >= (x_end + 1)) + return (3); + if (y_start >= (y_end + 1)) + return (4); + if (lines >= (y_end - y_start)) + return (5); + if ((0 < lines) && (x_start < x_end) && (y_start < y_end)) + { + if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, (y_start + lines), y_end)) + { + xterm_erase_cursor (xw); + scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines); + xterm_draw_cursor (xw); + } + else + { + scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines); + if (CURSOR_IN_RECTANGLE + (xw, x_start, x_end, y_start, (y_end - lines))) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + } + } +} + +static void +scroll_lines_down (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines) +{ + { + unsigned int y_to = y_end; + unsigned int y_from = (y_to - lines); + while (y_from > y_start) + xterm_copy_map_line (xw, x_start, x_end, (--y_from), (--y_to)); + } + XCopyArea ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_WINDOW (xw)), + (XW_NORMAL_GC (xw)), + (XTERM_X_PIXEL (xw, x_start)), + (XTERM_Y_PIXEL (xw, y_start)), + ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))), + (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))), + (XTERM_X_PIXEL (xw, x_start)), + (XTERM_Y_PIXEL (xw, (y_start + lines)))); +} + +int +xterm_scroll_lines_down (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + unsigned int lines) +{ + if (x_end >= ((XW_X_CSIZE (xw)) + 1)) + return (1); + if (y_end >= ((XW_Y_CSIZE (xw)) + 1)) + return (2); + if (x_start >= (x_end + 1)) + return (3); + if (y_start >= (y_end + 1)) + return (4); + if (lines >= (y_end - y_start)) + return (5); + if ((0 < lines) && (x_start < x_end) && (y_start < y_end)) + { + if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, (y_end - lines))) + { + xterm_erase_cursor (xw); + scroll_lines_down (xw, x_start, x_end, y_start, y_end, lines); + xterm_draw_cursor (xw); + } + else + { + scroll_lines_down (xw, x_start, x_end, y_start, y_end, lines); + if (CURSOR_IN_RECTANGLE + (xw, x_start, x_end, (y_start + lines), y_end)) + { + (XW_CURSOR_VISIBLE_P (xw)) = 0; + xterm_draw_cursor (xw); + } + } + } +} + +int +xterm_save_contents (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + char * contents) +{ + unsigned int x_length; + unsigned int string_length; + + if (x_end >= ((XW_X_CSIZE (xw)) + 1)) + return (1); + if (y_end >= ((XW_Y_CSIZE (xw)) + 1)) + return (2); + if (x_start >= (x_end + 1)) + return (3); + if (y_start >= (y_end + 1)) + return (4); + x_length = (x_end - x_start); + string_length = (2 * x_length * (y_end - y_start)); + + { + char * string_scan = contents; + unsigned int y; + for (y = y_start; (y < y_end); y += 1) + { + unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); + char * char_scan = (XTERM_CHAR_LOC (xw, index)); + char * char_end = (char_scan + x_length); + char * hl_scan = (XTERM_HL_LOC (xw, index)); + while (char_scan < char_end) + { + (*string_scan++) = (*char_scan++); + (*string_scan++) = (*hl_scan++); + } + } + } +} + +int +xterm_restore_contents (struct xwindow * xw, + unsigned int x_start, + unsigned int x_end, + unsigned int y_start, + unsigned int y_end, + char * contents) +{ + unsigned int x_length; + unsigned int string_length; + + if (x_end >= ((XW_X_CSIZE (xw)) + 1)) + return (1); + if (y_end >= ((XW_Y_CSIZE (xw)) + 1)) + return (2); + if (x_start >= (x_end + 1)) + return (3); + if (y_start >= (y_end + 1)) + return (4); + x_length = (x_end - x_start); + string_length = (2 * x_length * (y_end - y_start)); + if (string_length > 0) + { + char * string_scan = contents; + unsigned int y; + for (y = y_start; (y < y_end); y += 1) + { + unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); + char * char_scan = (XTERM_CHAR_LOC (xw, index)); + char * char_end = (char_scan + x_length); + char * hl_scan = (XTERM_HL_LOC (xw, index)); + while (char_scan < char_end) + { + (*char_scan++) = (*string_scan++); + (*hl_scan++) = (*string_scan++); + } + } + xterm_dump_contents (xw, x_start, x_end, y_start, y_end); + } + return (0); +} diff --git a/src/x11/x11term.scm b/src/x11/x11term.scm new file mode 100644 index 000000000..9186734c0 --- /dev/null +++ b/src/x11/x11term.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 + 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. + +|# + +;;;; X11 Terminal interface +;;; package: (x11 terminal) +;;; +;;; These were once primitives created by x11term.c in umodule prx11. + +(C-include "x11") + +(define (xterm-erase-cursor window) + (c-call "xterm_erase_cursor" window)) + +(define (xterm-draw-cursor window) + (c-call "xterm_draw_cursor" window)) + +(define (xterm-dump-rectangle window x y width height) + (c-call "xterm_dump_rectangle" window x y width height)) + +(define (xterm-reconfigure window x-csize y-csize) + (c-call "xterm_reconfigure" window x-csize y-csize)) + +(define (xterm-map-x-coordinate window x) + (c-call "xterm_map_x_coordinate" window x)) + +(define (xterm-map-y-coordinate window y) + (c-call "xterm_map_y_coordinate" window y)) + +(define (xterm-map-x-size window width) + (c-call "xterm_map_x_size" window width)) + +(define (xterm-map-y-size window height) + (c-call "xterm_map_y_size" window height)) + +(define (xterm-open-window display geometry suppress-map) + (receive (name class map?) + (cond ((and (pair? suppress-map) + (string? (car suppress-map)) + (string? (cdr suppress-map))) + (values (car suppress-map) (cdr suppress-map) #t)) + ((and (vector? suppress-map) + (= 3 (vector-length suppress-map)) + (boolean? (vector-ref suppress-map 0)) + (string? (vector-ref suppress-map 1)) + (string? (vector-ref suppress-map 2))) + (values (vector-ref suppress-map 1) + (vector-ref suppress-map 2) + (vector-ref suppress-map 0))) + ((eq? #f suppress-map) + (values #f #f #t)) + (else + (values #f #f #f))) + (let ((window + (c-call "xterm_open_window" (make-alien '(struct |xwindow|)) + display geometry name class (if map? 1 0)))) + (if (alien-null? window) + (error "Could not open xterm:" geometry)) + window))) + +(define (xterm-x-size xterm) + (c-call "xterm_x_size" xterm)) + +(define (xterm-y-size xterm) + (c-call "xterm_y_size" xterm)) + +(define (xterm-set-size xterm width height) + (c-call "xterm_set_size" xterm width height)) + +(define (xterm-enable-cursor window enable?) + (c-call "xterm_enable_cursor" window (if enable? 1 0))) + +(define (xterm-write-cursor! xterm x y) + (let ((code (c-call "xterm_write_cursor" xterm x y))) + (case code + ((1) (error:bad-range-argument x 'xterm-write-cursor!)) + ((2) (error:bad-range-argument y 'xterm-write-cursor!))))) + +(define (xterm-write-char! xterm x y char highlight) + (let ((code (c-call "xterm_write_char" + xterm x y (char->ascii char) highlight))) + (case code + ((1) (error:bad-range-argument x 'xterm-write-char!)) + ((2) (error:bad-range-argument y 'xterm-write-char!)) + ((3) (error:bad-range-argument highlight 'xterm-write-char!))))) + +(define (xterm-write-substring! xterm x y string start end highlight) + (let ((code (c-call "xterm_write_substring" + xterm x y string start end highlight))) + (case code + ((1) (error:bad-range-argument x 'xterm-write-substring!)) + ((2) (error:bad-range-argument y 'xterm-write-substring!)) + ((3) (error:bad-range-argument start 'xterm-write-substring!)) + ((4) (error:bad-range-argument highlight 'xterm-write-substring!)) + ((5) (error:bad-range-argument end 'xterm-write-substring!))))) + +(define (xterm-clear-rectangle! window x-start x-end y-start y-end highlight) + (let ((code (c-call "xterm_clear_rectangle" + window x-start x-end y-start y-end highlight))) + (case code + ((1) (error:bad-range-argument x-end 'xterm-clear-rectangle)) + ((2) (error:bad-range-argument y-end 'xterm-clear-rectangle)) + ((3) (error:bad-range-argument x-start 'xterm-clear-rectangle)) + ((4) (error:bad-range-argument y-start 'xterm-clear-rectangle)) + ((5) (error:bad-range-argument highlight 'xterm-clear-rectangle))))) + +(define (xterm-scroll-lines-up xterm x-start x-end y-start y-end lines) + ;; Scroll the contents of the region up by LINES. + (let ((code (c-call "xterm_scroll_lines_up" + xterm x-start x-end y-start y-end lines))) + (case code + ((1) (error:bad-range-argument x-end 'xterm-scroll-lines-up)) + ((2) (error:bad-range-argument y-end 'xterm-scroll-lines-up)) + ((3) (error:bad-range-argument x-start 'xterm-scroll-lines-up)) + ((4) (error:bad-range-argument y-start 'xterm-scroll-lines-up)) + ((5) (error:bad-range-argument lines 'xterm-scroll-lines-up))))) + +(define (xterm-scroll-lines-down xterm x-start x-end y-start y-end lines) + ;; Scroll the contents of the region down by LINES. + (let ((code (c-call "xterm_scroll_lines_down" + xterm x-start x-end y-start y-end lines))) + (case code + ((1) (error:bad-range-argument x-end 'xterm-scroll-lines-down)) + ((2) (error:bad-range-argument y-end 'xterm-scroll-lines-down)) + ((3) (error:bad-range-argument x-start 'xterm-scroll-lines-down)) + ((4) (error:bad-range-argument y-start 'xterm-scroll-lines-down)) + ((5) (error:bad-range-argument lines 'xterm-scroll-lines-down))))) + +(define (xterm-save-contents xterm x-start x-end y-start y-end) + ;; Get the contents of the terminal screen rectangle as a string. + ;; The string contains alternating (CHARACTER, HIGHLIGHT) pairs. + ;; The pairs are organized in row-major order from (X-START, Y-START). + (let* ((string (make-string (* 2 + (- x-end x-start) + (- y-end y-start)))) + (code (c-call "xterm_save_contents" + xterm x-start x-end y-start y-end string))) + (case code + ((1) (error:bad-range-argument x-end 'xterm-save-contents)) + ((2) (error:bad-range-argument y-end 'xterm-save-contents)) + ((3) (error:bad-range-argument x-start 'xterm-save-contents)) + ((4) (error:bad-range-argument y-start 'xterm-save-contents))))) + +(define (xterm-restore-contents xterm x-start x-end y-start y-end contents) + ;; Replace the terminal screen rectangle with CONTENTS. + ;; See `XTERM-SCREEN-CONTENTS' for the format of CONTENTS. + (if (not (= (string-length string) + (* 2 + (- x-end x-start) + (- y-end y-start)))) + (error:bad-range-argument contents 'xterm-restore-contents)) + (let ((code (c-call "xterm_restore_contents" + xterm x-start x-end y-start y-end contents))) + (case code + ((1) (error:bad-range-argument x-end 'xterm-restore-contents)) + ((2) (error:bad-range-argument y-end 'xterm-restore-contents)) + ((3) (error:bad-range-argument x-start 'xterm-restore-contents)) + ((4) (error:bad-range-argument y-start 'xterm-restore-contents))))) \ No newline at end of file