--- /dev/null
+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.
--- /dev/null
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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
+\f
+ 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.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
--- /dev/null
+-*-Text-*-
+
+Please see the git commit log:
+
+$ git clone git://git.savannah.gnu.org/mit-scheme.git
+$ git log origin/master -- src/x11-screen/
--- /dev/null
+## 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)"
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+#!/bin/sh
+
+set -e
+autoreconf --force --install
--- /dev/null
+#!/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-time<? "x11-screen.pkg" package-set))
+ (cref/generate-trivial-constructor "x11-screen" #f))
+ (construct-packages-from-file (fasload package-set)))
+
+ (compile-file "x11-screen" '() (->environment '(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
--- /dev/null
+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
--- /dev/null
+#| -*-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))
+\f
+;; 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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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)))
+\f
+(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))))
+\f
+(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))
+\f
+(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)))
+\f
+(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))))
+\f
+(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"))
+\f
+;;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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
--- /dev/null
+#!/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
--- /dev/null
+#| -*-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
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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)
+\f
+(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))
+\f
+;;; 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))))
+\f
+(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)))))
+\f
+(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))
+\f
+;;;; 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)))))))))))
+\f
+(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)))))))
+\f
+(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))))
+\f
+(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)))))))
+\f
+(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)))
+\f
+;;;; 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))
+\f
+(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)))))
+\f
+;;;; 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)))))
+\f
+(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)
+\f
+;;;; 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))
+\f
+(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))
+\f
+(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))
+\f
+;;;; 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))
+\f
+(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)
+\f
+;;;; 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))
+\f
+;;;; 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
--- /dev/null
+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.
--- /dev/null
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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
+\f
+ 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.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
--- /dev/null
+-*-Text-*-
+
+Please see the git commit log:
+
+$ git clone git://git.savannah.gnu.org/mit-scheme.git
+$ git log origin/master -- src/x11/ | more
--- /dev/null
+## 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)"
--- /dev/null
+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...
--- /dev/null
+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.
--- /dev/null
+#!/bin/sh
+
+set -e
+rm -rf m4
+mkdir m4
+autoreconf --force --install -I m4
--- /dev/null
+#!/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
--- /dev/null
+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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+/* -*-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);
+\f
+/* 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);
+\f
+/* 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);
+\f
+/* 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);
--- /dev/null
+#| -*-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.
+\f
+(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)))
+\f
+;;; 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))
+\f
+;;; 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)))
+\f
+;;; 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))
+\f
+;;; 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
--- /dev/null
+/* -*-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 <malloc.h>
+#include <X11/Xlib.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+\f
+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;
+};
+\f
+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);
+\f
+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);
+\f
+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) */
--- /dev/null
+#| -*-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
+\f
+(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
--- /dev/null
+/* -*-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 <stdlib.h>
+#include <string.h>
+#include <setjmp.h>
+#include "x11.h"
+#include <X11/Xmd.h>
+#include <X11/keysym.h>
+
+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 *);
+\f
+/* 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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)));
+}
+\f
+/* 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);
+}
+\f
+/* 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);
+ }
+}
+\f
+/* 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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);
+}
+\f
+/* 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));
+}
+\f
+/* 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)));
+}
+\f
+/* 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);
+}
+\f
+/* 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)));
+}
+\f
+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;
+}
+\f
+/* 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));
+}
+\f
+/* 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));
+}
+\f
+/* 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);
+}
+\f
+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);
+}
+\f
+/* 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)));
+}
--- /dev/null
+#| -*-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)
+ "<unknown>"
+ (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
--- /dev/null
+/* -*-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));
+}
+\f
+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);
+}
+\f
+/* 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);
+}
--- /dev/null
+#| -*-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")
+\f
+;;; 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))))
+\f
+;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+;;;; 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)
+\f
+;;;; 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))
+\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)))
+\f
+(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))
+\f
+(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))
+\f
+;;;; 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))
+ "")))
+\f
+(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))))
+\f
+(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)))
+\f
+(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))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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)))
+\f
+;; 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))
+\f
+;;;; Colormaps
+
+(define-record-type <colormap>
+ (%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))
+\f
+(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
--- /dev/null
+/* -*-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 <float.h>
+#include <limits.h>
+#include <math.h>
+#include <string.h>
+\f
+#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))));
+}
+\f
+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);
+}
+\f
+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)));
+}
+\f
+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);
+}
+\f
+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);
+ }
+ }
+}
+\f
+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;
+}
+\f
+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<x1) { /* x-axis flip */
+ int t=x1; x1=x2; x2=t;
+ if (angle1 < 64*180)
+ angle1 = 64*180 - angle1;
+ else
+ angle1 = 64*540 - angle1;
+ angle2 = -angle2;
+ }
+ if (y2<y1) { /* y-axis flip */
+ int t=y1; y1=y2; y2=t;
+ angle1 = 64*360 - angle1;
+ angle2 = -angle2;
+ }
+ width = x2 - x1;
+ height = y2 - y1;
+ if (!fill_p)
+ XDrawArc
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + x1),
+ (internal_border_width + y1),
+ width, height, angle1, angle2);
+ else
+ XFillArc
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + x1),
+ (internal_border_width + y1),
+ width, height, angle1, angle2);
+}
+\f
+/************** TEST PROGRAM FOR X-GRAPHICS-DRAW-ARC *****************
+(define g (make-graphics-device))
+
+(define (test dx dy a1 a2)
+ (let ((x .3)
+ (y .4)
+ (r .2))
+ (define (fx a) (+ x (* r (cos (* a (asin 1) 1/90)))))
+ (define (fy a) (+ y (* r (sin (* a (asin 1) 1/90)))))
+ (graphics-set-coordinate-limits g (- dx) (- dy) dx dy)
+ (graphics-operation g 'set-foreground-color "black")
+ (graphics-clear g)
+
+ (graphics-draw-text g 0 0 ".")
+
+ (graphics-draw-line g -1 0 1 0)
+ (graphics-draw-line g 0 -1 0 1)
+ (graphics-draw-line g 0 0 1 1)
+ (graphics-draw-text g .5 0 "+X")
+ (graphics-draw-text g -.5 0 "-X")
+ (graphics-draw-text g 0 .5 "+Y")
+ (graphics-draw-text g 0 -.5 "-Y")
+
+ ;; The grey wedge is that that 10 degrees of the arc.
+ (graphics-operation g 'set-foreground-color "grey")
+ (graphics-operation g 'draw-arc x y r r a1 a2 #T)
+ (graphics-operation g 'set-foreground-color "black")
+ (graphics-operation g 'draw-arc x y r r a1 (+ a2 (if (< a2 0) 10 -10)) #T)
+
+ (graphics-operation g 'set-foreground-color "red")
+ (graphics-draw-text g x y ".O")
+
+ (let ((b1 (min a1 (+ a1 a2)))
+ (b2 (max a1 (+ a1 a2))))
+ (do ((a b1 (+ a 5)))
+ ((> 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)
+ ***********************************************************************/
+\f
+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);
+}
+\f
+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);
+ }
+}
+\f
+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);
+}
+\f
+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);
+}
+\f
+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++)));
+}
+\f
+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);
+}
+
+\f
+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)));
+}
--- /dev/null
+#| -*-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")
+\f
+(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
--- /dev/null
+/* -*-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 <string.h>
+#include "x11.h"
+\f
+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
+\f
+#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)
+{
+}
+\f
+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++);
+ }
+}
+\f
+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);
+ }
+ }
+}
+\f
+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));
+}
+\f
+#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);
+}
+\f
+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)))));
+}
+\f
+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);
+}
+\f
+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);
+}
+\f
+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);
+}
+\f
+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);
+}
+\f
+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);
+ }
+ }
+ }
+}
+\f
+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);
+ }
+ }
+ }
+}
+\f
+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);
+}
--- /dev/null
+#| -*-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
projects / mit-scheme.git / commitdiff