/[cmucl]/src/hemlock/key-event.lisp
ViewVC logotype

Contents of /src/hemlock/key-event.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Wed May 8 14:56:40 1996 UTC (17 years, 11 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b, RELEASE_18c
Branch point for: RELENG_18
Changes since 1.3: +11 -2 lines
Patch from Jeurgen Weiss to translate-key-event which makes it deal better with
european keyboards.
1 ;;; -*- Log: hemlock.log; Package: extensions -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/key-event.lisp,v 1.4 1996/05/08 14:56:40 ram Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file implements key-events for representing editor input. It also
13 ;;; provides a couple routines to interface this to X11.
14 ;;;
15 ;;; Written by Blaine Burks and Bill Chiles.
16 ;;;
17
18 ;;; The following are the implementation dependent parts of this code (what
19 ;;; you would have to change if you weren't using X11):
20 ;;; *modifier-translations*
21 ;;; DEFINE-CLX-MODIFIER
22 ;;; TRANSLATE-KEY-EVENT
23 ;;; TRANSLATE-MOUSE-KEY-EVENT
24 ;;; DEFINE-KEYSYM
25 ;;; DEFINE-MOUSE-KEYSYM
26 ;;; DO-ALPHA-KEY-EVENTS
27 ;;; If the window system didn't use a keysym mechanism to represent keys, you
28 ;;; would also need to write something that mapped whatever did encode the
29 ;;; keys to the keysyms defined with DEFINE-KEYSYM.
30 ;;;
31
32 (in-package "EXTENSIONS")
33
34 (export '( define-keysym define-mouse-keysym name-keysym keysym-names
35 keysym-preferred-name define-key-event-modifier define-clx-modifier
36 make-key-event-bits key-event-modifier-mask key-event-bits-modifiers
37 *all-modifier-names* translate-key-event translate-mouse-key-event
38 make-key-event key-event key-event-p key-event-bits key-event-keysym
39 char-key-event key-event-char key-event-bit-p do-alpha-key-events
40 print-pretty-key print-pretty-key-event))
41
42
43
44 ;;;; Keysym <==> Name translation.
45
46 ;;; Keysyms are named by case-insensitive names. However, if the name
47 ;;; consists of a single character, the name is case-sensitive.
48 ;;;
49
50 ;;; This table maps a keysym to a list of names. The first name is the
51 ;;; preferred printing name.
52 ;;;
53 (defvar *keysyms-to-names*)
54
55 ;;; This table maps all keysym names to the appropriate keysym.
56 ;;;
57 (defvar *names-to-keysyms*)
58
59 (proclaim '(inline name-keysym keysym-names keysym-preferred-name))
60
61 (defun name-keysym (name)
62 "This returns the keysym named name. If name is unknown, this returns nil."
63 (gethash (get-name-case-right name) *names-to-keysyms*))
64
65 (defun keysym-names (keysym)
66 "This returns the list of all names for keysym. If keysym is undefined,
67 this returns nil."
68 (gethash keysym *keysyms-to-names*))
69
70 (defun keysym-preferred-name (keysym)
71 "This returns the preferred name for keysym, how it is typically printed.
72 If keysym is undefined, this returns nil."
73 (car (gethash keysym *keysyms-to-names*)))
74
75
76
77 ;;;; Character key-event stuff.
78
79 ;;; GET-NAME-CASE-RIGHT -- Internal.
80 ;;;
81 ;;; This returns the canonical string for a keysym name for use with
82 ;;; hash tables.
83 ;;;
84 (defun get-name-case-right (string)
85 (if (= (length string) 1) string (string-downcase string)))
86
87 ;;; DEFINE-KEYSYM -- Public.
88 ;;;
89 (defun define-keysym (keysym preferred-name &rest other-names)
90 "This establishes a mapping from preferred-name to keysym for purposes of
91 specifying key-events in #k syntax. Other-names also map to keysym, but the
92 system uses preferred-name when printing key-events. The names are
93 case-insensitive simple-strings. Redefining a keysym or re-using names has
94 undefined effects."
95 (setf (gethash keysym *keysyms-to-names*) (cons preferred-name other-names))
96 (dolist (name (cons preferred-name other-names))
97 (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
98
99 ;;; This is an a-list mapping CLX modifier masks to defined key-event
100 ;;; modifier names. DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
101 ;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
102 ;;;
103 (defvar *modifier-translations*)
104
105 ;;; This is an ordered a-list mapping defined key-event modifier names to the
106 ;;; appropriate mask for the modifier. Modifier names have a short and a long
107 ;;; version. For each pair of names for the same mask, the names are
108 ;;; contiguous in this list, and the short name appears first.
109 ;;; PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on this.
110 ;;;
111 (defvar *modifiers-to-internal-masks*)
112
113 ;;; TRANSLATE-KEY-EVENT -- Public.
114 ;;;
115 #+clx
116 (defun translate-key-event (display scan-code bits)
117 "Translates the X scan-code and X bits to a key-event. First this maps
118 scan-code to an X keysym using XLIB:KEYCODE->KEYSYM looking at bits and
119 supplying index as 1 if the X shift bit is on, 0 otherwise.
120
121 If the resulting keysym is undefined, and it is not a modifier keysym, then
122 this signals an error. If the keysym is a modifier key, then this returns
123 nil.
124
125 If the following conditions are satisfied
126 the keysym is defined
127 the X shift bit is off
128 the X lock bit is on
129 the X keysym represents a lowercase letter
130 then this maps the scan-code again supplying index as 1 this time, treating
131 the X lock bit as a caps-lock bit. If this results in an undefined keysym,
132 this signals an error. Otherwise, this makes a key-event with the keysym
133 and bits formed by mapping the X bits to key-event bits.
134
135 If any state bit is set that has no suitable modifier translation, it is
136 passed to XLIB:DEFAULT-KEYSYM-INDEX in order to handle Mode_Switch keys
137 appropriately.
138
139 Otherwise, this makes a key-event with the keysym and bits formed by mapping
140 the X bits to key-event bits."
141 (let ((new-bits 0)
142 shiftp lockp)
143 (dolist (map *modifier-translations*)
144 (unless (zerop (logand (car map) bits))
145 ;; ignore the bits of the mapping for the determination of a key index
146 (setq bits (logxor bits (car map)))
147 (cond
148 ((string-equal (cdr map) "Shift")
149 (setf shiftp t))
150 ((string-equal (cdr map) "Lock")
151 (setf lockp t))
152 (t (setf new-bits
153 (logior new-bits (key-event-modifier-mask (cdr map))))))))
154 ;; here pass any remaining modifier bits to clx
155 (let* ((index (and (not (zerop bits))
156 (xlib:default-keysym-index display scan-code bits)))
157 (keysym (xlib:keycode->keysym display scan-code (or index (if shiftp 1 0)))))
158 (cond ((null (keysym-names keysym))
159 nil)
160 ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
161 (let ((keysym (xlib:keycode->keysym display scan-code 1)))
162 (if (keysym-names keysym)
163 (make-key-event keysym new-bits)
164 nil)))
165 (t
166 (make-key-event keysym new-bits))))))
167
168
169
170 ;;;; Mouse key-event stuff.
171
172 ;;; Think of this data as a three dimensional array indexed by the following
173 ;;; domains:
174 ;;; 1-5
175 ;;; for the mouse scan-codes (button numbers) delivered by X.
176 ;;; :button-press or :button-release
177 ;;; whether the button was pressed or released.
178 ;;; :keysym or :shifted-modifier-name
179 ;;; whether the X shift bit was set.
180 ;;; For each button, pressed and released, we store a keysym to be used in a
181 ;;; key-event representing the button and whether it was pressed or released.
182 ;;; We also store a modifier name that TRANSLATE-MOUSE-KEY-EVENT turns on
183 ;;; whenever a mouse event occurs with the X shift bit on. This is basically
184 ;;; an archaic feature since we now can specify key-events like the following:
185 ;;; #k"shift-leftdown"
186 ;;; Previously we couldn't, so we mapped the shift bit to a bit we could
187 ;;; talke about, such as super.
188 ;;;
189 (defvar *mouse-translation-info*)
190
191 (eval-when (compile eval)
192 (defmacro button-press-info (event-dispatch) `(car ,event-dispatch))
193 (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch))
194 (defmacro button-keysym (info) `(car ,info))
195 (defmacro button-shifted-modifier-name (info) `(cdr ,info))
196 ) ;eval-when
197
198 ;;; MOUSE-TRANSLATION-INFO -- Internal.
199 ;;;
200 ;;; This returns the requested information, :keysym or :shifted-modifier-name,
201 ;;; for the button cross event-key. If the information is undefined, this
202 ;;; signals an error.
203 ;;;
204 (defun mouse-translation-info (button event-key info)
205 (let ((event-dispatch (svref *mouse-translation-info* button)))
206 (unless event-dispatch
207 (error "No defined mouse translation information for button ~S." button))
208 (let ((data (ecase event-key
209 (:button-press (button-press-info event-dispatch))
210 (:button-release (button-release-info event-dispatch)))))
211 (unless data
212 (error
213 "No defined mouse translation information for button ~S and event ~S."
214 button event-key))
215 (ecase info
216 (:keysym (button-keysym data))
217 (:shifted-modifier-name (button-shifted-modifier-name data))))))
218
219 ;;; %SET-MOUSE-TRANSLATION-INFO -- Internal.
220 ;;;
221 ;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO
222 ;;; does, filling in the data structure on an as-needed basis, and stores
223 ;;; the value for the indicated info.
224 ;;;
225 (defun %set-mouse-translation-info (button event-key info value)
226 (let ((event-dispatch (svref *mouse-translation-info* button)))
227 (unless event-dispatch
228 (setf event-dispatch
229 (setf (svref *mouse-translation-info* button) (cons nil nil))))
230 (let ((data (ecase event-key
231 (:button-press (button-press-info event-dispatch))
232 (:button-release (button-release-info event-dispatch)))))
233 (unless data
234 (setf data
235 (ecase event-key
236 (:button-press
237 (setf (button-press-info event-dispatch) (cons nil nil)))
238 (:button-release
239 (setf (button-release-info event-dispatch) (cons nil nil))))))
240 (ecase info
241 (:keysym
242 (setf (button-keysym data) value))
243 (:shifted-modifier-name
244 (setf (button-shifted-modifier-name data) value))))))
245 ;;;
246 (defsetf mouse-translation-info %set-mouse-translation-info)
247
248 ;;; DEFINE-MOUSE-KEYSYM -- Public.
249 ;;;
250 (defun define-mouse-keysym (button keysym name shifted-bit event-key)
251 "This defines keysym named name for the X button cross the X event-key.
252 Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
253 in the key-event it returns whenever the X shift bit is on."
254 (unless (<= 1 button 5)
255 (error "Buttons are number 1-5, not ~D." button))
256 (setf (gethash keysym *keysyms-to-names*) (list name))
257 (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)
258 (setf (mouse-translation-info button event-key :keysym) keysym)
259 (setf (mouse-translation-info button event-key :shifted-modifier-name)
260 shifted-bit))
261
262 ;;; TRANSLATE-MOUSE-KEY-EVENT -- Public.
263 ;;;
264 (defun translate-mouse-key-event (scan-code bits event-key)
265 "This translates the X button code, scan-code, and modifier bits, bits, for
266 the X event-key into a key-event. See DEFINE-MOUSE-KEYSYM."
267 (let ((keysym (mouse-translation-info scan-code event-key :keysym))
268 (new-bits 0))
269 (dolist (map *modifier-translations*)
270 (when (logtest (car map) bits)
271 (setf new-bits
272 (if (string-equal (cdr map) "Shift")
273 (logior new-bits
274 (key-event-modifier-mask
275 (mouse-translation-info
276 scan-code event-key :shifted-modifier-name)))
277 (logior new-bits
278 (key-event-modifier-mask (cdr map)))))))
279 (make-key-event keysym new-bits)))
280
281
282
283 ;;;; Stuff for parsing #k syntax.
284
285 (defstruct (key-event (:print-function %print-key-event)
286 (:constructor %make-key-event (keysym bits)))
287 (bits nil :type fixnum)
288 (keysym nil :type fixnum))
289
290 (defun %print-key-event (object stream ignore)
291 (declare (ignore ignore))
292 (write-string "#<Key-Event " stream)
293 (print-pretty-key-event object stream)
294 (write-char #\> stream))
295
296 ;;; This maps Common Lisp CHAR-CODE's to character classes for parsing #k
297 ;;; syntax.
298 ;;;
299 (defvar *key-character-classes* (make-array char-code-limit
300 :initial-element :other))
301
302 ;;; These characters are special:
303 ;;; #\< .......... :ISO-start - Signals start of an ISO character.
304 ;;; #\> .......... :ISO-end - Signals end of an ISO character.
305 ;;; #\- .......... :modifier-terminator - Indicates last *id-namestring*
306 ;;; was a modifier.
307 ;;; #\" .......... :EOF - Means we have come to the end of the character.
308 ;;; #\{a-z, A-Z} .. :letter - Means the char is a letter.
309 ;;; #\space ....... :event-terminator- Indicates the last *id-namestring*
310 ;;; was a character name.
311 ;;;
312 ;;; Every other character has class :other.
313 ;;;
314 (hi::do-alpha-chars (char :both)
315 (setf (svref *key-character-classes* (char-code char)) :letter))
316 (setf (svref *key-character-classes* (char-code #\<)) :ISO-start)
317 (setf (svref *key-character-classes* (char-code #\>)) :ISO-end)
318 (setf (svref *key-character-classes* (char-code #\-)) :modifier-terminator)
319 (setf (svref *key-character-classes* (char-code #\space)) :event-terminator)
320 (setf (svref *key-character-classes* (char-code #\")) :EOF)
321
322 ;;; This holds the characters built up while lexing a potential keysym or
323 ;;; modifier identifier.
324 ;;;
325 (defvar *id-namestring*
326 (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-char))
327
328 ;;; PARSE-KEY-FUN -- Internal.
329 ;;;
330 ;;; This is the #k dispatch macro character reader. It is a FSM that parses
331 ;;; key specifications. It returns either a VECTOR form or a MAKE-KEY-EVENT
332 ;;; form. Since key-events are unique at runtime, we cannot create them at
333 ;;; readtime, returning the constant object from READ. Wherever a #k appears,
334 ;;; there's a for that at loadtime or runtime will return the unique key-event
335 ;;; or vector of unique key-events.
336 ;;;
337 (defun parse-key-fun (stream sub-char count)
338 (declare (ignore sub-char count))
339 (setf (fill-pointer *id-namestring*) 0)
340 (prog ((bits 0)
341 (key-event-list ())
342 char class)
343 (unless (char= (read-char stream) #\")
344 (error "Keys must be delimited by ~S." #\"))
345 ;; Skip any leading spaces in the string.
346 (skip-whitespace stream)
347 (multiple-value-setq (char class) (get-key-char stream))
348 (ecase class
349 ((:letter :other :escaped) (go ID))
350 (:ISO-start (go ISOCHAR))
351 (:ISO-end (error "Angle brackets must be escaped."))
352 (:modifier-terminator (error "Dash must be escaped."))
353 (:EOF (error "No key to read.")))
354 ID
355 (vector-push-extend char *id-namestring*)
356 (multiple-value-setq (char class) (get-key-char stream))
357 (ecase class
358 ((:letter :other :escaped) (go ID))
359 (:event-terminator (go GOT-CHAR))
360 (:modifier-terminator (go GOT-MODIFIER))
361 ((:ISO-start :ISO-end) (error "Angle brackets must be escaped."))
362 (:EOF (go GET-LAST-CHAR)))
363 GOT-CHAR
364 (push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
365 key-event-list)
366 (setf (fill-pointer *id-namestring*) 0)
367 (setf bits 0)
368 ;; Skip any whitespace between characters.
369 (skip-whitespace stream)
370 (multiple-value-setq (char class) (get-key-char stream))
371 (ecase class
372 ((:letter :other :escaped) (go ID))
373 (:ISO-start (go ISOCHAR))
374 (:ISO-end (error "Angle brackets must be escaped."))
375 (:modifier-terminator (error "Dash must be escaped."))
376 (:EOF (go FINAL)))
377 GOT-MODIFIER
378 (let ((modifier-name (car (assoc *id-namestring*
379 *modifiers-to-internal-masks*
380 :test #'string-equal))))
381 (unless modifier-name
382 (error "~S is not a defined modifier." *id-namestring*))
383 (setf (fill-pointer *id-namestring*) 0)
384 (setf bits (logior bits (key-event-modifier-mask modifier-name))))
385 (multiple-value-setq (char class) (get-key-char stream))
386 (ecase class
387 ((:letter :other :escaped) (go ID))
388 (:ISO-start (go ISOCHAR))
389 (:ISO-end (error "Angle brackets must be escaped."))
390 (:modifier-terminator (error "Dash must be escaped."))
391 (:EOF (error "Expected something naming a key-event, got EOF.")))
392 ISOCHAR
393 (multiple-value-setq (char class) (get-key-char stream))
394 (ecase class
395 ((:letter :event-terminator :other :escaped)
396 (vector-push-extend char *id-namestring*)
397 (go ISOCHAR))
398 (:ISO-start (error "Open Angle must be escaped."))
399 (:modifier-terminator (error "Dash must be escaped."))
400 (:EOF (error "Bad syntax in key specification, hit eof."))
401 (:ISO-end (go GOT-CHAR)))
402 GET-LAST-CHAR
403 (push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
404 key-event-list)
405 FINAL
406 (return (if (cdr key-event-list)
407 `(vector ,@(nreverse key-event-list))
408 `,(car key-event-list)))))
409
410 (set-dispatch-macro-character #\# #\k #'parse-key-fun)
411
412 (defconstant key-event-escape-char #\\
413 "The escape character that #k uses.")
414
415 ;;; GET-KEY-CHAR -- Internal.
416 ;;;
417 ;;; This is used by PARSE-KEY-FUN.
418 ;;;
419 (defun get-key-char (stream)
420 (let ((char (read-char stream t nil t)))
421 (cond ((char= char key-event-escape-char)
422 (let ((char (read-char stream t nil t)))
423 (values char :escaped)))
424 (t (values char (svref *key-character-classes* (char-code char)))))))
425
426
427
428 ;;;; Code to deal with modifiers.
429
430 (defvar *modifier-count* 0
431 "The number of modifiers that is currently defined.")
432
433 (eval-when (compile eval load)
434
435 (defconstant modifier-count-limit 6
436 "The maximum number of modifiers supported.")
437
438 ); eval-when
439
440 ;;; This is purely a list for users.
441 ;;;
442 (defvar *all-modifier-names* ()
443 "A list of all the names of defined modifiers.")
444
445 ;;; DEFINE-KEY-EVENT-MODIFIER -- Public.
446 ;;;
447 ;;; Note that short-name is pushed into *modifiers-to-internal-masks* after
448 ;;; long-name. PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on
449 ;;; this feature.
450 ;;;
451 (defun define-key-event-modifier (long-name short-name)
452 "This establishes long-name and short-name as modifier names for purposes
453 of specifying key-events in #k syntax. The names are case-insensitive and
454 must be strings. If either name is already defined, this signals an error."
455 (when (= *modifier-count* modifier-count-limit)
456 (error "Maximum of ~D modifiers allowed." modifier-count-limit))
457 (let ((long-name (string-capitalize long-name))
458 (short-name (string-capitalize short-name)))
459 (flet ((frob (name)
460 (when (assoc name *modifiers-to-internal-masks*
461 :test #'string-equal)
462 (restart-case
463 (error "Modifier name has already been defined -- ~S" name)
464 (blow-it-off ()
465 :report "Go on without defining this modifier."
466 (return-from define-key-event-modifier nil))))))
467 (frob long-name)
468 (frob short-name))
469 (unwind-protect
470 (let ((new-bits (ash 1 *modifier-count*)))
471 (push (cons long-name new-bits) *modifiers-to-internal-masks*)
472 (push (cons short-name new-bits) *modifiers-to-internal-masks*)
473 (pushnew long-name *all-modifier-names* :test #'string-equal)
474 ;; Sometimes the long-name is the same as the short-name.
475 (pushnew short-name *all-modifier-names* :test #'string-equal))
476 (incf *modifier-count*))))
477
478 ;;;
479 ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
480 ;;; default key-event modifiers.
481 ;;;
482
483 ;;; DEFINE-CLX-MODIFIER -- Public.
484 ;;;
485 (defun define-clx-modifier (clx-mask modifier-name)
486 "This establishes a mapping from clx-mask to a define key-event modifier-name.
487 TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
488 with bits defined by this routine."
489 (let ((map (assoc modifier-name *modifiers-to-internal-masks*
490 :test #'string-equal)))
491 (unless map (error "~S an undefined modifier name." modifier-name))
492 (push (cons clx-mask (car map)) *modifier-translations*)))
493
494 ;;;
495 ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
496 ;;; default clx modifiers, mapping them to some system default key-event
497 ;;; modifiers.
498 ;;;
499
500 ;;; MAKE-KEY-EVENT-BITS -- Public.
501 ;;;
502 (defun make-key-event-bits (&rest modifier-names)
503 "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier
504 names. If any name is undefined, this signals an error."
505 (let ((mask 0))
506 (dolist (mod modifier-names mask)
507 (let ((this-mask (cdr (assoc mod *modifiers-to-internal-masks*
508 :test #'string-equal))))
509 (unless this-mask (error "~S is an undefined modifier name." mod))
510 (setf mask (logior mask this-mask))))))
511
512 ;;; KEY-EVENT-BITS-MODIFIERS -- Public.
513 ;;;
514 (defun key-event-bits-modifiers (bits)
515 "This returns a list of key-event modifier names, one for each modifier
516 set in bits."
517 (let ((res nil))
518 (do ((map (cdr *modifiers-to-internal-masks*) (cddr map)))
519 ((null map) res)
520 (when (logtest bits (cdar map))
521 (push (caar map) res)))))
522
523 ;;; KEY-EVENT-MODIFIER-MASK -- Public.
524 ;;;
525 (defun key-event-modifier-mask (modifier-name)
526 "This function returns a mask for modifier-name. This mask is suitable
527 for use with KEY-EVENT-BITS. If modifier-name is undefined, this signals
528 an error."
529 (let ((res (cdr (assoc modifier-name *modifiers-to-internal-masks*
530 :test #'string-equal))))
531 (unless res (error "Undefined key-event modifier -- ~S." modifier-name))
532 res))
533
534
535
536 ;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT.
537
538 (defvar *keysym-high-bytes*)
539
540 (defconstant modifier-bits-limit (ash 1 modifier-count-limit))
541
542 ;;; GET-KEY-EVENT -- Internal.
543 ;;;
544 ;;; This finds the key-event specified by keysym and bits. If the key-event
545 ;;; does not already exist, this creates it. This assumes keysym is defined,
546 ;;; and if it isn't, this will make a key-event anyway that will cause an
547 ;;; error when the system tries to print it.
548 ;;;
549 (defun get-key-event (keysym bits)
550 (let* ((high-byte (ash keysym -8))
551 (low-byte-vector (svref *keysym-high-bytes* high-byte)))
552 (unless low-byte-vector
553 (let ((new-vector (make-array 256 :initial-element nil)))
554 (setf (svref *keysym-high-bytes* high-byte) new-vector)
555 (setf low-byte-vector new-vector)))
556 (let* ((low-byte (ldb (byte 8 0) keysym))
557 (bit-vector (svref low-byte-vector low-byte)))
558 (unless bit-vector
559 (let ((new-vector (make-array modifier-bits-limit
560 :initial-element nil)))
561 (setf (svref low-byte-vector low-byte) new-vector)
562 (setf bit-vector new-vector)))
563 (let ((key-event (svref bit-vector bits)))
564 (if key-event
565 key-event
566 (setf (svref bit-vector bits) (%make-key-event keysym bits)))))))
567
568 ;;; MAKE-KEY-EVENT -- Public.
569 ;;;
570 (defun make-key-event (object &optional (bits 0))
571 "This returns a key-event described by object with bits. Object is one of
572 keysym, string, or key-event. When object is a key-event, this uses
573 KEY-EVENT-KEYSYM. You can form bits with MAKE-KEY-EVENT-BITS or
574 KEY-EVENT-MODIFIER-MASK."
575 (etypecase object
576 (integer
577 (unless (keysym-names object)
578 (error "~S is an undefined keysym." object))
579 (get-key-event object bits))
580 #|(character
581 (let* ((name (char-name object))
582 (keysym (name-keysym (or name (string object)))))
583 (unless keysym
584 (error "~S is an undefined keysym." object))
585 (get-key-event keysym bits)))|#
586 (string
587 (let ((keysym (name-keysym object)))
588 (unless keysym
589 (error "~S is an undefined keysym." object))
590 (get-key-event keysym bits)))
591 (key-event
592 (get-key-event (key-event-keysym object) bits))))
593
594 ;;; KEY-EVENT-BIT-P -- Public.
595 ;;;
596 (defun key-event-bit-p (key-event bit-name)
597 "This returns whether key-event has the bit set named by bit-name. This
598 signals an error if bit-name is undefined."
599 (let ((mask (cdr (assoc bit-name *modifiers-to-internal-masks*
600 :test #'string-equal))))
601 (unless mask
602 (error "~S is not a defined modifier." bit-name))
603 (not (zerop (logand (key-event-bits key-event) mask)))))
604
605
606
607 ;;;; KEY-EVENT-CHAR and CHAR-KEY-EVENT.
608
609 ;;; This maps key-events to characters. Users modify this by SETF'ing
610 ;;; KEY-EVENT-CHAR.
611 ;;;
612 (defvar *key-event-characters*)
613
614 (defun key-event-char (key-event)
615 "Returns the character associated with key-event. This is SETF'able."
616 (check-type key-event key-event)
617 (gethash key-event *key-event-characters*))
618
619 (defun %set-key-event-char (key-event character)
620 (check-type character character)
621 (check-type key-event key-event)
622 (setf (gethash key-event *key-event-characters*) character))
623 ;;;
624 (defsetf key-event-char %set-key-event-char)
625
626
627 ;;; This maps characters to key-events. Users modify this by SETF'ing
628 ;;; CHAR-KEY-EVENT.
629 ;;;
630 (defvar *character-key-events*)
631
632 (defun char-key-event (char)
633 "Returns the key-event associated with char. This is SETF'able."
634 (check-type char character)
635 (svref *character-key-events* (char-code char)))
636
637 (defun %set-char-key-event (char key-event)
638 (check-type char character)
639 (check-type key-event key-event)
640 (setf (svref *character-key-events* (char-code char)) key-event))
641 ;;;
642 (defsetf char-key-event %set-char-key-event)
643
644
645
646 ;;;; DO-ALPHA-KEY-EVENTS.
647
648 (defmacro alpha-key-events-loop (var start-keysym end-keysym result body)
649 (let ((n (gensym)))
650 `(do ((,n ,start-keysym (1+ ,n)))
651 ((> ,n ,end-keysym) ,result)
652 (let ((,var (make-key-event ,n 0)))
653 (when (alpha-char-p (key-event-char ,var))
654 ,@body)))))
655
656 (defmacro do-alpha-key-events ((var kind &optional result) &rest forms)
657 "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*)
658 This macro evaluates each form with var bound to a key-event representing an
659 alphabetic character. Kind is one of :lower, :upper, or :both, and this
660 binds var to each key-event in order as specified in the X11 protocol
661 specification. When :both is specified, this processes lowercase letters
662 first."
663 (case kind
664 (:both
665 `(progn (alpha-key-events-loop ,var 97 122 nil ,forms)
666 (alpha-key-events-loop ,var 65 90 ,result ,forms)))
667 (:lower
668 `(alpha-key-events-loop ,var 97 122 ,result ,forms))
669 (:upper
670 `(alpha-key-events-loop ,var 65 90 ,result ,forms))
671 (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
672 kind))))
673
674
675
676 ;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT.
677
678 ;;; PRINT-PRETTY-KEY -- Public.
679 ;;;
680 (defun print-pretty-key (key &optional (stream *standard-output*) long-names-p)
681 "This prints key, a key-event or vector of key-events, to stream in a
682 user-expected fashion. Long-names-p indicates whether modifiers should
683 print with their long or short name."
684 (declare (type (or vector key-event) key) (type stream stream))
685 (etypecase key
686 (key-event (print-pretty-key-event key stream long-names-p))
687 (vector
688 (let ((length-1 (1- (length key))))
689 (dotimes (i (length key))
690 (let ((key-event (aref key i)))
691 (print-pretty-key-event key-event stream long-names-p)
692 (unless (= i length-1) (write-char #\space stream))))))))
693
694 ;;; PRINT-PRETTY-KEY-EVENT -- Public.
695 ;;;
696 ;;; Note, this makes use of the ordering in the a-list
697 ;;; *modifiers-to-internal-masks* by CDDR'ing down it by starting on a short
698 ;;; name or a long name.
699 ;;;
700 (defun print-pretty-key-event (key-event &optional (stream *standard-output*)
701 long-names-p)
702 "This prints key-event to stream. Long-names-p indicates whether modifier
703 names should appear using the long name or short name."
704 (do ((map (if long-names-p
705 (cdr *modifiers-to-internal-masks*)
706 *modifiers-to-internal-masks*)
707 (cddr map)))
708 ((null map))
709 (when (not (zerop (logand (cdar map) (key-event-bits key-event))))
710 (write-string (caar map) stream)
711 (write-char #\- stream)))
712 (let* ((name (keysym-preferred-name (key-event-keysym key-event)))
713 (spacep (position #\space (the simple-string name))))
714 (when spacep (write-char #\< stream))
715 (write-string name stream)
716 (when spacep (write-char #\> stream))))
717
718
719
720 ;;;; Re-initialization.
721
722 ;;; RE-INITIALIZE-KEY-EVENTS -- Internal.
723 ;;;
724 (defun re-initialize-key-events ()
725 "This blows away all data associated with keysyms, modifiers, mouse
726 translations, and key-event/characters mapping. Then it re-establishes
727 the system defined key-event modifiers and the system defined CLX
728 modifier mappings to some of those key-event modifiers.
729
730 When recompiling this file, you should load it and call this function
731 before using any part of the key-event interface, especially before
732 defining all your keysyms and using #k syntax."
733 (setf *keysyms-to-names* (make-hash-table :test #'eql))
734 (setf *names-to-keysyms* (make-hash-table :test #'equal))
735 (setf *modifier-translations* ())
736 (setf *modifiers-to-internal-masks* ())
737 (setf *mouse-translation-info* (make-array 6 :initial-element nil))
738 (setf *modifier-count* 0)
739 (setf *all-modifier-names* ())
740 (setf *keysym-high-bytes* (make-array 256 :initial-element nil))
741 (setf *key-event-characters* (make-hash-table))
742 (setf *character-key-events*
743 (make-array char-code-limit :initial-element nil))
744
745 (define-key-event-modifier "Hyper" "H")
746 (define-key-event-modifier "Super" "S")
747 (define-key-event-modifier "Meta" "M")
748 (define-key-event-modifier "Control" "C")
749 (define-key-event-modifier "Shift" "Shift")
750 (define-key-event-modifier "Lock" "Lock")
751
752 #+clx (define-clx-modifier (xlib:make-state-mask :shift) "Shift")
753 #+clx (define-clx-modifier (xlib:make-state-mask :mod-1) "Meta")
754 #+clx (define-clx-modifier (xlib:make-state-mask :control) "Control")
755 #+clx (define-clx-modifier (xlib:make-state-mask :lock) "Lock"))
756
757 ;;; Initialize stuff if not already initialized.
758 ;;;
759 (unless (boundp '*keysyms-to-names*)
760 (re-initialize-key-events))

  ViewVC Help
Powered by ViewVC 1.1.5