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

  ViewVC Help
Powered by ViewVC 1.1.5