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

  ViewVC Help
Powered by ViewVC 1.1.5