/[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.2 - (hide annotations) (vendor branch)
Wed Oct 10 17:35:35 1990 UTC (23 years, 6 months ago) by wlott
Changes since 1.1.1.1: +13 -13 lines
Merged MIPS branch onto new-compiler branch.
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     (if (<= 65505 keysym 65518) ;modifier keys.
150     nil
151     (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
152     keysym)))
153     ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
154     (let ((keysym (xlib:keycode->keysym display scan-code 1)))
155     (unless (keysym-names keysym)
156     (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
157     keysym))
158     (make-key-event keysym new-bits)))
159     (t
160     (make-key-event keysym new-bits))))))
161    
162    
163    
164     ;;;; Mouse key-event stuff.
165    
166     ;;; Think of this data as a three dimensional array indexed by the following
167     ;;; domains:
168     ;;; 1-5
169     ;;; for the mouse scan-codes (button numbers) delivered by X.
170     ;;; :button-press or :button-release
171     ;;; whether the button was pressed or released.
172     ;;; :keysym or :shifted-modifier-name
173     ;;; whether the X shift bit was set.
174     ;;; For each button, pressed and released, we store a keysym to be used in a
175     ;;; key-event representing the button and whether it was pressed or released.
176     ;;; We also store a modifier name that TRANSLATE-MOUSE-KEY-EVENT turns on
177     ;;; whenever a mouse event occurs with the X shift bit on. This is basically
178     ;;; an archaic feature since we now can specify key-events like the following:
179     ;;; #k"shift-leftdown"
180     ;;; Previously we couldn't, so we mapped the shift bit to a bit we could
181     ;;; talke about, such as super.
182     ;;;
183     (defvar *mouse-translation-info* (make-array 6 :initial-element nil))
184    
185     (eval-when (compile eval)
186     (defmacro button-press-info (event-dispatch) `(car ,event-dispatch))
187     (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch))
188     (defmacro button-keysym (info) `(car ,info))
189     (defmacro button-shifted-modifier-name (info) `(cdr ,info))
190     ) ;eval-when
191    
192     ;;; MOUSE-TRANSLATION-INFO -- Internal.
193     ;;;
194     ;;; This returns the requested information, :keysym or :shifted-modifier-name,
195     ;;; for the button cross event-key. If the information is undefined, this
196     ;;; signals an error.
197     ;;;
198     (defun mouse-translation-info (button event-key info)
199     (let ((event-dispatch (svref *mouse-translation-info* button)))
200     (unless event-dispatch
201     (error "No defined mouse translation information for button ~S." button))
202     (let ((data (ecase event-key
203     (:button-press (button-press-info event-dispatch))
204     (:button-release (button-release-info event-dispatch)))))
205     (unless data
206     (error
207     "No defined mouse translation information for button ~S and event ~S."
208     button event-key))
209     (ecase info
210     (:keysym (button-keysym data))
211     (:shifted-modifier-name (button-shifted-modifier-name data))))))
212    
213     ;;; %SET-MOUSE-TRANSLATION-INFO -- Internal.
214     ;;;
215     ;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO
216     ;;; does, filling in the data structure on an as-needed basis, and stores
217     ;;; the value for the indicated info.
218     ;;;
219     (defun %set-mouse-translation-info (button event-key info value)
220     (let ((event-dispatch (svref *mouse-translation-info* button)))
221     (unless event-dispatch
222     (setf event-dispatch
223     (setf (svref *mouse-translation-info* button) (cons nil nil))))
224     (let ((data (ecase event-key
225     (:button-press (button-press-info event-dispatch))
226     (:button-release (button-release-info event-dispatch)))))
227     (unless data
228     (setf data
229     (ecase event-key
230     (:button-press
231     (setf (button-press-info event-dispatch) (cons nil nil)))
232     (:button-release
233     (setf (button-release-info event-dispatch) (cons nil nil))))))
234     (ecase info
235     (:keysym
236     (setf (button-keysym data) value))
237     (:shifted-modifier-name
238     (setf (button-shifted-modifier-name data) value))))))
239     ;;;
240     (defsetf mouse-translation-info %set-mouse-translation-info)
241    
242     ;;; DEFINE-MOUSE-KEYSYM -- Public.
243     ;;;
244     (defun define-mouse-keysym (button keysym name shifted-bit event-key)
245     "This defines keysym named name for the X button cross the X event-key.
246     Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
247     in the key-event it returns whenever the X shift bit is on."
248     (unless (<= 1 button 5)
249     (error "Buttons are number 1-5, not ~D." button))
250     (setf (gethash keysym *keysyms-to-names*) (list name))
251     (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)
252     (setf (mouse-translation-info button event-key :keysym) keysym)
253     (setf (mouse-translation-info button event-key :shifted-modifier-name)
254     shifted-bit))
255    
256     ;;; TRANSLATE-MOUSE-KEY-EVENT -- Public.
257     ;;;
258     (defun translate-mouse-key-event (scan-code bits event-key)
259     "This translates the X button code, scan-code, and modifier bits, bits, for
260     the X event-key into a key-event. See DEFINE-MOUSE-KEYSYM."
261     (let ((keysym (mouse-translation-info scan-code event-key :keysym))
262     (new-bits 0))
263     (dolist (map *modifier-translations*)
264     (when (logtest (car map) bits)
265     (setf new-bits
266     (if (string-equal (cdr map) "Shift")
267     (logior new-bits
268     (key-event-modifier-mask
269     (mouse-translation-info
270     scan-code event-key :shifted-modifier-name)))
271     (logior new-bits
272     (key-event-modifier-mask (cdr map)))))))
273     (make-key-event keysym new-bits)))
274    
275    
276    
277     ;;;; Stuff for parsing #k syntax.
278    
279     (defstruct (key-event (:print-function %print-key-event)
280     (:constructor %make-key-event (keysym bits)))
281     (bits :type fixnum)
282     (keysym :type :fixnum))
283    
284     (defun %print-key-event (object stream ignore)
285     (declare (ignore ignore))
286     (write-string "#<Key-Event " stream)
287     (print-pretty-key-event object stream)
288     (write-char #\> stream))
289    
290     ;;; This maps Common Lisp CHAR-CODE's to character classes for parsing #k
291     ;;; syntax.
292     ;;;
293     (defvar *key-character-classes* (make-array char-code-limit
294     :initial-element :other))
295    
296     ;;; These characters are special:
297     ;;; #\< .......... :ISO-start - Signals start of an ISO character.
298     ;;; #\> .......... :ISO-end - Signals end of an ISO character.
299     ;;; #\- .......... :modifier-terminator - Indicates last *id-namestring*
300     ;;; was a modifier.
301     ;;; #\" .......... :EOF - Means we have come to the end of the character.
302     ;;; #\{a-z, A-Z} .. :letter - Means the char is a letter.
303     ;;; #\space ....... :event-terminator- Indicates the last *id-namestring*
304     ;;; was a character name.
305     ;;;
306     ;;; Every other character has class :other.
307     ;;;
308     (hi::do-alpha-chars (char :both)
309     (setf (svref *key-character-classes* (char-code char)) :letter))
310     (setf (svref *key-character-classes* (char-code #\<)) :ISO-start)
311     (setf (svref *key-character-classes* (char-code #\>)) :ISO-end)
312     (setf (svref *key-character-classes* (char-code #\-)) :modifier-terminator)
313     (setf (svref *key-character-classes* (char-code #\space)) :event-terminator)
314     (setf (svref *key-character-classes* (char-code #\")) :EOF)
315    
316     ;;; This holds the characters built up while lexing a potential keysym or
317     ;;; modifier identifier.
318     ;;;
319     (defvar *id-namestring*
320 wlott 1.1.1.2 (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-character))
321 ram 1.1
322     ;;; PARSE-KEY-FUN -- Internal.
323     ;;;
324     ;;; This is the #k dispatch macro character reader. It is a FSM that parses
325     ;;; key specifications. It returns either a VECTOR form or a MAKE-KEY-EVENT
326     ;;; form. Since key-events are unique at runtime, we cannot create them at
327     ;;; readtime, returning the constant object from READ. Wherever a #k appears,
328     ;;; there's a for that at loadtime or runtime will return the unique key-event
329     ;;; or vector of unique key-events.
330     ;;;
331     (defun parse-key-fun (stream sub-char count)
332     (declare (ignore sub-char count))
333     (setf (fill-pointer *id-namestring*) 0)
334     (prog ((bits 0)
335     (key-event-list ())
336     char class)
337     (unless (char= (read-char stream) #\")
338     (error "Keys must be delimited by ~S." #\"))
339     ;; Skip any leading spaces in the string.
340     (skip-whitespace stream)
341     (multiple-value-setq (char class) (get-key-char stream))
342     (ecase class
343     ((:letter :other :escaped) (go ID))
344     (:ISO-start (go ISOCHAR))
345     (:ISO-end (error "Angle brackets must be escaped."))
346     (:modifier-terminator (error "Dash must be escaped."))
347     (:EOF (error "No key to read.")))
348     ID
349     (vector-push-extend char *id-namestring*)
350     (multiple-value-setq (char class) (get-key-char stream))
351     (ecase class
352     ((:letter :other :escaped) (go ID))
353     (:event-terminator (go GOT-CHAR))
354     (:modifier-terminator (go GOT-MODIFIER))
355     ((:ISO-start :ISO-end) (error "Angle brackets must be escaped."))
356     (:EOF (go GET-LAST-CHAR)))
357     GOT-CHAR
358     (push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
359     key-event-list)
360     (setf (fill-pointer *id-namestring*) 0)
361     (setf bits 0)
362     ;; Skip any whitespace between characters.
363     (skip-whitespace stream)
364     (multiple-value-setq (char class) (get-key-char stream))
365     (ecase class
366     ((:letter :other :escaped) (go ID))
367     (:ISO-start (go ISOCHAR))
368     (:ISO-end (error "Angle brackets must be escaped."))
369     (:modifier-terminator (error "Dash must be escaped."))
370     (:EOF (go FINAL)))
371     GOT-MODIFIER
372     (let ((modifier-name (car (assoc *id-namestring*
373     *modifiers-to-internal-masks*
374     :test #'string-equal))))
375     (unless modifier-name
376     (error "~S is not a defined modifier." *id-namestring*))
377     (setf (fill-pointer *id-namestring*) 0)
378     (setf bits (logior bits (key-event-modifier-mask modifier-name))))
379     (multiple-value-setq (char class) (get-key-char stream))
380     (ecase class
381     ((:letter :other :escaped) (go ID))
382     (:ISO-start (go ISOCHAR))
383     (:ISO-end (error "Angle brackets must be escaped."))
384     (:modifier-terminator (error "Dash must be escaped."))
385     (:EOF (error "Expected something naming a key-event, got EOF.")))
386     ISOCHAR
387     (multiple-value-setq (char class) (get-key-char stream))
388     (ecase class
389     ((:letter :event-terminator :other :escaped)
390     (vector-push-extend char *id-namestring*)
391     (go ISOCHAR))
392     (:ISO-start (error "Open Angle must be escaped."))
393     (:modifier-terminator (error "Dash must be escaped."))
394     (:EOF (error "Bad syntax in key specification, hit eof."))
395     (:ISO-end (go GOT-CHAR)))
396     GET-LAST-CHAR
397     (push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
398     key-event-list)
399     FINAL
400     (return (if (cdr key-event-list)
401     `(vector ,@(nreverse key-event-list))
402     `,(car key-event-list)))))
403    
404     (set-dispatch-macro-character #\# #\k #'parse-key-fun)
405    
406     (defconstant key-event-escape-char #\\
407     "The escape character that #k uses.")
408    
409     ;;; GET-KEY-CHAR -- Internal.
410     ;;;
411     ;;; This is used by PARSE-KEY-FUN.
412     ;;;
413     (defun get-key-char (stream)
414     (let ((char (read-char stream t nil t)))
415     (cond ((char= char key-event-escape-char)
416     (let ((char (read-char stream t nil t)))
417     (values char :escaped)))
418     (t (values char (svref *key-character-classes* (char-code char)))))))
419    
420    
421    
422     ;;;; Code to deal with modifiers.
423    
424     (defvar *modifier-count* 0
425     "The number of modifiers that is currently defined.")
426    
427     (defconstant modifier-count-limit 6
428     "The maximum number of modifiers supported.")
429    
430     ;;; This is purely a list for users.
431     ;;;
432     (defvar *all-modifier-names* ()
433     "A list of all the names of defined modifiers.")
434    
435     ;;; DEFINE-KEY-EVENT-MODIFIER -- Public.
436     ;;;
437     ;;; Note that short-name is pushed into *modifiers-to-internal-masks* after
438     ;;; long-name. PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on
439     ;;; this feature.
440     ;;;
441     (defun define-key-event-modifier (long-name short-name)
442     "This establishes long-name and short-name as modifier names for purposes
443     of specifying key-events in #k syntax. The names are case-insensitive and
444     must be strings. If either name is already defined, this signals an error."
445     (when (= *modifier-count* modifier-count-limit)
446     (error "Maximum of ~D modifiers allowed." modifier-count-limit))
447     (let ((long-name (string-capitalize long-name))
448     (short-name (string-capitalize short-name)))
449     (flet ((frob (name)
450     (when (assoc name *modifiers-to-internal-masks*
451     :test #'string-equal)
452     (restart-case
453     (error "Modifier name has already been defined -- ~S" name)
454     (blow-it-off ()
455     :report "Go on without defining this modifier."
456     (return-from define-key-event-modifier nil))))))
457     (frob long-name)
458     (frob short-name))
459     (unwind-protect
460     (let ((new-bits (ash 1 *modifier-count*)))
461     (push (cons long-name new-bits) *modifiers-to-internal-masks*)
462     (push (cons short-name new-bits) *modifiers-to-internal-masks*)
463     (pushnew long-name *all-modifier-names* :test #'string-equal)
464     ;; Sometimes the long-name is the same as the short-name.
465     (pushnew short-name *all-modifier-names* :test #'string-equal))
466     (incf *modifier-count*))))
467    
468     ;;;
469     ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
470     ;;; default key-event modifiers.
471     ;;;
472    
473     ;;; DEFINE-CLX-MODIFIER -- Public.
474     ;;;
475 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