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

  ViewVC Help
Powered by ViewVC 1.1.5