/[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.10 - (hide annotations) (vendor branch)
Mon Sep 7 16:50:35 1992 UTC (21 years, 7 months ago) by ram
Changes since 1.1.1.9: +2 -2 lines
Fixed doc string.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: extensions -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.1.1.5 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.1.1.10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/key-event.lisp,v 1.1.1.10 1992/09/07 16:50:35 ram Exp $")
11 ram 1.1.1.5 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file implements key-events for representing editor input. It also
15     ;;; provides a couple routines to interface this to X11.
16     ;;;
17     ;;; Written by Blaine Burks and Bill Chiles.
18     ;;;
19    
20     ;;; The following are the implementation dependent parts of this code (what
21     ;;; you would have to change if you weren't using X11):
22     ;;; *modifier-translations*
23     ;;; DEFINE-CLX-MODIFIER
24     ;;; TRANSLATE-KEY-EVENT
25     ;;; TRANSLATE-MOUSE-KEY-EVENT
26     ;;; DEFINE-KEYSYM
27     ;;; DEFINE-MOUSE-KEYSYM
28     ;;; DO-ALPHA-KEY-EVENTS
29     ;;; If the window system didn't use a keysym mechanism to represent keys, you
30     ;;; would also need to write something that mapped whatever did encode the
31     ;;; keys to the keysyms defined with DEFINE-KEYSYM.
32     ;;;
33    
34     (in-package "EXTENSIONS")
35    
36     (export '( define-keysym define-mouse-keysym name-keysym keysym-names
37     keysym-preferred-name define-key-event-modifier define-clx-modifier
38     make-key-event-bits key-event-modifier-mask key-event-bits-modifiers
39     *all-modifier-names* translate-key-event translate-mouse-key-event
40     make-key-event key-event key-event-p key-event-bits key-event-keysym
41     char-key-event key-event-char key-event-bit-p do-alpha-key-events
42     print-pretty-key print-pretty-key-event))
43    
44    
45    
46     ;;;; Keysym <==> Name translation.
47    
48     ;;; Keysyms are named by case-insensitive names. However, if the name
49     ;;; consists of a single character, the name is case-sensitive.
50     ;;;
51    
52     ;;; This table maps a keysym to a list of names. The first name is the
53     ;;; preferred printing name.
54     ;;;
55 ram 1.1.1.9 (defvar *keysyms-to-names*)
56 ram 1.1
57     ;;; This table maps all keysym names to the appropriate keysym.
58     ;;;
59 ram 1.1.1.9 (defvar *names-to-keysyms*)
60 ram 1.1
61     (proclaim '(inline name-keysym keysym-names keysym-preferred-name))
62    
63     (defun name-keysym (name)
64     "This returns the keysym named name. If name is unknown, this returns nil."
65     (gethash (get-name-case-right name) *names-to-keysyms*))
66    
67     (defun keysym-names (keysym)
68     "This returns the list of all names for keysym. If keysym is undefined,
69     this returns nil."
70     (gethash keysym *keysyms-to-names*))
71    
72     (defun keysym-preferred-name (keysym)
73     "This returns the preferred name for keysym, how it is typically printed.
74     If keysym is undefined, this returns nil."
75     (car (gethash keysym *keysyms-to-names*)))
76    
77    
78    
79     ;;;; Character key-event stuff.
80    
81     ;;; GET-NAME-CASE-RIGHT -- Internal.
82     ;;;
83     ;;; This returns the canonical string for a keysym name for use with
84     ;;; hash tables.
85     ;;;
86     (defun get-name-case-right (string)
87     (if (= (length string) 1) string (string-downcase string)))
88    
89     ;;; DEFINE-KEYSYM -- Public.
90     ;;;
91     (defun define-keysym (keysym preferred-name &rest other-names)
92     "This establishes a mapping from preferred-name to keysym for purposes of
93     specifying key-events in #k syntax. Other-names also map to keysym, but the
94     system uses preferred-name when printing key-events. The names are
95     case-insensitive simple-strings. Redefining a keysym or re-using names has
96     undefined effects."
97     (setf (gethash keysym *keysyms-to-names*) (cons preferred-name other-names))
98     (dolist (name (cons preferred-name other-names))
99     (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
100    
101     ;;; This is an a-list mapping CLX modifier masks to defined key-event
102     ;;; modifier names. DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
103     ;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
104     ;;;
105 ram 1.1.1.9 (defvar *modifier-translations*)
106 ram 1.1
107     ;;; This is an ordered a-list mapping defined key-event modifier names to the
108     ;;; appropriate mask for the modifier. Modifier names have a short and a long
109     ;;; version. For each pair of names for the same mask, the names are
110     ;;; contiguous in this list, and the short name appears first.
111     ;;; PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on this.
112     ;;;
113 ram 1.1.1.9 (defvar *modifiers-to-internal-masks*)
114 ram 1.1
115     ;;; TRANSLATE-KEY-EVENT -- Public.
116     ;;;
117 wlott 1.1.1.2 #+clx
118 ram 1.1 (defun translate-key-event (display scan-code bits)
119     "Translates the X scan-code and X bits to a key-event. First this maps
120     scan-code to an X keysym using XLIB:KEYCODE->KEYSYM looking at bits and
121     supplying index as 1 if the X shift bit is on, 0 otherwise.
122    
123     If the resulting keysym is undefined, and it is not a modifier keysym, then
124     this signals an error. If the keysym is a modifier key, then this returns
125     nil.
126    
127     If the following conditions are satisfied
128     the keysym is defined
129     the X shift bit is off
130     the X lock bit is on
131     the X keysym represents a lowercase letter
132     then this maps the scan-code again supplying index as 1 this time, treating
133     the X lock bit as a caps-lock bit. If this results in an undefined keysym,
134     this signals an error. Otherwise, this makes a key-event with the keysym
135     and bits formed by mapping the X bits to key-event bits.
136    
137     Otherwise, this makes a key-event with the keysym and bits formed by mapping
138     the X bits to key-event bits."
139     (let ((new-bits 0)
140     shiftp lockp)
141     (dolist (map *modifier-translations*)
142     (unless (zerop (logand (car map) bits))
143     (cond
144     ((string-equal (cdr map) "Shift")
145     (setf shiftp t))
146     ((string-equal (cdr map) "Lock")
147     (setf lockp t))
148     (t (setf new-bits
149     (logior new-bits (key-event-modifier-mask (cdr map))))))))
150     (let ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0))))
151     (cond ((null (keysym-names keysym))
152 wlott 1.1.1.4 nil)
153 ram 1.1 ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
154     (let ((keysym (xlib:keycode->keysym display scan-code 1)))
155 wlott 1.1.1.4 (if (keysym-names keysym)
156     (make-key-event keysym new-bits)
157     nil)))
158 ram 1.1 (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 ram 1.1.1.9 (defvar *mouse-translation-info*)
183 ram 1.1
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 wlott 1.1.1.7 (bits nil :type fixnum)
281 wlott 1.1.1.8 (keysym nil :type fixnum))
282 ram 1.1
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 wlott 1.1.1.6 (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-char))
320 ram 1.1
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 wlott 1.1.1.3 (eval-when (compile eval load)
427    
428 ram 1.1 (defconstant modifier-count-limit 6
429     "The maximum number of modifiers supported.")
430 wlott 1.1.1.3
431     ); eval-when
432 ram 1.1
433     ;;; This is purely a list for users.
434     ;;;
435     (defvar *all-modifier-names* ()
436     "A list of all the names of defined modifiers.")
437    
438     ;;; DEFINE-KEY-EVENT-MODIFIER -- Public.
439     ;;;
440     ;;; Note that short-name is pushed into *modifiers-to-internal-masks* after
441     ;;; long-name. PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on
442     ;;; this feature.
443     ;;;
444     (defun define-key-event-modifier (long-name short-name)
445     "This establishes long-name and short-name as modifier names for purposes
446     of specifying key-events in #k syntax. The names are case-insensitive and
447     must be strings. If either name is already defined, this signals an error."
448     (when (= *modifier-count* modifier-count-limit)
449     (error "Maximum of ~D modifiers allowed." modifier-count-limit))
450     (let ((long-name (string-capitalize long-name))
451     (short-name (string-capitalize short-name)))
452     (flet ((frob (name)
453     (when (assoc name *modifiers-to-internal-masks*
454     :test #'string-equal)
455     (restart-case
456     (error "Modifier name has already been defined -- ~S" name)
457     (blow-it-off ()
458     :report "Go on without defining this modifier."
459     (return-from define-key-event-modifier nil))))))
460     (frob long-name)
461     (frob short-name))
462     (unwind-protect
463     (let ((new-bits (ash 1 *modifier-count*)))
464     (push (cons long-name new-bits) *modifiers-to-internal-masks*)
465     (push (cons short-name new-bits) *modifiers-to-internal-masks*)
466     (pushnew long-name *all-modifier-names* :test #'string-equal)
467     ;; Sometimes the long-name is the same as the short-name.
468     (pushnew short-name *all-modifier-names* :test #'string-equal))
469     (incf *modifier-count*))))
470    
471     ;;;
472     ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
473     ;;; default key-event modifiers.
474     ;;;
475    
476     ;;; DEFINE-CLX-MODIFIER -- Public.
477     ;;;
478 wlott 1.1.1.2 (defun define-clx-modifier (clx-mask modifier-name)
479 ram 1.1 "This establishes a mapping from clx-mask to a define key-event modifier-name.
480     TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
481     with bits defined by this routine."
482     (let ((map (assoc modifier-name *modifiers-to-internal-masks*
483     :test #'string-equal)))
484     (unless map (error "~S an undefined modifier name." modifier-name))
485     (push (cons clx-mask (car map)) *modifier-translations*)))
486    
487     ;;;
488     ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
489     ;;; default clx modifiers, mapping them to some system default key-event
490     ;;; modifiers.
491     ;;;
492    
493     ;;; MAKE-KEY-EVENT-BITS -- Public.
494     ;;;
495     (defun make-key-event-bits (&rest modifier-names)
496     "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier
497     names. If any name is undefined, this signals an error."
498     (let ((mask 0))
499     (dolist (mod modifier-names mask)
500     (let ((this-mask (cdr (assoc mod *modifiers-to-internal-masks*
501     :test #'string-equal))))
502     (unless this-mask (error "~S is an undefined modifier name." mod))
503     (setf mask (logior mask this-mask))))))
504    
505     ;;; KEY-EVENT-BITS-MODIFIERS -- Public.
506     ;;;
507     (defun key-event-bits-modifiers (bits)
508     "This returns a list of key-event modifier names, one for each modifier
509     set in bits."
510     (let ((res nil))
511     (do ((map (cdr *modifiers-to-internal-masks*) (cddr map)))
512     ((null map) res)
513     (when (logtest bits (cdar map))
514     (push (caar map) res)))))
515    
516     ;;; KEY-EVENT-MODIFIER-MASK -- Public.
517     ;;;
518     (defun key-event-modifier-mask (modifier-name)
519     "This function returns a mask for modifier-name. This mask is suitable
520     for use with KEY-EVENT-BITS. If modifier-name is undefined, this signals
521     an error."
522     (let ((res (cdr (assoc modifier-name *modifiers-to-internal-masks*
523     :test #'string-equal))))
524     (unless res (error "Undefined key-event modifier -- ~S." modifier-name))
525     res))
526    
527    
528    
529     ;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT.
530    
531 ram 1.1.1.9 (defvar *keysym-high-bytes*)
532 ram 1.1
533     (defconstant modifier-bits-limit (ash 1 modifier-count-limit))
534    
535     ;;; GET-KEY-EVENT -- Internal.
536     ;;;
537     ;;; This finds the key-event specified by keysym and bits. If the key-event
538     ;;; does not already exist, this creates it. This assumes keysym is defined,
539     ;;; and if it isn't, this will make a key-event anyway that will cause an
540     ;;; error when the system tries to print it.
541     ;;;
542     (defun get-key-event (keysym bits)
543     (let* ((high-byte (ash keysym -8))
544     (low-byte-vector (svref *keysym-high-bytes* high-byte)))
545     (unless low-byte-vector
546 wlott 1.1.1.2 (let ((new-vector (make-array 256 :initial-element nil)))
547 ram 1.1 (setf (svref *keysym-high-bytes* high-byte) new-vector)
548     (setf low-byte-vector new-vector)))
549     (let* ((low-byte (ldb (byte 8 0) keysym))
550     (bit-vector (svref low-byte-vector low-byte)))
551     (unless bit-vector
552 wlott 1.1.1.2 (let ((new-vector (make-array modifier-bits-limit
553     :initial-element nil)))
554 ram 1.1 (setf (svref low-byte-vector low-byte) new-vector)
555     (setf bit-vector new-vector)))
556     (let ((key-event (svref bit-vector bits)))
557     (if key-event
558     key-event
559     (setf (svref bit-vector bits) (%make-key-event keysym bits)))))))
560    
561     ;;; MAKE-KEY-EVENT -- Public.
562     ;;;
563     (defun make-key-event (object &optional (bits 0))
564     "This returns a key-event described by object with bits. Object is one of
565     keysym, string, or key-event. When object is a key-event, this uses
566     KEY-EVENT-KEYSYM. You can form bits with MAKE-KEY-EVENT-BITS or
567     KEY-EVENT-MODIFIER-MASK."
568     (etypecase object
569     (integer
570     (unless (keysym-names object)
571     (error "~S is an undefined keysym." object))
572     (get-key-event object bits))
573     #|(character
574     (let* ((name (char-name object))
575     (keysym (name-keysym (or name (string object)))))
576     (unless keysym
577     (error "~S is an undefined keysym." object))
578     (get-key-event keysym bits)))|#
579     (string
580     (let ((keysym (name-keysym object)))
581     (unless keysym
582     (error "~S is an undefined keysym." object))
583     (get-key-event keysym bits)))
584     (key-event
585     (get-key-event (key-event-keysym object) bits))))
586    
587     ;;; KEY-EVENT-BIT-P -- Public.
588     ;;;
589     (defun key-event-bit-p (key-event bit-name)
590     "This returns whether key-event has the bit set named by bit-name. This
591     signals an error if bit-name is undefined."
592     (let ((mask (cdr (assoc bit-name *modifiers-to-internal-masks*
593     :test #'string-equal))))
594     (unless mask
595     (error "~S is not a defined modifier." bit-name))
596     (not (zerop (logand (key-event-bits key-event) mask)))))
597    
598    
599    
600     ;;;; KEY-EVENT-CHAR and CHAR-KEY-EVENT.
601    
602     ;;; This maps key-events to characters. Users modify this by SETF'ing
603     ;;; KEY-EVENT-CHAR.
604     ;;;
605 ram 1.1.1.9 (defvar *key-event-characters*)
606 ram 1.1
607     (defun key-event-char (key-event)
608     "Returns the character associated with key-event. This is SETF'able."
609     (check-type key-event key-event)
610     (gethash key-event *key-event-characters*))
611    
612     (defun %set-key-event-char (key-event character)
613     (check-type character character)
614     (check-type key-event key-event)
615     (setf (gethash key-event *key-event-characters*) character))
616     ;;;
617     (defsetf key-event-char %set-key-event-char)
618    
619    
620     ;;; This maps characters to key-events. Users modify this by SETF'ing
621     ;;; CHAR-KEY-EVENT.
622     ;;;
623 ram 1.1.1.9 (defvar *character-key-events*)
624 ram 1.1
625     (defun char-key-event (char)
626     "Returns the key-event associated with char. This is SETF'able."
627     (check-type char character)
628     (svref *character-key-events* (char-code char)))
629    
630     (defun %set-char-key-event (char key-event)
631     (check-type char character)
632     (check-type key-event key-event)
633     (setf (svref *character-key-events* (char-code char)) key-event))
634     ;;;
635     (defsetf char-key-event %set-char-key-event)
636    
637    
638    
639     ;;;; DO-ALPHA-KEY-EVENTS.
640    
641     (defmacro alpha-key-events-loop (var start-keysym end-keysym result body)
642     (let ((n (gensym)))
643     `(do ((,n ,start-keysym (1+ ,n)))
644     ((> ,n ,end-keysym) ,result)
645     (let ((,var (make-key-event ,n 0)))
646     (when (alpha-char-p (key-event-char ,var))
647     ,@body)))))
648    
649     (defmacro do-alpha-key-events ((var kind &optional result) &rest forms)
650 ram 1.1.1.10 "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*)
651 ram 1.1 This macro evaluates each form with var bound to a key-event representing an
652     alphabetic character. Kind is one of :lower, :upper, or :both, and this
653     binds var to each key-event in order as specified in the X11 protocol
654     specification. When :both is specified, this processes lowercase letters
655     first."
656     (case kind
657     (:both
658     `(progn (alpha-key-events-loop ,var 97 122 nil ,forms)
659     (alpha-key-events-loop ,var 65 90 ,result ,forms)))
660     (:lower
661     `(alpha-key-events-loop ,var 97 122 ,result ,forms))
662     (:upper
663     `(alpha-key-events-loop ,var 65 90 ,result ,forms))
664     (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
665     kind))))
666    
667    
668    
669     ;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT.
670    
671     ;;; PRINT-PRETTY-KEY -- Public.
672     ;;;
673     (defun print-pretty-key (key &optional (stream *standard-output*) long-names-p)
674     "This prints key, a key-event or vector of key-events, to stream in a
675     user-expected fashion. Long-names-p indicates whether modifiers should
676     print with their long or short name."
677     (etypecase key
678     (structure (print-pretty-key-event key stream long-names-p))
679     (vector
680     (let ((length-1 (1- (length key))))
681     (dotimes (i (length key))
682     (let ((key-event (aref key i)))
683     (print-pretty-key-event key-event stream long-names-p)
684     (unless (= i length-1) (write-char #\space stream))))))))
685    
686     ;;; PRINT-PRETTY-KEY-EVENT -- Public.
687     ;;;
688     ;;; Note, this makes use of the ordering in the a-list
689     ;;; *modifiers-to-internal-masks* by CDDR'ing down it by starting on a short
690     ;;; name or a long name.
691     ;;;
692     (defun print-pretty-key-event (key-event &optional (stream *standard-output*)
693     long-names-p)
694     "This prints key-event to stream. Long-names-p indicates whether modifier
695     names should appear using the long name or short name."
696     (do ((map (if long-names-p
697     (cdr *modifiers-to-internal-masks*)
698     *modifiers-to-internal-masks*)
699     (cddr map)))
700     ((null map))
701     (when (not (zerop (logand (cdar map) (key-event-bits key-event))))
702     (write-string (caar map) stream)
703     (write-char #\- stream)))
704     (let* ((name (keysym-preferred-name (key-event-keysym key-event)))
705     (spacep (position #\space (the simple-string name))))
706     (when spacep (write-char #\< stream))
707     (write-string name stream)
708     (when spacep (write-char #\> stream))))
709    
710    
711    
712     ;;;; Re-initialization.
713    
714     ;;; RE-INITIALIZE-KEY-EVENTS -- Internal.
715     ;;;
716     (defun re-initialize-key-events ()
717     "This blows away all data associated with keysyms, modifiers, mouse
718     translations, and key-event/characters mapping. Then it re-establishes
719     the system defined key-event modifiers and the system defined CLX
720     modifier mappings to some of those key-event modifiers.
721    
722     When recompiling this file, you should load it and call this function
723     before using any part of the key-event interface, especially before
724     defining all your keysyms and using #k syntax."
725     (setf *keysyms-to-names* (make-hash-table :test #'eql))
726     (setf *names-to-keysyms* (make-hash-table :test #'equal))
727     (setf *modifier-translations* ())
728     (setf *modifiers-to-internal-masks* ())
729     (setf *mouse-translation-info* (make-array 6 :initial-element nil))
730     (setf *modifier-count* 0)
731     (setf *all-modifier-names* ())
732     (setf *keysym-high-bytes* (make-array 256 :initial-element nil))
733     (setf *key-event-characters* (make-hash-table))
734 wlott 1.1.1.2 (setf *character-key-events*
735     (make-array char-code-limit :initial-element nil))
736 ram 1.1
737     (define-key-event-modifier "Hyper" "H")
738     (define-key-event-modifier "Super" "S")
739     (define-key-event-modifier "Meta" "M")
740     (define-key-event-modifier "Control" "C")
741     (define-key-event-modifier "Shift" "Shift")
742     (define-key-event-modifier "Lock" "Lock")
743 wlott 1.1.1.2
744     #+clx (define-clx-modifier (xlib:make-state-mask :shift) "Shift")
745     #+clx (define-clx-modifier (xlib:make-state-mask :mod-1) "Meta")
746     #+clx (define-clx-modifier (xlib:make-state-mask :control) "Control")
747     #+clx (define-clx-modifier (xlib:make-state-mask :lock) "Lock"))
748 ram 1.1.1.9
749     ;;; Initialize stuff if not already initialized.
750     ;;;
751     (unless (boundp '*keysyms-to-names*)
752     (re-initialize-key-events))

  ViewVC Help
Powered by ViewVC 1.1.5