source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/key-event.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.7 KB
Line 
1;;; -*- Log: hemlock.log; Package: HEMLOCK-EXT -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file implements key-events for representing editor input.  It also
13;;; provides a couple routines to interface this to X11.
14;;;
15;;; Written by Blaine Burks and Bill Chiles.
16;;;
17
18;;; The following are the implementation dependent parts of this code (what
19;;; you would have to change if you weren't using X11):
20;;;    *modifier-translations*
21;;;    DEFINE-CLX-MODIFIER
22;;;    TRANSLATE-KEY-EVENT
23;;;    TRANSLATE-MOUSE-KEY-EVENT
24;;;    DEFINE-KEYSYM
25;;;    DEFINE-MOUSE-KEYSYM
26;;;    DO-ALPHA-KEY-EVENTS
27;;; If the window system didn't use a keysym mechanism to represent keys, you
28;;; would also need to write something that mapped whatever did encode the
29;;; keys to the keysyms defined with DEFINE-KEYSYM.
30;;;
31
32(in-package :hemlock-ext)
33
34
35;;;; Keysym <==> Name translation.
36
37;;; Keysyms are named by case-insensitive names.  However, if the name
38;;; consists of a single character, the name is case-sensitive.
39;;;
40
41;;; This table maps a keysym to a list of names.  The first name is the
42;;; preferred printing name.
43;;;
44(defvar *keysyms-to-names*)
45 
46;;; This table maps all keysym names to the appropriate keysym.
47;;;
48(defvar *names-to-keysyms*)
49
50(declaim (inline name-keysym keysym-names keysym-preferred-name))
51
52(defun name-keysym (name)
53  "This returns the keysym named name.  If name is unknown, this returns nil."
54  (gethash (get-name-case-right name) *names-to-keysyms*))
55
56(defun keysym-names (keysym)
57  "This returns the list of all names for keysym.  If keysym is undefined,
58   this returns nil."
59  (gethash keysym *keysyms-to-names*))
60
61(defun keysym-preferred-name (keysym)
62  "This returns the preferred name for keysym, how it is typically printed.
63   If keysym is undefined, this returns nil."
64  (car (gethash keysym *keysyms-to-names*)))
65
66
67
68;;;; Character key-event stuff.
69
70;;; GET-NAME-CASE-RIGHT -- Internal.
71;;;
72;;; This returns the canonical string for a keysym name for use with
73;;; hash tables.
74;;;
75(defun get-name-case-right (string)
76  (if (= (length string) 1) string (string-downcase string)))
77
78;;; DEFINE-KEYSYM -- Public.
79;;;
80(defun define-keysym (keysym preferred-name &rest other-names)
81  "This establishes a mapping from preferred-name to keysym for purposes of
82   specifying key-events in #k syntax.  Other-names also map to keysym, but the
83   system uses preferred-name when printing key-events.  The names are
84   case-insensitive simple-strings.  Redefining a keysym or re-using names has
85   undefined effects."
86  (setf (gethash keysym *keysyms-to-names*) (cons preferred-name other-names))
87  (dolist (name (cons preferred-name other-names))
88    (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
89
90;;; This is an a-list mapping CLX modifier masks to defined key-event
91;;; modifier names.  DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
92;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
93;;;
94(defvar *modifier-translations*)
95
96;;; This is an ordered a-list mapping defined key-event modifier names to the
97;;; appropriate mask for the modifier.  Modifier names have a short and a long
98;;; version.  For each pair of names for the same mask, the names are
99;;; contiguous in this list, and the short name appears first.
100;;; PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on this.
101;;;
102(defvar *modifiers-to-internal-masks*)
103
104;;; TRANSLATE-KEY-EVENT -- Public.
105;;;
106#+clx
107(defun translate-key-event (display scan-code bits)
108  "Translates the X scan-code and X bits to a key-event.  First this maps
109   scan-code to an X keysym using XLIB:KEYCODE->KEYSYM looking at bits and
110   supplying index as 1 if the X shift bit is on, 0 otherwise.
111
112   If the resulting keysym is undefined, and it is not a modifier keysym, then
113   this signals an error.  If the keysym is a modifier key, then this returns
114   nil.
115
116   If the following conditions are satisfied
117      the keysym is defined
118      the X shift bit is off
119      the X lock bit is on
120      the X keysym represents a lowercase letter
121   then this maps the scan-code again supplying index as 1 this time, treating
122   the X lock bit as a caps-lock bit.  If this results in an undefined keysym,
123   this signals an error.  Otherwise, this makes a key-event with the keysym
124   and bits formed by mapping the X bits to key-event bits.
125
126   If any state bit is set that has no suitable modifier translation, it is
127   passed to XLIB:DEFAULT-KEYSYM-INDEX in order to handle Mode_Switch keys
128   appropriately.
129
130   Otherwise, this makes a key-event with the keysym and bits formed by mapping
131   the X bits to key-event bits."
132  (let ((new-bits 0)
133        shiftp lockp)
134    (dolist (map *modifier-translations*)
135      (unless (zerop (logand (car map) bits))
136        ;; ignore the bits of the mapping for the determination of a key index
137        (setq bits (logxor bits (car map)))
138        (cond
139         ((string-equal (cdr map) "Shift")
140          (setf shiftp t))
141         ((string-equal (cdr map) "Lock")
142          (setf lockp t))
143         (t (setf new-bits
144                  (logior new-bits (key-event-modifier-mask (cdr map))))))))
145    ;; here pass any remaining modifier bits to clx
146    (let* ((index  (and (not (zerop bits))
147                        (xlib:default-keysym-index display scan-code bits)))
148           (keysym (xlib:keycode->keysym display scan-code (or index (if shiftp 1 0)))))
149      (cond ((null (keysym-names keysym))
150             nil)
151            ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
152             (let ((keysym (xlib:keycode->keysym display scan-code 1)))
153               (if (keysym-names keysym)
154                   (make-key-event keysym new-bits)
155                   nil)))
156            (t
157             (make-key-event keysym new-bits))))))
158
159
160
161;;;; Mouse key-event stuff.
162
163;;; Think of this data as a three dimensional array indexed by the following
164;;; domains:
165;;;    1-5
166;;;       for the mouse scan-codes (button numbers) delivered by X.
167;;;    :button-press or :button-release
168;;;       whether the button was pressed or released.
169;;;    :keysym or :shifted-modifier-name
170;;;       whether the X shift bit was set.
171;;; For each button, pressed and released, we store a keysym to be used in a
172;;; key-event representing the button and whether it was pressed or released.
173;;; We also store a modifier name that TRANSLATE-MOUSE-KEY-EVENT turns on
174;;; whenever a mouse event occurs with the X shift bit on.  This is basically
175;;; an archaic feature since we now can specify key-events like the following:
176;;;    #k"shift-leftdown"
177;;; Previously we couldn't, so we mapped the shift bit to a bit we could
178;;; talke about, such as super.
179;;;
180(defvar *mouse-translation-info*)
181
182(eval-when (:compile-toplevel :execute)
183  (defmacro button-press-info (event-dispatch) `(car ,event-dispatch))
184  (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch))
185  (defmacro button-keysym (info) `(car ,info))
186  (defmacro button-shifted-modifier-name (info) `(cdr ,info))
187) ;eval-when
188
189;;; MOUSE-TRANSLATION-INFO -- Internal.
190;;;
191;;; This returns the requested information, :keysym or :shifted-modifier-name,
192;;; for the button cross event-key.  If the information is undefined, this
193;;; signals an error.
194;;;
195(defun mouse-translation-info (button event-key info)
196  (let ((event-dispatch (svref *mouse-translation-info* button)))
197    (unless event-dispatch
198      (error "No defined mouse translation information for button ~S." button))
199    (let ((data (ecase event-key
200                  (:button-press (button-press-info event-dispatch))
201                  (:button-release (button-release-info event-dispatch)))))
202      (unless data
203        (error
204         "No defined mouse translation information for button ~S and event ~S."
205         button event-key))
206      (ecase info
207        (:keysym (button-keysym data))
208        (:shifted-modifier-name (button-shifted-modifier-name data))))))
209
210;;; %SET-MOUSE-TRANSLATION-INFO -- Internal.
211;;;
212;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO
213;;; does, filling in the data structure on an as-needed basis, and stores
214;;; the value for the indicated info.
215;;;
216(defun %set-mouse-translation-info (button event-key info value)
217  (let ((event-dispatch (svref *mouse-translation-info* button)))
218    (unless event-dispatch
219      (setf event-dispatch
220            (setf (svref *mouse-translation-info* button) (cons nil nil))))
221    (let ((data (ecase event-key
222                  (:button-press (button-press-info event-dispatch))
223                  (:button-release (button-release-info event-dispatch)))))
224      (unless data
225        (setf data
226              (ecase event-key
227                (:button-press
228                 (setf (button-press-info event-dispatch) (cons nil nil)))
229                (:button-release
230                 (setf (button-release-info event-dispatch) (cons nil nil))))))
231      (ecase info
232        (:keysym
233         (setf (button-keysym data) value))
234        (:shifted-modifier-name
235         (setf (button-shifted-modifier-name data) value))))))
236;;;
237(defsetf mouse-translation-info %set-mouse-translation-info)
238
239;;; DEFINE-MOUSE-KEYSYM -- Public.
240;;;
241(defun define-mouse-keysym (button keysym name shifted-bit event-key)
242  "This defines keysym named name for the X button cross the X event-key.
243   Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
244   in the key-event it returns whenever the X shift bit is on."
245  (unless (<= 1 button 5)
246    (error "Buttons are number 1-5, not ~D." button))
247  (setf (gethash keysym *keysyms-to-names*) (list name))
248  (setf (gethash  (get-name-case-right name) *names-to-keysyms*) keysym)
249  (setf (mouse-translation-info button event-key :keysym) keysym)
250  (setf (mouse-translation-info button event-key :shifted-modifier-name)
251        shifted-bit))
252
253;;; TRANSLATE-MOUSE-KEY-EVENT -- Public.
254;;;
255(defun translate-mouse-key-event (scan-code bits event-key)
256  "This translates the X button code, scan-code, and modifier bits, bits, for
257   the X event-key into a key-event.  See DEFINE-MOUSE-KEYSYM."
258  (let ((keysym (mouse-translation-info scan-code event-key :keysym))
259        (new-bits 0))
260    (dolist (map *modifier-translations*)
261      (when (logtest (car map) bits)
262        (setf new-bits
263              (if (string-equal (cdr map) "Shift")
264                  (logior new-bits
265                          (key-event-modifier-mask
266                           (mouse-translation-info
267                            scan-code event-key :shifted-modifier-name)))
268                  (logior new-bits
269                          (key-event-modifier-mask (cdr map)))))))
270    (make-key-event keysym new-bits)))
271
272
273
274;;;; Stuff for parsing #k syntax.
275
276
277
278(defstruct (key-event (:print-function %print-key-event)
279                      (:constructor %make-key-event (keysym bits)))
280  (bits nil :type fixnum)
281  (keysym nil :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 'base-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(eval-when (:compile-toplevel :execute :load-toplevel)
427
428(defconstant modifier-count-limit 6
429  "The maximum number of modifiers supported.")
430
431); eval-when
432
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(defun define-clx-modifier (clx-mask modifier-name)
479  "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(defvar *keysym-high-bytes*)
532
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      (let ((new-vector (make-array 256 :initial-element nil)))
547        (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        (let ((new-vector (make-array modifier-bits-limit
553                                      :initial-element nil)))
554          (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(defvar *key-event-characters*)
606
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(defvar *character-key-events*)
624
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  "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*)
651   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  (declare (type (or vector key-event) key) (type stream stream))
678  (etypecase key
679    (key-event (print-pretty-key-event key stream long-names-p))
680    (vector
681     (let ((length-1 (1- (length key))))
682       (dotimes (i (length key))
683         (let ((key-event (aref key i)))
684           (print-pretty-key-event key-event stream long-names-p)
685           (unless (= i length-1) (write-char #\space stream))))))))
686
687;;; PRINT-PRETTY-KEY-EVENT -- Public.
688;;;
689;;; Note, this makes use of the ordering in the a-list
690;;; *modifiers-to-internal-masks* by CDDR'ing down it by starting on a short
691;;; name or a long name.
692;;;
693(defun print-pretty-key-event (key-event &optional (stream *standard-output*)
694                                         long-names-p)
695  "This prints key-event to stream.  Long-names-p indicates whether modifier
696   names should appear using the long name or short name."
697  (do ((map (if long-names-p
698                (cdr *modifiers-to-internal-masks*)
699                *modifiers-to-internal-masks*)
700            (cddr map)))
701      ((null map))
702    (when (not (zerop (logand (cdar map) (key-event-bits key-event))))
703      (write-string (caar map) stream)
704      (write-char #\- stream)))
705  (let* ((name (keysym-preferred-name (key-event-keysym key-event)))
706         (spacep (position #\space (the simple-string name))))
707    (when spacep (write-char #\< stream))
708    (write-string name stream)
709    (when spacep (write-char #\> stream))))
710
711
712
713;;;; Re-initialization.
714
715;;; RE-INITIALIZE-KEY-EVENTS -- Internal.
716;;;
717(defun re-initialize-key-events ()
718  "This blows away all data associated with keysyms, modifiers, mouse
719   translations, and key-event/characters mapping.  Then it re-establishes
720   the system defined key-event modifiers and the system defined CLX
721   modifier mappings to some of those key-event modifiers.
722
723   When recompiling this file, you should load it and call this function
724   before using any part of the key-event interface, especially before
725   defining all your keysyms and using #k syntax."
726  (setf *keysyms-to-names* (make-hash-table :test #'eql))
727  (setf *names-to-keysyms* (make-hash-table :test #'equal))
728  (setf *modifier-translations* ())
729  (setf *modifiers-to-internal-masks* ())
730  (setf *mouse-translation-info* (make-array 6 :initial-element nil))
731  (setf *modifier-count* 0)
732  (setf *all-modifier-names* ())
733  (setf *keysym-high-bytes* (make-array 256 :initial-element nil))
734  (setf *key-event-characters* (make-hash-table))
735  (setf *character-key-events*
736        (make-array char-code-limit :initial-element nil))
737 
738  (define-key-event-modifier "Hyper" "H")
739  (define-key-event-modifier "Super" "S")
740  (define-key-event-modifier "Meta" "M")
741  (define-key-event-modifier "Control" "C")
742  (define-key-event-modifier "Shift" "Shift")
743  (define-key-event-modifier "Lock" "Lock")
744
745  #+clx (define-clx-modifier (xlib:make-state-mask :shift) "Shift")
746  #+clx (define-clx-modifier (xlib:make-state-mask :mod-1) "Meta")
747  #+clx (define-clx-modifier (xlib:make-state-mask :control) "Control")
748  #+clx (define-clx-modifier (xlib:make-state-mask :lock) "Lock"))
749
750;;; Initialize stuff if not already initialized.
751;;;
752(unless (boundp '*keysyms-to-names*)
753  (re-initialize-key-events))
Note: See TracBrowser for help on using the repository browser.