/[cmucl]/src/clx/translate.lisp
ViewVC logotype

Contents of /src/clx/translate.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.5: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
2
3 ;;;
4 ;;; TEXAS INSTRUMENTS INCORPORATED
5 ;;; P.O. BOX 2909
6 ;;; AUSTIN, TEXAS 78769
7 ;;;
8 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9 ;;;
10 ;;; Permission is granted to any individual or institution to use, copy, modify,
11 ;;; and distribute this software, provided that this complete copyright and
12 ;;; permission notice is maintained, intact, in all copies and supporting
13 ;;; documentation.
14 ;;;
15 ;;; Texas Instruments Incorporated provides this software "as is" without
16 ;;; express or implied warranty.
17 ;;;
18
19 #+cmu
20 (ext:file-comment "$Id: translate.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $")
21
22 (in-package :xlib)
23
24 (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
25
26 (defun define-keysym-set (set first-keysym last-keysym)
27 ;; Define all keysyms from first-keysym up to and including
28 ;; last-keysym to be in SET (returned from the keysym-set function).
29 ;; Signals an error if the keysym range overlaps an existing set.
30 (declare (type keyword set)
31 (type keysym first-keysym last-keysym))
32 (when (> first-keysym last-keysym)
33 (rotatef first-keysym last-keysym))
34 (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
35 (dolist (set *keysym-sets*)
36 (let ((first (second set))
37 (last (third set)))
38 (when (or (<= first first-keysym last)
39 (<= first last-keysym last))
40 (error "Keysym range overlaps existing set ~s" set))))
41 (push (list set first-keysym last-keysym) *keysym-sets*)
42 set)
43
44 (defun keysym-set (keysym)
45 ;; Return the character code set name of keysym
46 (declare (type keysym keysym)
47 (clx-values keyword))
48 (dolist (set *keysym-sets*)
49 (let ((first (second set))
50 (last (third set)))
51 (when (<= first keysym last)
52 (return (first set))))))
53
54 (eval-when (:compile-toplevel :load-toplevel :execute)
55 (defmacro keysym (keysym &rest bytes)
56 ;; Build a keysym.
57 ;;
58 ;; If KEYSYM is an integer, it is used as the most significant
59 ;; bits of the keysym, and BYTES are used to specify low order
60 ;; bytes. The last parameter is always byte4 of the keysym. If
61 ;; KEYSYM is not an integer, the keysym associated with KEYSYM is
62 ;; returned.
63 ;;
64 ;; This is a macro and not a function macro to promote
65 ;; compile-time lookup. All arguments are evaluated.
66 ;;
67 ;; FIXME: The above means that this shouldn't really be a macro at
68 ;; all, but a compiler macro. Probably, anyway.
69 (declare (type t keysym)
70 (type list bytes)
71 (clx-values keysym))
72 (typecase keysym
73 ((integer 0 *)
74 (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
75 (otherwise
76 (or (car (character->keysyms keysym))
77 (error "~s Isn't the name of a keysym" keysym))))))
78
79 (defvar *keysym->character-map*
80 (make-hash-table :test (keysym->character-map-test) :size 400))
81
82 ;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
83 ;; With the following accessor macros. Everything after OBJECT is optional.
84
85 (defmacro keysym-mapping-object (keysym-mapping)
86 ;; Parameter to translate
87 `(first ,keysym-mapping))
88
89 (defmacro keysym-mapping-translate (keysym-mapping)
90 ;; Function to be called with parameters (display state OBJECT)
91 ;; when translating KEYSYM and modifiers and mask are satisfied.
92 `(second ,keysym-mapping))
93
94 (defmacro keysym-mapping-lowercase (keysym-mapping)
95 ;; LOWERCASE is used for uppercase alphabetic keysyms. The value
96 ;; is the associated lowercase keysym.
97 `(third ,keysym-mapping))
98
99 (defmacro keysym-mapping-modifiers (keysym-mapping)
100 ;; MODIFIERS is either a modifier-mask or list containing intermixed
101 ;; keysyms and state-mask-keys specifying when to use this
102 ;; keysym-translation.
103 `(fourth ,keysym-mapping))
104
105 (defmacro keysym-mapping-mask (keysym-mapping)
106 ;; MASK is either a modifier-mask or list containing intermixed
107 ;; keysyms and state-mask-keys specifying which modifiers to look at
108 ;; (i.e. modifiers not specified are don't-cares)
109 `(fifth ,keysym-mapping))
110
111 (defvar *default-keysym-translate-mask*
112 (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
113 (logand #xff (lognot (make-state-mask :lock))))
114 "Default keysym state mask to use during keysym-translation.")
115
116 (defun define-keysym (object keysym &key lowercase translate modifiers mask display)
117 ;; Define the translation from keysym/modifiers to a (usually
118 ;; character) object. ANy previous keysym definition with
119 ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
120 ;;
121 ;; MODIFIERS is either a modifier-mask or list containing intermixed
122 ;; keysyms and state-mask-keys specifying when to use this
123 ;; keysym-translation. The default is NIL.
124 ;;
125 ;; MASK is either a modifier-mask or list containing intermixed
126 ;; keysyms and state-mask-keys specifying which modifiers to look at
127 ;; (i.e. modifiers not specified are don't-cares).
128 ;; If mask is :MODIFIERS then the mask is the same as the modifiers
129 ;; (i.e. modifiers not specified by modifiers are don't cares)
130 ;; The default mask is *default-keysym-translate-mask*
131 ;;
132 ;; If DISPLAY is specified, the translation will be local to DISPLAY,
133 ;; otherwise it will be the default translation for all displays.
134 ;;
135 ;; LOWERCASE is used for uppercase alphabetic keysyms. The value
136 ;; is the associated lowercase keysym. This information is used
137 ;; by the keysym-both-case-p predicate (for caps-lock computations)
138 ;; and by the keysym-downcase function.
139 ;;
140 ;; TRANSLATE will be called with parameters (display state OBJECT)
141 ;; when translating KEYSYM and modifiers and mask are satisfied.
142 ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
143 ;; (or modifiers 0)))
144 ;; when mask and modifiers aren't lists of keysyms]
145 ;; The default is #'default-keysym-translate
146 ;;
147 (declare (type (or base-char t) object)
148 (type keysym keysym)
149 (type (or null mask16 (clx-list (or keysym state-mask-key)))
150 modifiers)
151 (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
152 mask)
153 (type (or null display) display)
154 (type (or null keysym) lowercase)
155 (type (or null (function (display card16 t) t)) translate))
156 (flet ((merge-keysym-mappings (new old)
157 ;; Merge new keysym-mapping with list of old mappings.
158 ;; Ensure that the mapping with no modifiers or mask comes first.
159 (let* ((key (keysym-mapping-modifiers new))
160 (merge (delete key old :key #'cadddr :test #'equal)))
161 (if key
162 (nconc merge (list new))
163 (cons new merge))))
164 (mask-check (mask)
165 (unless (or (numberp mask)
166 (dolist (element mask t)
167 (unless (or (find element +state-mask-vector+)
168 (gethash element *keysym->character-map*))
169 (return nil))))
170 (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym)))))))
171 (let ((entry
172 ;; Create with a single LIST call, to ensure cdr-coding
173 (cond
174 (mask
175 (unless (eq mask :modifiers)
176 (mask-check mask))
177 (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
178 (error "Mask with no modifiers"))
179 (list object translate lowercase modifiers mask))
180 (modifiers (mask-check modifiers)
181 (list object translate lowercase modifiers))
182 (lowercase (list object translate lowercase))
183 (translate (list object translate))
184 (t (list object)))))
185 (if display
186 (let ((previous (assoc keysym (display-keysym-translation display))))
187 (if previous
188 (setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
189 (push (list keysym entry) (display-keysym-translation display))))
190 (setf (gethash keysym *keysym->character-map*)
191 (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
192 object))
193
194 (defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)
195 ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
196 ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
197 (declare (type (or base-char t) object)
198 (type keysym keysym)
199 (type (or null mask16 (clx-list (or keysym state-mask-key)))
200 modifiers)
201 (type (or null display) display))
202 (flet ((match (key entry)
203 (let ((object (car key))
204 (modifiers (cdr key)))
205 (or (eql object (keysym-mapping-object entry))
206 (equal modifiers (keysym-mapping-modifiers entry))))))
207 (let* (entry
208 (previous (if display
209 (cdr (setq entry (assoc keysym (display-keysym-translation display))))
210 (gethash keysym *keysym->character-map*)))
211 (key (cons object modifiers)))
212 (when (and previous (find key previous :test #'match))
213 (setq previous (delete key previous :test #'match))
214 (if display
215 (setf (cdr entry) previous)
216 (setf (gethash keysym *keysym->character-map*) previous))))))
217
218 (defun keysym-downcase (keysym)
219 ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
220 (declare (type keysym keysym))
221 (declare (clx-values keysym))
222 (let ((translations (gethash keysym *keysym->character-map*)))
223 (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
224
225 (defun keysym-uppercase-alphabetic-p (keysym)
226 ;; Returns T if keysym is uppercase-alphabetic.
227 ;; I.E. If it has a lowercase equivalent.
228 (declare (type keysym keysym))
229 (declare (clx-values (or null keysym)))
230 (let ((translations (gethash keysym *keysym->character-map*)))
231 (and translations
232 (keysym-mapping-lowercase (first translations)))))
233
234 (defun character->keysyms (character &optional display)
235 ;; Given a character, return a list of all matching keysyms.
236 ;; If DISPLAY is given, translations specific to DISPLAY are used,
237 ;; otherwise only global translations are used.
238 ;; Implementation dependent function.
239 ;; May be slow [i.e. do a linear search over all known keysyms]
240 (declare (type t character)
241 (type (or null display) display)
242 (clx-values (clx-list keysym)))
243 (let ((result nil))
244 (when display
245 (dolist (mapping (display-keysym-translation display))
246 (when (eql character (second mapping))
247 (push (first mapping) result))))
248 (maphash #'(lambda (keysym mappings)
249 (dolist (mapping mappings)
250 (when (eql (keysym-mapping-object mapping) character)
251 (pushnew keysym result))))
252 *keysym->character-map*)
253 result))
254
255 (eval-when (:compile-toplevel :load-toplevel :execute)
256 (defconstant character-set-switch-keysym (keysym 255 126))
257 (defconstant left-shift-keysym (keysym 255 225))
258 (defconstant right-shift-keysym (keysym 255 226))
259 (defconstant left-control-keysym (keysym 255 227))
260 (defconstant right-control-keysym (keysym 255 228))
261 (defconstant caps-lock-keysym (keysym 255 229))
262 (defconstant shift-lock-keysym (keysym 255 230))
263 (defconstant left-meta-keysym (keysym 255 231))
264 (defconstant right-meta-keysym (keysym 255 232))
265 (defconstant left-alt-keysym (keysym 255 233))
266 (defconstant right-alt-keysym (keysym 255 234))
267 (defconstant left-super-keysym (keysym 255 235))
268 (defconstant right-super-keysym (keysym 255 236))
269 (defconstant left-hyper-keysym (keysym 255 237))
270 (defconstant right-hyper-keysym (keysym 255 238)))
271
272
273 ;;-----------------------------------------------------------------------------
274 ;; Keysym mapping functions
275
276 (defun display-keyboard-mapping (display)
277 (declare (type display display))
278 (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
279 (or (display-keysym-mapping display)
280 (setf (display-keysym-mapping display) (keyboard-mapping display))))
281
282 (defun keycode->keysym (display keycode keysym-index)
283 (declare (type display display)
284 (type card8 keycode)
285 (type card8 keysym-index)
286 (clx-values keysym))
287 (let* ((mapping (display-keyboard-mapping display))
288 (keysym (aref mapping keycode keysym-index)))
289 (declare (type (simple-array keysym (* *)) mapping)
290 (type keysym keysym))
291 ;; The keysym-mapping is brain dammaged.
292 ;; Mappings for both-case alphabetic characters have the
293 ;; entry for keysym-index zero set to the uppercase keysym
294 ;; (this is normally where the lowercase keysym goes), and the
295 ;; entry for keysym-index one is zero.
296 (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms
297 (keysym-downcase keysym))
298 ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
299 (aref mapping keycode 0))
300 (t keysym))))
301
302 (defun keysym->character (display keysym &optional (state 0))
303 ;; Find the character associated with a keysym.
304 ;; STATE can be used to set character attributes.
305 ;; Implementation dependent function.
306 (declare (type display display)
307 (type keysym keysym)
308 (type card16 state))
309 (declare (clx-values (or null character)))
310 (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
311 (mapping (or ;; Find the matching display mapping
312 (dolist (mapping display-mappings)
313 (when (mapping-matches-p display state mapping)
314 (return mapping)))
315 ;; Find the matching static mapping
316 (dolist (mapping (gethash keysym *keysym->character-map*))
317 (when (mapping-matches-p display state mapping)
318 (return mapping))))))
319 (when mapping
320 (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
321 display state (keysym-mapping-object mapping)))))
322
323 (defun mapping-matches-p (display state mapping)
324 ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
325 (declare (type display display)
326 (type mask16 state)
327 (type list mapping))
328 (declare (clx-values generalized-boolean))
329 (flet
330 ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
331 ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
332 ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
333 ;; otherwise ignore unknown modifiers.
334 (declare (type list display-mapping) ; Alist of (keysym . mask)
335 (type (or mask16 list) modifiers)
336 (type mask16 mask))
337 (declare (clx-values (or null mask16)))
338 (if (numberp modifiers)
339 modifiers
340 (dolist (modifier modifiers mask)
341 (declare (type symbol modifier))
342 (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq)))
343 (setq mask
344 (logior mask
345 (if bit
346 (ash 1 bit)
347 (or (cdr (assoc modifier display-mapping))
348 ;; bad modifier
349 (if errorp
350 (return-from modifiers->mask nil)
351 0))))))))))
352
353 (let* ((display-mapping (get-display-modifier-mapping display))
354 (mapping-modifiers (keysym-mapping-modifiers mapping))
355 (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
356 (return-from mapping-matches-p nil)))
357 (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default.
358 (if mapping-modifiers ; If no modifiers, match anything.
359 *default-keysym-translate-mask*
360 0)))
361 (mask (if (eq mapping-mask :modifiers)
362 modifiers
363 (modifiers->mask display-mapping mapping-mask nil))))
364 (declare (type mask16 modifiers mask))
365 (= (logand state mask) modifiers))))
366
367 (defun default-keysym-index (display keycode state)
368 ;; Returns a keysym-index for use with keycode->character
369 (declare (clx-values card8))
370 (macrolet ((keystate-p (state keyword)
371 `(logbitp ,(position keyword +state-mask-vector+) ,state)))
372 (let* ((mapping (display-keyboard-mapping display))
373 (keysyms-per-keycode (array-dimension mapping 1))
374 (symbolp (and (> keysyms-per-keycode 2)
375 (state-keysymp display state character-set-switch-keysym)))
376 (result (if symbolp 2 0)))
377 (declare (type (simple-array keysym (* *)) mapping)
378 (type generalized-boolean symbolp)
379 (type card8 keysyms-per-keycode result))
380 (when (and (< result keysyms-per-keycode)
381 (keysym-shift-p display state (keysym-uppercase-alphabetic-p
382 (aref mapping keycode 0))))
383 (incf result))
384 result)))
385
386 (defun keysym-shift-p (display state uppercase-alphabetic-p &key
387 shift-lock-xors
388 (control-modifiers
389 '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
390 (declare (type display display)
391 (type card16 state)
392 (type generalized-boolean uppercase-alphabetic-p)
393 (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
394 ;;; as neither if the character is alphabetic.
395 (declare (clx-values generalized-boolean))
396 (macrolet ((keystate-p (state keyword)
397 `(logbitp ,(position keyword +state-mask-vector+) ,state)))
398 (let* ((controlp (or (keystate-p state :control)
399 (dolist (modifier control-modifiers)
400 (when (state-keysymp display state modifier)
401 (return t)))))
402 (shiftp (keystate-p state :shift))
403 (lockp (keystate-p state :lock))
404 (alphap (or uppercase-alphabetic-p
405 (not (state-keysymp display #.(make-state-mask :lock)
406 caps-lock-keysym)))))
407 (declare (type generalized-boolean controlp shiftp lockp alphap))
408 ;; Control keys aren't affected by lock
409 (unless controlp
410 ;; Not a control character - check state of lock modifier
411 (when (and lockp
412 alphap
413 (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors
414 (setq shiftp (not shiftp))))
415 shiftp)))
416
417 ;;; default-keysym-index implements the following tables:
418 ;;;
419 ;;; control shift caps-lock character character
420 ;;; 0 0 0 #\a #\8
421 ;;; 0 0 1 #\A #\8
422 ;;; 0 1 0 #\A #\*
423 ;;; 0 1 1 #\A #\*
424 ;;; 1 0 0 #\control-A #\control-8
425 ;;; 1 0 1 #\control-A #\control-8
426 ;;; 1 1 0 #\control-shift-a #\control-*
427 ;;; 1 1 1 #\control-shift-a #\control-*
428 ;;;
429 ;;; control shift shift-lock character character
430 ;;; 0 0 0 #\a #\8
431 ;;; 0 0 1 #\A #\*
432 ;;; 0 1 0 #\A #\*
433 ;;; 0 1 1 #\A #\8
434 ;;; 1 0 0 #\control-A #\control-8
435 ;;; 1 0 1 #\control-A #\control-*
436 ;;; 1 1 0 #\control-shift-a #\control-*
437 ;;; 1 1 1 #\control-shift-a #\control-8
438
439 (defun keycode->character (display keycode state &key keysym-index
440 (keysym-index-function #'default-keysym-index))
441 ;; keysym-index defaults to the result of keysym-index-function which
442 ;; is called with the following parameters:
443 ;; (char0 state caps-lock-p keysyms-per-keycode)
444 ;; where char0 is the "character" object associated with keysym-index 0 and
445 ;; caps-lock-p is non-nil when the keysym associated with the lock
446 ;; modifier is for caps-lock.
447 ;; STATE can also used for setting character attributes.
448 ;; Implementation dependent function.
449 (declare (type display display)
450 (type card8 keycode)
451 (type card16 state)
452 (type (or null card8) keysym-index)
453 (type (or null (function (base-char card16 generalized-boolean card8) card8))
454 keysym-index-function))
455 (declare (clx-values (or null character)))
456 (let* ((index (or keysym-index
457 (funcall keysym-index-function display keycode state)))
458 (keysym (if index (keycode->keysym display keycode index) 0)))
459 (declare (type (or null card8) index)
460 (type keysym keysym))
461 (when (plusp keysym)
462 (keysym->character display keysym state))))
463
464 (defun get-display-modifier-mapping (display)
465 (labels ((keysym-replace (display modifiers mask &aux result)
466 (dolist (modifier modifiers result)
467 (push (cons (keycode->keysym display modifier 0) mask) result))))
468 (or (display-modifier-mapping display)
469 (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
470 (modifier-mapping display)
471 (setf (display-modifier-mapping display)
472 (nconc (keysym-replace display shift #.(make-state-mask :shift))
473 (keysym-replace display lock #.(make-state-mask :lock))
474 (keysym-replace display control #.(make-state-mask :control))
475 (keysym-replace display mod1 #.(make-state-mask :mod-1))
476 (keysym-replace display mod2 #.(make-state-mask :mod-2))
477 (keysym-replace display mod3 #.(make-state-mask :mod-3))
478 (keysym-replace display mod4 #.(make-state-mask :mod-4))
479 (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
480
481 (defun state-keysymp (display state keysym)
482 ;; Returns T when a modifier key associated with KEYSYM is on in STATE
483 (declare (type display display)
484 (type card16 state)
485 (type keysym keysym))
486 (declare (clx-values generalized-boolean))
487 (let* ((mapping (get-display-modifier-mapping display))
488 (mask (assoc keysym mapping)))
489 (and mask (plusp (logand state (cdr mask))))))
490
491 (defun mapping-notify (display request start count)
492 ;; Called on a mapping-notify event to update
493 ;; the keyboard-mapping cache in DISPLAY
494 (declare (type display display)
495 (type (member :modifier :keyboard :pointer) request)
496 (type card8 start count)
497 (ignore count start))
498 ;; Invalidate the keyboard mapping to force the next key translation to get it
499 (case request
500 (:modifier
501 (setf (display-modifier-mapping display) nil))
502 (:keyboard
503 (setf (display-keysym-mapping display) nil))))
504
505 (defun keysym-in-map-p (display keysym keymap)
506 ;; Returns T if keysym is found in keymap
507 (declare (type display display)
508 (type keysym keysym)
509 (type (bit-vector 256) keymap))
510 (declare (clx-values generalized-boolean))
511 ;; The keysym may appear in the keymap more than once,
512 ;; So we have to search the entire keysym map.
513 (do* ((min (display-min-keycode display))
514 (max (display-max-keycode display))
515 (map (display-keyboard-mapping display))
516 (jmax (min 2 (array-dimension map 1)))
517 (i min (1+ i)))
518 ((> i max))
519 (declare (type card8 min max jmax)
520 (type (simple-array keysym (* *)) map))
521 (when (and (plusp (aref keymap i))
522 (dotimes (j jmax)
523 (when (= keysym (aref map i j)) (return t))))
524 (return t))))
525
526 (defun character-in-map-p (display character keymap)
527 ;; Implementation dependent function.
528 ;; Returns T if character is found in keymap
529 (declare (type display display)
530 (type character character)
531 (type (bit-vector 256) keymap))
532 (declare (clx-values generalized-boolean))
533 ;; Check all one bits in keymap
534 (do* ((min (display-min-keycode display))
535 (max (display-max-keycode display))
536 (jmax (array-dimension (display-keyboard-mapping display) 1))
537 (i min (1+ i)))
538 ((> i max))
539 (declare (type card8 min max jmax))
540 (when (and (plusp (aref keymap i))
541 ;; Match when character is in mapping for this keycode
542 (dotimes (j jmax)
543 (when (eql character (keycode->character display i 0 :keysym-index j))
544 (return t))))
545 (return t))))
546
547 (defun keysym->keycodes (display keysym)
548 ;; Return keycodes for keysym, as multiple values
549 (declare (type display display)
550 (type keysym keysym))
551 (declare (clx-values (or null keycode) (or null keycode) (or null keycode)))
552 ;; The keysym may appear in the keymap more than once,
553 ;; So we have to search the entire keysym map.
554 (do* ((min (display-min-keycode display))
555 (max (display-max-keycode display))
556 (map (display-keyboard-mapping display))
557 (jmax (min 2 (array-dimension map 1)))
558 (i min (1+ i))
559 (result nil))
560 ((> i max) (values-list result))
561 (declare (type card8 min max jmax)
562 (type (simple-array keysym (* *)) map))
563 (dotimes (j jmax)
564 (when (= keysym (aref map i j))
565 (push i result)))))

  ViewVC Help
Powered by ViewVC 1.1.5