From: Stephen Adams Date: Tue, 25 Oct 1994 01:46:12 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~7061 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5a95c663cc6d560acbdb6fbee6b6da0075adcc84;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/key-w32.scm b/v7/src/edwin/key-w32.scm new file mode 100644 index 000000000..65d5471cb --- /dev/null +++ b/v7/src/edwin/key-w32.scm @@ -0,0 +1,171 @@ +;;; -*-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) diff --git a/v7/src/edwin/key-x11.scm b/v7/src/edwin/key-x11.scm new file mode 100644 index 000000000..9c975e7d6 --- /dev/null +++ b/v7/src/edwin/key-x11.scm @@ -0,0 +1,935 @@ +;;; -*-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 diff --git a/v7/src/edwin/mousecom.scm b/v7/src/edwin/mousecom.scm new file mode 100644 index 000000000..6ad6d9c2f --- /dev/null +++ b/v7/src/edwin/mousecom.scm @@ -0,0 +1,114 @@ +;;; -*-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)) diff --git a/v7/src/edwin/win32.scm b/v7/src/edwin/win32.scm new file mode 100644 index 000000000..9448d4d38 --- /dev/null +++ b/v7/src/edwin/win32.scm @@ -0,0 +1,543 @@ +;;; -*-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) + +(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)))) diff --git a/v7/src/edwin/win32com.scm b/v7/src/edwin/win32com.scm new file mode 100644 index 000000000..e6c396802 --- /dev/null +++ b/v7/src/edwin/win32com.scm @@ -0,0 +1,46 @@ +;;; -*-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)) +