/[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 - (hide 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 ram 1.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 wlott 1.1.1.2 #+clx
115 ram 1.1 (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 wlott 1.1.1.4 nil)
150 ram 1.1 ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
151     (let ((keysym (xlib:keycode->keysym display scan-code 1)))
152 wlott 1.1.1.4 (if (keysym-names keysym)
153     (make-key-event keysym new-bits)
154     nil)))
155 ram 1.1 (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 wlott 1.1.1.2 (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-character))
317 ram 1.1
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 wlott 1.1.1.3 (eval-when (compile eval load)
424    
425 ram 1.1 (defconstant modifier-count-limit 6
426     "The maximum number of modifiers supported.")
427 wlott 1.1.1.3
428     ); eval-when
429 ram 1.1
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 wlott 1.1.1.2 (defun define-clx-modifier (clx-mask modifier-name)
476 ram 1.1 "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 wlott 1.1.1.2 (let ((new-vector (make-array 256 :initial-element nil)))
544 ram 1.1 (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 wlott 1.1.1.2 (let ((new-vector (make-array modifier-bits-limit
550     :initial-element nil)))
551 ram 1.1 (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 wlott 1.1.1.2 (setf *character-key-events*
733     (make-array char-code-limit :initial-element nil))
734 ram 1.1
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 wlott 1.1.1.2
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