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

  ViewVC Help
Powered by ViewVC 1.1.5