/[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 - (hide 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 ram 1.1 ;;; -*- Log: hemlock.log; Package: extensions -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/key-event.lisp,v 1.4 1996/05/08 14:56:40 ram Exp $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
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 ram 1.2 (defvar *keysyms-to-names*)
54 ram 1.1
55     ;;; This table maps all keysym names to the appropriate keysym.
56     ;;;
57 ram 1.2 (defvar *names-to-keysyms*)
58 ram 1.1
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 ram 1.2 (defvar *modifier-translations*)
104 ram 1.1
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 ram 1.2 (defvar *modifiers-to-internal-masks*)
112 ram 1.1
113     ;;; TRANSLATE-KEY-EVENT -- Public.
114     ;;;
115 ram 1.2 #+clx
116 ram 1.1 (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 ram 1.4 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 ram 1.1 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 ram 1.4 ;; ignore the bits of the mapping for the determination of a key index
146     (setq bits (logxor bits (car map)))
147 ram 1.1 (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 ram 1.4 ;; 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 ram 1.1 (cond ((null (keysym-names keysym))
159 ram 1.2 nil)
160 ram 1.1 ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
161     (let ((keysym (xlib:keycode->keysym display scan-code 1)))
162 ram 1.2 (if (keysym-names keysym)
163     (make-key-event keysym new-bits)
164     nil)))
165 ram 1.1 (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 ram 1.2 (defvar *mouse-translation-info*)
190 ram 1.1
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 ram 1.2 (bits nil :type fixnum)
288     (keysym nil :type fixnum))
289 ram 1.1
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 ram 1.2 (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-char))
327 ram 1.1
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 ram 1.2 (eval-when (compile eval load)
434    
435 ram 1.1 (defconstant modifier-count-limit 6
436     "The maximum number of modifiers supported.")
437    
438 ram 1.2 ); eval-when
439    
440 ram 1.1 ;;; 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 ram 1.2 (defvar *keysym-high-bytes*)
539 ram 1.1
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 ram 1.2 (let ((new-vector (make-array 256 :initial-element nil)))
554 ram 1.1 (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 ram 1.2 (let ((new-vector (make-array modifier-bits-limit
560     :initial-element nil)))
561 ram 1.1 (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 ram 1.2 (defvar *key-event-characters*)
613 ram 1.1
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 ram 1.2 (defvar *character-key-events*)
631 ram 1.1
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 ram 1.2 "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*)
658 ram 1.1 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 ram 1.2 (declare (type (or vector key-event) key) (type stream stream))
685 ram 1.1 (etypecase key
686 ram 1.2 (key-event (print-pretty-key-event key stream long-names-p))
687 ram 1.1 (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 ram 1.2 (setf *character-key-events*
743     (make-array char-code-limit :initial-element nil))
744 ram 1.1
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 ram 1.2
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