--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: key-w32.scm,v 1.1 1994/10/25 01:46:12 adams Exp $
+;;;
+;;; Copyright (c) 1991-1992 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Windows Keys
+;;; Package: (edwin win32-keys)
+
+(declare (usual-integrations))
+
+;; This constructs a vector mapping VK_* codes (integers 0..255) to special key
+;; names (symbols).
+;; It doesn not include keys that are affected by the Win32 API TranslateMessage,
+;; which are: any printing character, backspace, enter, escape, tab
+
+(let-syntax
+ ((make-translation-vector
+ (lambda ()
+ (let ((v (make-vector 256 #F)))
+ (for-each (lambda (def)
+ (if (not (null? (cddr def)))
+ (vector-set! v (second def) (third def))))
+ '(;;VK_name code special-key name
+ (VK_LBUTTON #x01)
+ (VK_RBUTTON #x02)
+ (VK_CANCEL #x03)
+ (VK_MBUTTON #x04)
+
+ (VK_BACK #x08)
+ (VK_TAB #x09)
+
+ (VK_CLEAR #x0C)
+ (VK_RETURN #x0D)
+
+ (VK_SHIFT #x10)
+ (VK_CONTROL #x11)
+ (VK_MENU #x12)
+ (VK_PAUSE #x13 stop)
+ (VK_CAPITAL #x14)
+
+ (VK_ESCAPE #x1B)
+
+ (VK_SPACE #x20)
+ (VK_PRIOR #x21 prior)
+ (VK_NEXT #x22 next)
+ (VK_END #x23 end)
+ (VK_HOME #x24 home)
+ (VK_LEFT #x25 left)
+ (VK_UP #x26 up)
+ (VK_RIGHT #x27 right)
+ (VK_DOWN #x28 down)
+ (VK_SELECT #x29 select)
+ (VK_PRINT #x2A print)
+ (VK_EXECUTE #x2B)
+ (VK_SNAPSHOT #x2C)
+ (VK_INSERT #x2D insertchar)
+ (VK_DELETE #x2E deletechar)
+ (VK_HELP #x2F)
+
+ (VK_NUMPAD0 #x60)
+ (VK_NUMPAD1 #x61)
+ (VK_NUMPAD2 #x62)
+ (VK_NUMPAD3 #x63)
+ (VK_NUMPAD4 #x64)
+ (VK_NUMPAD5 #x65)
+ (VK_NUMPAD6 #x66)
+ (VK_NUMPAD7 #x67)
+ (VK_NUMPAD8 #x68)
+ (VK_NUMPAD9 #x69)
+ (VK_MULTIPLY #x6A)
+ (VK_ADD #x6B)
+ (VK_SEPARATOR #x6C)
+ (VK_SUBTRACT #x6D)
+ (VK_DECIMAL #x6E)
+ (VK_DIVIDE #x6F)
+ (VK_F1 #x70 f1)
+ (VK_F2 #x71 f2)
+ (VK_F3 #x72 f3)
+ (VK_F4 #x73 f4)
+ (VK_F5 #x74 f5)
+ (VK_F6 #x75 f6)
+ (VK_F7 #x76 f7)
+ (VK_F8 #x77 f8)
+ (VK_F9 #x78 f9)
+ (VK_F10 #x79 f10)
+ (VK_F11 #x7A f11)
+ (VK_F12 #x7B f12)
+ (VK_F13 #x7C f13)
+ (VK_F14 #x7D f14)
+ (VK_F15 #x7E f15)
+ (VK_F16 #x7F f16)
+ (VK_F17 #x80 f17)
+ (VK_F18 #x81 f18)
+ (VK_F19 #x82 f19)
+ (VK_F20 #x83 f20)
+ (VK_F21 #x84 f21)
+ (VK_F22 #x85 f22)
+ (VK_F23 #x86 f23)
+ (VK_F24 #x87 f24)
+
+ (VK_NUMLOCK #x90)
+ (VK_SCROLL #x91)
+
+ (VK_LSHIFT #xA0)
+ (VK_RSHIFT #xA1)
+ (VK_LCONTROL #xA2)
+ (VK_RCONTROL #xA3)
+ (VK_LMENU #xA4)
+ (VK_RMENU #xA5)
+
+ (VK_ATTN #xF6)
+ (VK_CRSEL #xF7)
+ (VK_EXSEL #xF8)
+ (VK_EREOF #xF9)
+ (VK_PLAY #xFA)
+ (VK_ZOOM #xFB)
+ (VK_NONAME #xFC)
+ (VK_PA1 #xFD)
+ (VK_OEM_CLEAR #xFE)))
+ v))))
+
+ (define win32-key-translation-vector (make-translation-vector)))
+
+(define (vk-code->name vk-code)
+ (vector-ref win32-key-translation-vector vk-code))
+
+(define (win32-make-special-key keysym bucky-bits)
+ (cond ((vk-code->name keysym)
+ => (lambda (name)
+ (make-special-key name bucky-bits)))
+ (else #F)))
+
+(define end)
+
+(define (initialize-package!)
+ (set! end (make-special-key 'end 0))
+ unspecific)
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: key-x11.scm,v 1.1 1994/10/25 01:46:12 adams Exp $
+;;;
+;;; Copyright (c) 1991-1992 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Keys
+;;; Package: (edwin x-keys)
+
+(declare (usual-integrations))
+
+;; 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)))
+
+(define (keysym->name keysym)
+ (cdr
+ (vector-binary-search x-key-translation-table
+ (lambda (u v) (< u v))
+ (lambda (pair) (car pair))
+ keysym)))
+
+(define (x-make-special-key keysym bucky-bits)
+ (make-special-key
+ (or (keysym->name keysym)
+ (editor-error "Keysym not registered" keysym))
+ bucky-bits))
+
+(define (hook/make-special-key/x name bucky-bits)
+ (intern-special-key name bucky-bits))
+
+(define (initialize-package!)
+ (set! hook/make-special-key hook/make-special-key/x))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: mousecom.scm,v 1.1 1994/10/25 01:46:12 adams Exp $
+;;;
+;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;;
+;;;; Mouse Commands
+
+(define-command mouse-select
+ "Select window the mouse is on."
+ ()
+ (lambda ()
+ (select-window (button-event/window (current-button-event)))))
+
+(define-command mouse-keep-one-window
+ "Select window mouse is on, then kill all other windows."
+ ()
+ (lambda ()
+ ((ref-command mouse-select))
+ ((ref-command delete-other-windows))))
+
+(define-command mouse-select-and-split
+ "Select window mouse is on, then split it vertically in half."
+ ()
+ (lambda ()
+ ((ref-command mouse-select))
+ ((ref-command split-window-vertically) false)))
+
+(define-command mouse-set-point
+ "Select window mouse is on, and move point to mouse position."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (let ((window (button-event/window button-event)))
+ (select-window window)
+ (set-current-point!
+ (or (window-coordinates->mark window
+ (button-event/x button-event)
+ (button-event/y button-event))
+ (buffer-end (window-buffer window))))))))
+
+(define-command mouse-set-mark
+ "Select window mouse is on, and set mark at mouse position.
+Display cursor at that position for a second."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (let ((window (button-event/window button-event)))
+ (select-window window)
+ (let ((mark
+ (or (window-coordinates->mark window
+ (button-event/x button-event)
+ (button-event/y button-event))
+ (buffer-end (window-buffer window)))))
+ (push-current-mark! mark)
+ (mark-flash mark))))))
+
+(define-command mouse-show-event
+ "Show the mouse position in the minibuffer."
+ ()
+ (lambda ()
+ (let ((button-event (current-button-event)))
+ (message "window: " (button-event/window button-event)
+ " x: " (button-event/x button-event)
+ " y: " (button-event/y button-event)))))
+
+(define-command mouse-ignore
+ "Don't do anything."
+ ()
+ (lambda () unspecific))
+
+(define button1-down (make-down-button 0))
+(define button2-down (make-down-button 1))
+(define button3-down (make-down-button 2))
+(define button4-down (make-down-button 3))
+(define button5-down (make-down-button 4))
+(define button1-up (make-up-button 0))
+(define button2-up (make-up-button 1))
+(define button3-up (make-up-button 2))
+(define button4-up (make-up-button 3))
+(define button5-up (make-up-button 4))
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: win32.scm,v 1.1 1994/10/25 01:46:12 adams Exp $
+;;;
+;;; Copyright (c) 1989-93 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;;Win32 Terminal
+;;; package (edwin screen win32)
+\f
+(declare (usual-integrations))
+
+(define-primitives
+ (nt-get-event 1)
+ (nt-peek-event 1)
+ (prim-win32-screen/clear-rectangle 6)
+ (prim-win32-screen/discard 1)
+ (prim-win32-screen/invalidate-rect 5)
+ (prim-win32-screen/vertical-scroll 6)
+ (prim-win32-screen/screen-writechar 5)
+ (prim-win32-screen/screen-move-cursor 3)
+ (prim-win32-screen/screen-x-size 1)
+ (prim-win32-screen/screen-y-size 1)
+ (prim-win32-screen/create-screen 3)
+ (prim-win32-screen/write-substring 7)
+ (prim-win32-screen/show-cursor 2))
+
+(define-integrable event:process-output 16)
+(define-integrable event:process-status 32)
+(define-integrable event:inferior-thread-output 64)
+
+(define win32-screens '())
+
+(define-structure (win32-screen-state
+ (constructor make-win32-screen-state (handle))
+ (conc-name win32-screen-state/))
+ (handle false read-only true)
+ (cursor-x 0) ; cached position, -1 if we dont know
+ (cursor-y 0) ; ditto
+ ;; This rect is the bounding box of a sequence of updates. RECT-TOP is #F
+ ;; if no box has been established.
+ (rect-top #F)
+ (rect-bottom 0)
+ (rect-right 0)
+ (rect-left 0)
+ (update? false)
+ (state 'OPEN))
+
+
+(define (make-win32-screen handle)
+ (let ((screen
+ (make-screen (make-win32-screen-state handle)
+ win32-screen/beep
+ win32-screen/clear-line!
+ win32-screen/clear-rectangle!
+ win32-screen/clear-screen!
+ win32-screen/discard!
+ win32-screen/enter!
+ win32-screen/exit!
+ win32-screen/flush!
+ win32-screen/modeline-event!
+ false
+ win32-screen/scroll-lines-down!
+ win32-screen/scroll-lines-up!
+ win32-screen/wrap-update!
+ win32-screen/write-char!
+ win32-screen/write-cursor!
+ win32-screen/write-substring!
+ 8
+ (prim-win32-screen/screen-x-size handle)
+ (prim-win32-screen/screen-y-size handle))))
+ (set! win32-screens (cons screen win32-screens))
+ screen))
+
+(define (win32-screen/beep screen)
+ screen
+ (message-beep -1))
+
+
+(define-integrable (set-rect! state top bottom left right)
+ (set-win32-screen-state/rect-top! state top)
+ (set-win32-screen-state/rect-bottom! state bottom)
+ (set-win32-screen-state/rect-left! state left)
+ (set-win32-screen-state/rect-right! state right))
+
+(define (expand-rect screen top bottom left right)
+ ;; Defined here because the system ones are not integrated:
+ (define-integrable (min u v) (if (fix:< u v) u v))
+ (define-integrable (max u v) (if (fix:> u v) u v))
+ (let ((state (screen-state screen)))
+ (if (win32-screen-state/rect-top state)
+ (set-rect! state
+ (min top (win32-screen-state/rect-top state))
+ (max bottom (win32-screen-state/rect-bottom state))
+ (min left (win32-screen-state/rect-left state))
+ (max right (win32-screen-state/rect-right state)))
+ (set-rect! state top bottom left right))))
+
+
+(define (flush-invalid-region screen)
+ (let ((state (screen-state screen)))
+ (if (win32-screen-state/rect-top state)
+ (begin
+ (prim-win32-screen/invalidate-rect
+ (win32-screen->handle screen)
+ (win32-screen-state/rect-top state)
+ (+ (win32-screen-state/rect-bottom state) 1)
+ (win32-screen-state/rect-left state)
+ (+ (win32-screen-state/rect-right state) 1))
+ (set-win32-screen-state/update?! state #f)))))
+
+
+(define-integrable (set-screen-cursor-position! screen x y)
+ (set-win32-screen-state/cursor-x! (screen-state screen) x)
+ (set-win32-screen-state/cursor-y! (screen-state screen) y))
+
+
+(define (win32-screen/clear-line! screen x y first-unused-x)
+ (prim-win32-screen/clear-rectangle (win32-screen->handle screen)
+ x first-unused-x y (fix:1+ y)
+ 0))
+
+(define (win32-screen/clear-rectangle! screen xl xu yl yu highlight)
+ (prim-win32-screen/clear-rectangle (win32-screen->handle screen)
+ xl xu yl yu
+ (if highlight 1 0)))
+
+(define (win32-screen/clear-screen! screen)
+ (prim-win32-screen/clear-rectangle (win32-screen->handle screen)
+ 0 (win32-x-size screen)
+ 0 (win32-y-size screen)
+ 0))
+
+(define (win32-screen/discard! screen)
+ (set! win32-screens (delq screen win32-screens))
+ (destroy-window (win32-screen->handle screen)))
+
+(define (win32-screen/enter! screen)
+ (set-screen-cursor-position! screen -1 -1)
+ (prim-win32-screen/show-cursor (win32-screen->handle screen) #T))
+
+(define (win32-screen/exit! screen)
+ screen
+ unspecific)
+
+(define (win32-screen/flush! screen)
+ screen
+ unspecific)
+
+(define (win32-screen/modeline-event! screen window type)
+ window type screen)
+
+(define (win32-screen/scroll-lines-down! screen xl xu yl yu amount)
+ (and #F
+ (prim-win32-screen/vertical-scroll (win32-screen->handle screen)
+ xl xu yl yu (+ yl amount))))
+
+(define (win32-screen/scroll-lines-up! screen xl xu yl yu amount)
+ (and #F
+ (prim-win32-screen/vertical-scroll (win32-screen->handle screen)
+ xl xu amount yu 0)
+ (prim-win32-screen/vertical-scroll (win32-screen->handle screen)
+ xl xu yl yu (- yl amount))))
+
+
+(define (win32-screen/wrap-update! screen thunk)
+ (let ((finished? false))
+ (dynamic-wind
+ (lambda ()
+ (prim-win32-screen/show-cursor (win32-screen->handle screen) #F)
+ (set-win32-screen-state/rect-top! (screen-state screen) #F))
+ (lambda ()
+ (let ((result (thunk)))
+ (set! finished? result)
+ result))
+ (lambda ()
+ (if finished?
+ (begin
+ (prim-win32-screen/show-cursor (win32-screen->handle screen) #T)))
+ (if (win32-screen-state/update? (screen-state screen))
+ (flush-invalid-region screen))))))
+
+(define (win32-screen/write-char! screen x y char highlight)
+ (prim-win32-screen/screen-writechar (win32-screen->handle screen) x y
+ (char->integer char)
+ (if highlight 1 0))
+ (if (char-graphic? char)
+ (set-screen-cursor-position! screen (+ x 1) y)
+ (set-screen-cursor-position! screen -1 -1)))
+
+(define (win32-screen/write-substring! screen x y string start end highlight)
+ (if (= start end) '()
+ (begin
+ (prim-win32-screen/write-substring
+ (win32-screen->handle screen) x y string start end
+ (if highlight 1 0))
+ (win32-screen/write-cursor! screen (+ x (- end start)) y)
+ (expand-rect screen x (+ x (- end start)) y y)
+ (set-win32-screen-state/update?! (screen-state screen) #t))))
+
+
+;;(define (win32-screen/write-cursor! screen x y)
+;; (begin
+;; (prim-win32-screen/screen-move-cursor (win32-screen->handle screen) x y)
+;; (set-screen-cursor-position! screen x y)))
+
+(define (win32-screen/write-cursor! screen x y)
+ (let ((state (screen-state screen)))
+ (if (or (not (= (win32-screen-state/cursor-x state) x))
+ (not (= (win32-screen-state/cursor-y state) y)))
+ (let ((handle (win32-screen->handle screen)))
+ (prim-win32-screen/screen-move-cursor handle x y)
+ (set-screen-cursor-position! screen x y)
+ (prim-win32-screen/invalidate-rect handle x (+ x 1) y (+ y 1))))))
+
+
+(define (win32-x-size screen)
+ (prim-win32-screen/screen-x-size (win32-screen->handle screen)))
+
+(define (win32-y-size screen)
+ (prim-win32-screen/screen-y-size (win32-screen->handle screen)))
+
+(define-integrable (win32-key-event? event)
+ (and (vector? event)
+ (fix:= (vector-ref event 0) 2)))
+
+(define (win32-mouse-event? event)
+ (and (vector? event)
+ (fix:= (vector-ref event 0) 4)))
+
+(define-integrable (win32-resize-event? event)
+ (and (vector? event)
+ (fix:= (vector-ref event 0) 1)))
+
+(define-integrable (change-event? event)
+ (fix:fixnum? event))
+
+(define-integrable (win32-close-event? event)
+ (and (vector? event)
+ (fix:= (vector-ref event 0) 8)))
+
+(define (win32-screen->handle screen)
+ (if (memq screen win32-screens)
+ (win32-screen-state/handle (screen-state screen))
+ (let ((window (prim-win32-screen/create-screen
+ 0 2751 (get-handle 1))))
+ (set-window-text window "Edwin")
+ (make-win32-screen window)
+ window)))
+
+(define win32-display-type)
+
+(define (initialize-package!)
+ (set! win32-display-type
+ (make-display-type 'win32
+ true
+ true
+ (lambda geometry
+ geometry
+ (let ((window (prim-win32-screen/create-screen
+ 0 2751 (get-handle 1))))
+ (set-window-text window "Edwin")
+ (make-win32-screen window)))
+ get-win32-input-operations
+ with-editor-interrupts-from-win32
+ with-win32-interrupts-enabled
+ with-win32-interrupts-disabled))
+ unspecific)
+
+(define (with-editor-interrupts-from-win32 receiver)
+ (fluid-let ((signal-interrupts? #t))
+ (dynamic-wind
+ (lambda () '())
+ (lambda () (receiver (lambda (thunk) (thunk)) '()))
+ (lambda () '()))))
+
+(define (with-win32-interrupts-enabled thunk)
+ (with-signal-interrupts true thunk))
+
+(define (with-win32-interrupts-disabled thunk)
+ (with-signal-interrupts false 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))
+
+(define signal-interrupts? #f)
+
+(define-integrable (some-bits? mask item) (not (fix:= 0 (fix:and mask item))))
+
+(define (process-mouse-event screen event)
+ screen
+ (make-input-event 'BUTTON
+ execute-button-command
+ screen
+ ((if (= (vector-ref event 5) 0)
+ make-down-button
+ make-up-button)
+ (cond ((some-bits? #x1 (vector-ref event 4)) 0)
+ ((some-bits? #x2 (vector-ref event 4)) 2)
+ ((some-bits? #x4 (vector-ref event 4)) 1)
+ (else 0)))
+ (vector-ref event 2)
+ (vector-ref event 1)))
+
+(define (process-resize-event screen event)
+ event
+ (set-screen-size! screen
+ (win32-x-size screen)
+ (win32-y-size screen))
+ (update-screen! screen #f)
+ #f)
+
+(define (process-close-event screen event)
+ event
+ (and (not (screen-deleted? screen))
+ (make-input-event 'DELETE-SCREEN delete-screen! screen)))
+
+
+(define (give-up-time-slice!)
+ (if (other-running-threads?)
+ (yield-current-thread) ; yield to scheme threads
+ (sleep 1))) ; ... or to win32 threads
+
+;;(define (win32-char event)
+;; (let ((key (vector-ref event 5))
+;; (cont-state (vector-ref event 4)))
+;; (cond ((not (fix:= (fix:and cont-state 514) 0))
+;; (char-metafy (integer->char key)))
+;; ((and (not (fix:= (fix:and cont-state 514) 0))
+;; (fix:= (fix:and cont-state 8) 8))
+;; (char-control-metafy (integer->char key)))
+;; ((fix:= (fix:and cont-state 8) 8)
+;; (integer->char key))
+;; (else
+;; (integer->char key)))))
+
+
+(define (process-key-event event)
+ (let* ((key (vector-ref event 5))
+ (cont-state (vector-ref event 4))
+ (alt? (some-bits? #x1 cont-state))
+ (control? (some-bits? #x2 cont-state))
+ (shift? (some-bits? #x4 cont-state)))
+ (let ((result
+ (cond ((fix:= key -1)
+ (let ((vk-code (vector-ref event 2))
+ (bucky-bits
+ (+ (if alt? 1 0) ; M-
+ (if control? 2 0) ; C-
+ (if shift? 4 0) ; S-
+ )))
+ (win32-make-special-key vk-code bucky-bits)))
+ ((and control? alt?)
+ (char-control-metafy (integer->char key)))
+ (alt?
+ (char-metafy (integer->char key)))
+ ;;((and control? (eq? key 32))
+ ;; #\c-space)
+ (control?
+ (char-controlify (integer->char key)))
+ (else
+ (integer->char key)))))
+ ;;(frob-trace (with-output-to-string
+ ;; (lambda ()
+ ;; (display event)
+ ;; (display " ")
+ ;; (display `((m ,alt?) (c ,control?) (s ,shift?)))
+ ;; (display "\r\n=> ")
+ ;; (write result))))
+ result)))
+
+
+(define (get-win32-input-operations screen)
+ (let ((screen-handle (win32-screen->handle screen))
+ (pending-result #F))
+ (let* ((read-event
+ (lambda (block?)
+ (let ((event (read-event-1 screen-handle block?)))
+ event)))
+
+ (process-event
+ (lambda (event)
+ (cond ((win32-key-event? event)
+ (let ((key (process-key-event event)))
+ (if (and signal-interrupts?
+ (eq? key #\BEL))
+ (begin
+ (signal-interrupt!)
+ #f)
+ key)))
+ ((win32-mouse-event? event)
+ (process-mouse-event screen event))
+ ((win32-resize-event? event)
+ (process-resize-event screen event))
+ ((win32-close-event? event)
+ (process-close-event screen event))
+ (else #f))))
+
+ (get-next-event
+ (lambda (block?)
+ (let loop ()
+ (let ((event (read-event block?)))
+ (cond ((not event)
+ #F)
+ ((change-event? event)
+ (let ((flag (process-change-event event)))
+ (if flag
+ (pce-event flag)
+ (loop))))
+ (else
+ (or (process-event event)
+ (loop))))))))
+
+ (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"))))
+
+ (halt-update?
+ (lambda ()
+ (or pending-result
+ (probe 'IN-UPDATE))))
+ (peek-no-hang
+ (lambda ()
+ (or pending-result
+ (probe #F))))
+ (peek
+ (lambda ()
+ (or pending-result
+ (let ((result (guarantee-result)))
+ (set! pending-result result)
+ result))))
+ (read
+ (lambda ()
+ (cond (pending-result
+ => (lambda (result)
+ (set! pending-result #F)
+ result))
+ (else
+ (guarantee-result))))))
+
+ (values halt-update?
+ peek-no-hang
+ peek
+ read))))
+
+
+(define (read-event-1 screen-handle block?)
+ (let loop ()
+ (let ((interrupt-mask (set-interrupt-enables! 5 #|interrupt-mask/gc-ok|# )))
+ (if (eq? block? 'IN-UPDATE)
+ (let ((result (nt-get-event screen-handle)))
+ (set-interrupt-enables! interrupt-mask)
+ result)
+ (cond (inferior-thread-changes?
+ (set-interrupt-enables! interrupt-mask)
+ event:inferior-thread-output)
+ ((process-output-available?)
+ (set-interrupt-enables! interrupt-mask)
+ event:process-output)
+ ((process-status-changes?)
+ (set-interrupt-enables! interrupt-mask)
+ event:process-status)
+ (else
+ (let ((result (nt-get-event screen-handle)))
+ (set-interrupt-enables! interrupt-mask)
+ ;; in lieu of blocking we give up our timeslice.
+ (if (and (not result)
+ block?)
+ (begin
+ (give-up-time-slice!)
+ (loop))
+ result))))))))
+
+(define (pce-event flag)
+ (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE)
+ update-screens!
+ #f))
+
+
+(define (process-change-event event)
+ (cond ((fix:= event event:process-output) (accept-process-output))
+ ((fix:= event event:process-status) (handle-process-status-changes))
+ ((fix:= event event:inferior-thread-output) (accept-thread-output))
+ (else (error "Illegal change event:" event))))
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: win32com.scm,v 1.1 1994/10/25 01:46:12 adams Exp $
+;;;
+;;; Copyright (c) 1994 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;;
+
+;;; package (edwin win-commands)
+
+;;; Win32 commands
+
+(declare (usual-integrations))
+
projects / mit-scheme.git / commitdiff