+++ /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,
- 2017, 2018 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
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 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-primitives
- (x-list-fonts 3)
- (x-set-default-font 2)
- (x-window-clear 1)
- (x-window-get-position 1)
- (x-window-get-size 1)
- (x-window-lower 1)
- (x-window-raise 1)
- (x-window-set-background-color 2)
- (x-window-set-border-color 2)
- (x-window-set-border-width 2)
- (x-window-set-cursor-color 2)
- (x-window-set-font 2)
- (x-window-set-foreground-color 2)
- (x-window-set-internal-border-width 2)
- (x-window-set-mouse-color 2)
- (x-window-set-mouse-shape 2)
- (x-window-set-position 3)
- (x-window-set-size 3)
- (x-window-x-size 1)
- (x-window-y-size 1)
- (xterm-reconfigure 3)
- (xterm-set-size 3)
- (xterm-x-size 1)
- (xterm-y-size 1))
-
-(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 'edwin-command$x- name)
- ,(close-syntax (symbol '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-syntax define-old-screen-command
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(define ,(symbol 'edwin-variable$x-screen- name)
- ,(close-syntax (symbol 'edwin-variable$frame- name)
- environment))))))
-
-(define-old-screen-command icon-name-format)
-(define-old-screen-command 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
(declare (usual-integrations))
\f
-(define-primitives
- (x-change-property 7)
- (x-close-all-displays 0)
- (x-close-display 1)
- (x-close-window 1)
- (x-convert-selection 6)
- (x-delete-property 3)
- (x-display-descriptor 1)
- (x-display-flush 1)
- (x-display-get-default 3)
- (x-display-get-size 2)
- (x-display-process-events 2)
- (x-display-sync 2)
- (x-get-atom-name 2)
- (x-get-selection-owner 2)
- (x-get-window-property 7)
- (x-intern-atom 3)
- (x-max-request-size 1)
- (x-open-display 1)
- (x-select-input 3)
- (x-send-selection-notify 6)
- (x-set-selection-owner 4)
- (x-window-andc-event-mask 2)
- (x-window-beep 1)
- (x-window-display 1)
- (x-window-flush 1)
- (x-window-id 1)
- (x-window-map 1)
- (x-window-or-event-mask 2)
- (x-window-raise 1)
- (x-window-set-event-mask 2)
- (x-window-set-icon-name 2)
- (x-window-set-input-focus 2)
- (x-window-set-name 2)
- (xterm-clear-rectangle! 6)
- (xterm-draw-cursor 1)
- (xterm-dump-rectangle 5)
- (xterm-enable-cursor 2)
- (xterm-erase-cursor 1)
- (xterm-map-x-coordinate 2)
- (xterm-map-x-size 2)
- (xterm-map-y-coordinate 2)
- (xterm-map-y-size 2)
- (xterm-open-window 3)
- (xterm-reconfigure 3)
- (xterm-restore-contents 6)
- (xterm-save-contents 5)
- (xterm-scroll-lines-down 6)
- (xterm-scroll-lines-up 6)
- (xterm-set-size 3)
- (xterm-write-char! 5)
- (xterm-write-cursor! 3)
- (xterm-write-substring! 7)
- (xterm-x-size 1)
- (xterm-y-size 1))
-\f
-;; These constants must match "microcode/x11base.c"
-(define-integrable event:process-output -2)
-(define-integrable event:process-status -3)
-(define-integrable event:inferior-thread-output -4)
-(define-integrable event-type:button-down 0)
-(define-integrable event-type:button-up 1)
-(define-integrable event-type:configure 2)
-(define-integrable event-type:enter 3)
-(define-integrable event-type:focus-in 4)
-(define-integrable event-type:focus-out 5)
-(define-integrable event-type:key-press 6)
-(define-integrable event-type:leave 7)
-(define-integrable event-type:motion 8)
-(define-integrable event-type:expose 9)
-(define-integrable event-type:delete-window 10)
-(define-integrable event-type:map 11)
-(define-integrable event-type:unmap 12)
-(define-integrable event-type:take-focus 13)
-(define-integrable event-type:visibility 14)
-(define-integrable event-type:selection-clear 15)
-(define-integrable event-type:selection-notify 16)
-(define-integrable event-type:selection-request 17)
-(define-integrable event-type:property-notify 18)
-(define-integrable number-of-event-types 19)
-
-;; This mask contains button-down, button-up, configure, focus-in,
-;; key-press, expose, destroy, map, unmap, visibility,
-;; selection-clear, selection-notify, selection-request, and
-;; property-notify.
-(define-integrable event-mask #x7de57)
-
-(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))
+;;;; An X display type that autoloads the x11-screen plugin.
+
+(define x-display-type
+ (make-display-type
+ 'X #t
+ (named-lambda (x11-screen-available?)
+ (and (let ((display (get-environment-variable "DISPLAY")))
+ (and (string? display)
+ (not (string-null? display))))
+ (let ((dirpath (system-library-directory-pathname "x11-screen/")))
+ (and dirpath
+ (file-directory? dirpath)))))
+ (named-lambda (make-x11-screen #!optional geometry)
+ (load-option-quietly 'x11-screen)
+ (make-xterm-screen geometry))
+ (named-lambda (get-x11-screen-input-operations screen)
+ screen
+ (get-xterm-input-operations))
+ (named-lambda (with-x11-display-grabbed receiver)
+ (with-editor-interrupts-from-x receiver))
+ (named-lambda (with-x11-interrupts-enabled thunk)
+ (with-x-interrupts-enabled thunk))
+ (named-lambda (with-x11-interrupts-disabled thunk)
+ (with-x-interrupts-disabled thunk))))
-(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 (eq? 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
+ geometry
+ (error "Not yet autoloaded."))
(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 (msec)
- (let ((timeout (and msec (+ (real-time-clock) msec))))
- (let loop ()
- (let ((event (read-event queue display timeout)))
- (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 (msec)
- (let ((result (get-next-event msec)))
- (if result
- (set! pending-result result))
- result))))
- (values
- (lambda () ;halt-update?
- (or (fix:< start end)
- (not (queue-empty? queue))))
- (lambda (msec) ;peek-no-hang
- (or pending-result
- (and (fix:< start end)
- (string-ref string start))
- (probe msec)))
- (lambda () ;peek
- (or pending-result
- (and (fix:< start end)
- (string-ref string start))
- (probe #f)))
- (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
- (or (get-next-event #f)
- (error "#F returned from blocking read"))))))))))))
-\f
-(define (read-event queue display timeout)
- (let* ((empty "empty")
- (event* (with-thread-events-blocked
- (lambda ()
- (if (queue-empty? queue)
- empty
- (dequeue!/unsafe queue)))))
- (event (if (eq? event* empty)
- (block-for-event display timeout)
- event*)))
- (if (and event trace-port)
- (write-line event trace-port))
- event))
-
-(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 (block-for-event display timeout)
- display
- (let ((queue x-display-events)
- (output-available? #f)
- (timed-out? #f)
- (thread (current-thread))
- (timer)
- (registrations))
- (let loop ()
- ;; IO events are not delivered when input lingers in port buffers.
- ;; Incrementally drain the port before suspending.
- (set! output-available? (accept-process-output))
-
- (dynamic-wind
- (lambda ()
- (set! timer
- (and timeout
- (register-time-event timeout
- (lambda ()
- (set! timed-out? #t)))))
- (set! registrations
- (if output-available?
- '()
- (register-process-output-events
- thread
- (lambda (mode)
- mode
- (set! output-available? #t))))))
- (lambda ()
- (with-thread-events-blocked
- (lambda ()
-
- ;; Drain X event queue before suspending. Wait-for-event
- ;; and throws from the previewer (aborts) may leave events
- ;; in buffers.
- (let drain ()
- (let ((event (x-display-process-events x-display-data 2)))
- (if event
- (begin (preview-event event queue)
- (drain)))))
-
- (if (and (queue-empty? queue)
- (not output-available?)
- (not timed-out?)
- (not (process-status-changes?))
- (not inferior-thread-changes?))
- (suspend-current-thread)))))
- (lambda ()
- (if (eq? (current-thread) thread)
- (begin
- (if timer (deregister-time-event timer))
- (set! timer)
- (for-each deregister-io-thread-event registrations)
- (set! registrations)))))
-
- (or (with-thread-events-blocked
- (lambda ()
- (and (not (queue-empty? queue))
- (dequeue!/unsafe queue))))
- (cond (timed-out?
- #f)
- ((process-status-changes?)
- event:process-status)
- (output-available?
- event:process-output)
- (inferior-thread-changes?
- event:inferior-thread-output)
- (else
- (loop)))))))
-
-(define (preview-event-stream)
- (with-thread-events-blocked
- (lambda ()
-
- (define (register!)
- (set! previewer-registration
- (register-io-thread-event (x-display-descriptor x-display-data)
- 'READ (current-thread) preview-events))
- unspecific)
-
- (define (preview-events mode)
- mode
- (dynamic-wind
- (lambda () unspecific)
- (lambda ()
- (let loop ()
- (let ((event (x-display-process-events x-display-data 2)))
- (if event
- (begin (preview-event event x-display-events)
- (loop))))))
- (lambda ()
- (if previewer-registration
- (register!)))))
-
- (register!))))
-
-(define (unpreview-event-stream)
- (with-thread-events-blocked
- (lambda ()
- (let ((registration previewer-registration))
- (set! previewer-registration #f)
- (if registration
- (deregister-io-thread-event registration))))))
-
-(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)
- #t)
- ((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))))
-
-;; Note that this handler is run in an interrupt (IO event).
-(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)))))
-
-;; Note that this handler is run in an interrupt (IO event).
-(define-event-handler event-type:unmap
- (lambda (screen event)
- event
- (if (not (screen-deleted? screen))
- (set-screen-mapped?! screen #f))
- #f))
-
-;; Note that this handler is run in an interrupt (IO event).
-(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-ref/default built-in-atoms-table name #f)
- (let ((table (car (display/cached-atoms-tables display))))
- (or (hash-table-ref/default table name #f)
- (let ((atom
- (x-intern-atom display
- (string-upcase (symbol->string name))
- soft?)))
- (if (not (= atom 0))
- (hash-table-set! 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-ref/default 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-set! 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-set! table (vector-ref built-in-atoms i) i))
- table)))
-
-(define display/cached-atoms-tables
- (let ((table (make-key-weak-eq-hash-table)))
- (lambda (display)
- (or (hash-table-ref/default table display #f)
- (let ((result
- (cons (make-strong-eq-hash-table)
- (make-strong-eqv-hash-table))))
- (hash-table-set! 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))))
- (copy!
- (if (= b/w 1)
- string-copy!
- vector-copy!)))
- (let loop ((offset 0) (bytes bytes))
- (if (<= bytes qb)
- (copy! result
- (quotient offset b/w)
- (read-once offset bytes bytes delete?)
- 0
- (quotient bytes b/w))
- (begin
- (copy! result
- (quotient offset b/w)
- (read-once offset bytes qb #f)
- 0
- (quotient qb 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?)
-
-(define (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-set! (display/selection-records display)
- selection
- (make-selection-record window time value))
- #t)))
-
-(define display/selection-records
- (let ((table (make-key-weak-eq-hash-table)))
- (lambda (display)
- (or (hash-table-ref/default table display #f)
- (let ((result (make-strong-eq-hash-table)))
- (hash-table-set! 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-ref/default (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-ref/default records name #f)))
- (and record
- (or (= 0 time) (<= (selection-record/time record) time))))
- (hash-table-delete! 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?)
-
-(define (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 previewer-registration)
-(define ignore-button-state)
+ (error "Not yet autoloaded."))
(define (with-editor-interrupts-from-x receiver)
- (fluid-let ((signal-interrupts? #t)
- (last-focus-time #f)
- (previewer-registration)
- (ignore-button-state #f))
- (dynamic-wind
- preview-event-stream
- (lambda () (receiver (lambda (thunk) (thunk)) '()))
- unpreview-event-stream)))
+ receiver
+ (error "Not yet autoloaded."))
(define (with-x-interrupts-enabled thunk)
- (with-signal-interrupts #t thunk))
+ thunk
+ (error "Not yet autoloaded."))
(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 (begin
- (load-library-object-file "prx11" #f)
- (implemented-primitive-procedure?
- (ucode-primitive x-open-display 1)))
- (or x-display-name (get-environment-variable "DISPLAY"))
- (let ((display
- (x-open-display
- (and x-display-name
- (string-for-primitive 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 'X
- #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)
\ No newline at end of file
+ thunk
+ (error "Not yet autoloaded."))
\ No newline at end of file
projects / mit-scheme.git / commitdiff