translate.lisp 23.7 KB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

(in-package :xlib)

(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)

(defun define-keysym-set (set first-keysym last-keysym)
  ;; Define all keysyms from first-keysym up to and including
Raymond Toy's avatar
Raymond Toy committed
25 26 27 28 29 30 31 32 33 34
  ;; last-keysym to be in the keysym set named SET.  SET is a keyword
  ;; (i.e., a symbol in the package named KEYWORD).  When the function
  ;; KEYSYM-SET is called with a keysym, the SET of the keysym set to
  ;; which the keysym belongs is returned.
  ;;
  ;; If the range of keysyms defined by first-keysym and last-keysym
  ;; overlaps the range of an existing keysym set, then an error is
  ;; signaled.
  (declare (type keyword set)
	   (type keysym first-keysym last-keysym))
ram's avatar
ram committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
  (when (> first-keysym last-keysym)
    (rotatef first-keysym last-keysym))
  (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
  (dolist (set *keysym-sets*)
    (let ((first (second set))
	  (last (third set)))
      (when (or (<= first first-keysym last)
		(<= first last-keysym last))
	(error "Keysym range overlaps existing set ~s" set))))
  (push (list set first-keysym last-keysym) *keysym-sets*)
  set)

(defun keysym-set (keysym)
  ;; Return the character code set name of keysym
  (declare (type keysym keysym)
ram's avatar
ram committed
50
	   (clx-values keyword))
ram's avatar
ram committed
51 52 53 54 55 56
  (dolist (set *keysym-sets*)
    (let ((first (second set))
	  (last (third set)))
      (when (<= first keysym last)
	(return (first set))))))

fgilham's avatar
fgilham committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro keysym (keysym &rest bytes)
    ;; Build a keysym.
    ;;
    ;; If KEYSYM is an integer, it is used as the most significant
    ;; bits of the keysym, and BYTES are used to specify low order
    ;; bytes. The last parameter is always byte4 of the keysym.  If
    ;; KEYSYM is not an integer, the keysym associated with KEYSYM is
    ;; returned.
    ;;
    ;; This is a macro and not a function macro to promote
    ;; compile-time lookup. All arguments are evaluated.
    ;;
    ;; FIXME: The above means that this shouldn't really be a macro at
    ;; all, but a compiler macro.  Probably, anyway.
    (declare (type t keysym)
	     (type list bytes)
	     (clx-values keysym))
    (typecase keysym
      ((integer 0 *)
       (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
      (otherwise
       (or (car (character->keysyms keysym))
	   (error "~s Isn't the name of a keysym" keysym))))))
ram's avatar
ram committed
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114

(defvar *keysym->character-map*
	(make-hash-table :test (keysym->character-map-test) :size 400))

;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
;; With the following accessor macros. Everything after OBJECT is optional.

(defmacro keysym-mapping-object (keysym-mapping)
  ;; Parameter to translate
  `(first ,keysym-mapping))

(defmacro keysym-mapping-translate (keysym-mapping)
  ;; Function to be called with parameters (display state OBJECT)
  ;; when translating KEYSYM and modifiers and mask are satisfied.
  `(second ,keysym-mapping))

(defmacro keysym-mapping-lowercase (keysym-mapping)
  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
  ;; is the associated lowercase keysym.
  `(third ,keysym-mapping))

(defmacro keysym-mapping-modifiers (keysym-mapping)
  ;; MODIFIERS is either a modifier-mask or list containing intermixed
  ;; keysyms and state-mask-keys specifying when to use this
  ;; keysym-translation.
  `(fourth ,keysym-mapping))

(defmacro keysym-mapping-mask (keysym-mapping)
  ;; MASK is either a modifier-mask or list containing intermixed
  ;; keysyms and state-mask-keys specifying which modifiers to look at
  ;; (i.e.  modifiers not specified are don't-cares)
  `(fifth ,keysym-mapping))

(defvar *default-keysym-translate-mask*
ram's avatar
ram committed
115
	(the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
ram's avatar
ram committed
116 117 118
	     (logand #xff (lognot (make-state-mask :lock))))
  "Default keysym state mask to use during keysym-translation.")

Raymond Toy's avatar
Raymond Toy committed
119
(defun define-keysym (object keysym &key lowercase translate modifiers mask display)
ram's avatar
ram committed
120
  ;; Define the translation from keysym/modifiers to a (usually
Raymond Toy's avatar
Raymond Toy committed
121 122
  ;; character) object.  Any previous keysym definition with KEYSYM
  ;; and MODIFIERS is deleted before the new definition is added.
ram's avatar
ram committed
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
  ;;
  ;; MODIFIERS is either a modifier-mask or list containing intermixed
  ;; keysyms and state-mask-keys specifying when to use this
  ;; keysym-translation.  The default is NIL.
  ;;
  ;; MASK is either a modifier-mask or list containing intermixed
  ;; keysyms and state-mask-keys specifying which modifiers to look at
  ;; (i.e.  modifiers not specified are don't-cares).
  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
  ;; (i.e.  modifiers not specified by modifiers are don't cares)
  ;; The default mask is *default-keysym-translate-mask*
  ;;
  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
  ;; otherwise it will be the default translation for all displays.
  ;;
  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
  ;; is the associated lowercase keysym.  This information is used
  ;; by the keysym-both-case-p predicate (for caps-lock computations)
  ;; and by the keysym-downcase function.
  ;;
  ;; TRANSLATE will be called with parameters (display state OBJECT)
  ;; when translating KEYSYM and modifiers and mask are satisfied.
  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
  ;;                     (or modifiers 0)))
  ;;      when mask and modifiers aren't lists of keysyms]
  ;; The default is #'default-keysym-translate
  ;;
ram's avatar
ram committed
150
  (declare (type (or base-char t) object)
ram's avatar
ram committed
151
	   (type keysym keysym)
ram's avatar
ram committed
152
	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
ram's avatar
ram committed
153
	         modifiers)
ram's avatar
ram committed
154
	   (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
ram's avatar
ram committed
155 156 157
	         mask)
	   (type (or null display) display)
           (type (or null keysym) lowercase)
ram's avatar
ram committed
158
	   (type (or null (function (display card16 t) t)) translate))
ram's avatar
ram committed
159 160 161 162 163 164 165 166 167 168 169
  (flet ((merge-keysym-mappings (new old)
	   ;; Merge new keysym-mapping with list of old mappings.
	   ;; Ensure that the mapping with no modifiers or mask comes first.
	   (let* ((key (keysym-mapping-modifiers new))
		  (merge (delete key old :key #'cadddr :test #'equal)))
	     (if key
		 (nconc merge (list new))
	       (cons new merge))))
	 (mask-check (mask)
	   (unless (or (numberp mask)
		       (dolist (element mask t)
fgilham's avatar
fgilham committed
170
			 (unless (or (find element +state-mask-vector+)
ram's avatar
ram committed
171 172
				     (gethash element *keysym->character-map*))
			   (return nil))))
ram's avatar
ram committed
173
	     (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym)))))))
ram's avatar
ram committed
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
    (let ((entry
	    ;; Create with a single LIST call, to ensure cdr-coding
	    (cond
	      (mask
	       (unless (eq mask :modifiers)
		 (mask-check mask))
	       (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
		 (error "Mask with no modifiers"))
	       (list object translate lowercase modifiers mask))
	      (modifiers (mask-check modifiers)
			 (list object translate lowercase modifiers))
	      (lowercase	(list object translate lowercase))
	      (translate	(list object translate))
	      (t	(list object)))))
      (if display
	  (let ((previous (assoc keysym (display-keysym-translation display))))
	    (if previous
		(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
	      (push (list keysym entry) (display-keysym-translation display))))
	(setf (gethash keysym *keysym->character-map*)
	      (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
    object))

(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
ram's avatar
ram committed
200
  (declare (type (or base-char t) object)
ram's avatar
ram committed
201
	   (type keysym keysym)
ram's avatar
ram committed
202
	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
ram's avatar
ram committed
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
	         modifiers)
	   (type (or null display) display))
  (flet ((match (key entry)
	   (let ((object (car key))
		 (modifiers (cdr key)))
	     (or (eql object (keysym-mapping-object entry))
		 (equal modifiers (keysym-mapping-modifiers entry))))))
    (let* (entry
	   (previous (if display
			 (cdr (setq entry (assoc keysym (display-keysym-translation display))))
		       (gethash keysym *keysym->character-map*)))
	   (key (cons object modifiers)))
      (when (and previous (find key previous :test #'match))
	(setq previous (delete key previous :test #'match))
	(if display
	    (setf (cdr entry) previous)
	  (setf (gethash keysym *keysym->character-map*) previous))))))

(defun keysym-downcase (keysym)
  ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
  (declare (type keysym keysym))
ram's avatar
ram committed
224
  (declare (clx-values keysym))
ram's avatar
ram committed
225 226 227 228 229 230 231
  (let ((translations (gethash keysym *keysym->character-map*)))
    (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))

(defun keysym-uppercase-alphabetic-p (keysym)
  ;; Returns T if keysym is uppercase-alphabetic.
  ;; I.E. If it has a lowercase equivalent.
  (declare (type keysym keysym))
ram's avatar
ram committed
232
  (declare (clx-values (or null keysym)))
ram's avatar
ram committed
233 234 235 236 237 238 239 240 241 242 243 244
  (let ((translations (gethash keysym *keysym->character-map*)))
    (and translations
	 (keysym-mapping-lowercase (first translations)))))

(defun character->keysyms (character &optional display)
  ;; Given a character, return a list of all matching keysyms.
  ;; If DISPLAY is given, translations specific to DISPLAY are used,
  ;; otherwise only global translations are used.
  ;; Implementation dependent function.
  ;; May be slow [i.e. do a linear search over all known keysyms]
  (declare (type t character)
	   (type (or null display) display)
ram's avatar
ram committed
245
	   (clx-values (clx-list keysym)))
ram's avatar
ram committed
246 247 248 249 250 251 252 253 254 255 256 257
  (let ((result nil))
    (when display
      (dolist (mapping (display-keysym-translation display))
	(when (eql character (second mapping))
	  (push (first mapping) result))))
    (maphash #'(lambda (keysym mappings)
		 (dolist (mapping mappings)
		   (when (eql (keysym-mapping-object mapping) character)
		     (pushnew keysym result))))
	     *keysym->character-map*)
    result))

fgilham's avatar
fgilham committed
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant character-set-switch-keysym (keysym 255 126))
  (defconstant left-shift-keysym (keysym 255 225))
  (defconstant right-shift-keysym (keysym 255 226))
  (defconstant left-control-keysym (keysym 255 227))
  (defconstant right-control-keysym (keysym 255 228))
  (defconstant caps-lock-keysym (keysym 255 229))
  (defconstant shift-lock-keysym (keysym 255 230))
  (defconstant left-meta-keysym (keysym 255 231))
  (defconstant right-meta-keysym (keysym 255 232))
  (defconstant left-alt-keysym (keysym 255 233))
  (defconstant right-alt-keysym (keysym 255 234))
  (defconstant left-super-keysym (keysym 255 235))
  (defconstant right-super-keysym (keysym 255 236))
  (defconstant left-hyper-keysym (keysym 255 237))
  (defconstant right-hyper-keysym (keysym 255 238)))
ram's avatar
ram committed
274 275 276 277 278 279 280


;;-----------------------------------------------------------------------------
;; Keysym mapping functions

(defun display-keyboard-mapping (display)
  (declare (type display display))
ram's avatar
ram committed
281
  (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
ram's avatar
ram committed
282 283 284 285 286 287 288
  (or (display-keysym-mapping display)
      (setf (display-keysym-mapping display) (keyboard-mapping display))))

(defun keycode->keysym (display keycode keysym-index)
  (declare (type display display)
	   (type card8 keycode)
	   (type card8 keysym-index)
ram's avatar
ram committed
289
	   (clx-values keysym))
ram's avatar
ram committed
290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
  (let* ((mapping (display-keyboard-mapping display))
	 (keysym (aref mapping keycode keysym-index)))
    (declare (type (simple-array keysym (* *)) mapping)
	     (type keysym keysym))
    ;; The keysym-mapping is brain dammaged.
    ;; Mappings for both-case alphabetic characters have the
    ;; entry for keysym-index zero set to the uppercase keysym
    ;; (this is normally where the lowercase keysym goes), and the
    ;; entry for keysym-index one is zero.
    (cond ((zerop keysym-index)			; Lowercase alphabetic keysyms
	   (keysym-downcase keysym))
	  ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
	   (aref mapping keycode 0))
	  (t keysym))))

(defun keysym->character (display keysym &optional (state 0))
  ;; Find the character associated with a keysym.
ram's avatar
ram committed
307
  ;; STATE can be used to set character attributes.
ram's avatar
ram committed
308 309 310 311
  ;; Implementation dependent function.
  (declare (type display display)
	   (type keysym keysym)
	   (type card16 state))
ram's avatar
ram committed
312
  (declare (clx-values (or null character)))
ram's avatar
ram committed
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
  (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
	 (mapping (or ;; Find the matching display mapping
		      (dolist (mapping display-mappings)
			(when (mapping-matches-p display state mapping)
			  (return mapping)))
		      ;; Find the matching static mapping
		      (dolist (mapping (gethash keysym *keysym->character-map*))
			(when (mapping-matches-p display state mapping)
			  (return mapping))))))
    (when mapping
      (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
	       display state (keysym-mapping-object mapping)))))

(defun mapping-matches-p (display state mapping)
  ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
  (declare (type display display)
	   (type mask16 state)
	   (type list mapping))
331
  (declare (clx-values generalized-boolean))
ram's avatar
ram committed
332 333 334 335 336 337 338 339
  (flet
    ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
       ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
       ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
       ;; otherwise ignore unknown modifiers.
       (declare (type list display-mapping)	; Alist of (keysym . mask)
		(type (or mask16 list) modifiers)
		(type mask16 mask))
ram's avatar
ram committed
340
       (declare (clx-values (or null mask16)))
ram's avatar
ram committed
341 342 343 344
       (if (numberp modifiers)
	   modifiers
	 (dolist (modifier modifiers mask)
	   (declare (type symbol modifier))
fgilham's avatar
fgilham committed
345
	   (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq)))
ram's avatar
ram committed
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371
	     (setq mask
		   (logior mask
			   (if bit
			       (ash 1 bit)
			     (or (cdr (assoc modifier display-mapping))
				 ;; bad modifier
				 (if errorp
				     (return-from modifiers->mask nil)
				   0))))))))))

    (let* ((display-mapping (get-display-modifier-mapping display))
	   (mapping-modifiers (keysym-mapping-modifiers mapping))
	   (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
			  (return-from mapping-matches-p nil)))
	   (mapping-mask (or (keysym-mapping-mask mapping)	; If no mask, use the default.
			     (if mapping-modifiers	        ; If no modifiers, match anything.
				 *default-keysym-translate-mask*
			       0)))
	   (mask (if (eq mapping-mask :modifiers)
		     modifiers
		   (modifiers->mask display-mapping mapping-mask nil))))
      (declare (type mask16 modifiers mask))
      (= (logand state mask) modifiers))))

(defun default-keysym-index (display keycode state)
  ;; Returns a keysym-index for use with keycode->character
ram's avatar
ram committed
372
  (declare (clx-values card8))
ram's avatar
ram committed
373
  (macrolet ((keystate-p (state keyword)
fgilham's avatar
fgilham committed
374
	       `(logbitp ,(position keyword +state-mask-vector+) ,state)))
ram's avatar
ram committed
375 376 377 378 379 380
    (let* ((mapping (display-keyboard-mapping display))
	   (keysyms-per-keycode (array-dimension mapping 1))
	   (symbolp (and (> keysyms-per-keycode 2)
			 (state-keysymp display state character-set-switch-keysym)))
	   (result (if symbolp 2 0)))
      (declare (type (simple-array keysym (* *)) mapping)
381
	       (type generalized-boolean symbolp)
ram's avatar
ram committed
382 383 384 385 386 387 388 389 390 391 392 393 394
	       (type card8 keysyms-per-keycode result))
      (when (and (< result keysyms-per-keycode)
		 (keysym-shift-p display state (keysym-uppercase-alphabetic-p
						 (aref mapping keycode 0))))
	(incf result))
      result)))

(defun keysym-shift-p (display state uppercase-alphabetic-p &key
		       shift-lock-xors
		       (control-modifiers
			 '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
  (declare (type display display)
	   (type card16 state)
395 396
	   (type generalized-boolean uppercase-alphabetic-p)
	   (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
ram's avatar
ram committed
397
	                                  ;;; as neither if the character is alphabetic.
398
  (declare (clx-values generalized-boolean))
ram's avatar
ram committed
399
  (macrolet ((keystate-p (state keyword)
fgilham's avatar
fgilham committed
400
	       `(logbitp ,(position keyword +state-mask-vector+) ,state)))
ram's avatar
ram committed
401 402 403 404 405 406 407 408 409
    (let* ((controlp (or (keystate-p state :control)
			 (dolist (modifier control-modifiers)
			   (when (state-keysymp display state modifier)
			     (return t)))))
	   (shiftp (keystate-p state :shift))
	   (lockp  (keystate-p state :lock))
	   (alphap (or uppercase-alphabetic-p
		       (not (state-keysymp display #.(make-state-mask :lock)
					   caps-lock-keysym)))))
410
      (declare (type generalized-boolean controlp shiftp lockp alphap))
ram's avatar
ram committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
      ;; Control keys aren't affected by lock
      (unless controlp
	;; Not a control character - check state of lock modifier
	(when (and lockp
		   alphap
		   (or (not shiftp) shift-lock-xors))	; Lock doesn't unshift unless shift-lock-xors
	  (setq shiftp (not shiftp))))
      shiftp)))

;;; default-keysym-index implements the following tables:
;;;
;;; control shift caps-lock character               character
;;;   0       0       0       #\a                      #\8
;;;   0       0       1       #\A                      #\8
;;;   0       1       0       #\A                      #\*
;;;   0       1       1       #\A                      #\*
;;;   1       0       0       #\control-A              #\control-8
;;;   1       0       1       #\control-A              #\control-8
;;;   1       1       0       #\control-shift-a        #\control-*
;;;   1       1       1       #\control-shift-a        #\control-*
;;;
;;; control shift shift-lock character               character
;;;   0       0       0       #\a                      #\8
;;;   0       0       1       #\A                      #\*
;;;   0       1       0       #\A                      #\*
;;;   0       1       1       #\A                      #\8
;;;   1       0       0       #\control-A              #\control-8
;;;   1       0       1       #\control-A              #\control-*
;;;   1       1       0       #\control-shift-a        #\control-*
;;;   1       1       1       #\control-shift-a        #\control-8

(defun keycode->character (display keycode state &key keysym-index
	                   (keysym-index-function #'default-keysym-index))
  ;; keysym-index defaults to the result of keysym-index-function which
  ;; is called with the following parameters:
  ;; (char0 state caps-lock-p keysyms-per-keycode)
  ;; where char0 is the "character" object associated with keysym-index 0 and
  ;; caps-lock-p is non-nil when the keysym associated with the lock
  ;; modifier is for caps-lock.
ram's avatar
ram committed
450
  ;; STATE can also used for setting character attributes.
ram's avatar
ram committed
451 452 453 454 455
  ;; Implementation dependent function.
  (declare (type display display)
	   (type card8 keycode)
	   (type card16 state)
	   (type (or null card8) keysym-index)
456
	   (type (or null (function (base-char card16 generalized-boolean card8) card8))
ram's avatar
ram committed
457
		 keysym-index-function))
ram's avatar
ram committed
458
  (declare (clx-values (or null character)))
ram's avatar
ram committed
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488
  (let* ((index (or keysym-index
		    (funcall keysym-index-function display keycode state)))
	 (keysym (if index (keycode->keysym display keycode index) 0)))
    (declare (type (or null card8) index)
	     (type keysym keysym))
    (when (plusp keysym)
      (keysym->character display keysym state))))

(defun get-display-modifier-mapping (display)
  (labels ((keysym-replace (display modifiers mask &aux result)
	     (dolist (modifier modifiers result)
	       (push (cons (keycode->keysym display modifier 0) mask) result))))
    (or (display-modifier-mapping display)
	(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
	    (modifier-mapping display)
	  (setf (display-modifier-mapping display)
		(nconc (keysym-replace display shift #.(make-state-mask :shift))
		       (keysym-replace display lock #.(make-state-mask :lock))
		       (keysym-replace display control #.(make-state-mask :control))
		       (keysym-replace display mod1 #.(make-state-mask :mod-1))
		       (keysym-replace display mod2 #.(make-state-mask :mod-2))
		       (keysym-replace display mod3 #.(make-state-mask :mod-3))
		       (keysym-replace display mod4 #.(make-state-mask :mod-4))
		       (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))

(defun state-keysymp (display state keysym)
  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
  (declare (type display display)
	   (type card16 state)
	   (type keysym keysym))
489
  (declare (clx-values generalized-boolean))
ram's avatar
ram committed
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512
  (let* ((mapping (get-display-modifier-mapping display))
	 (mask (assoc keysym mapping)))
    (and mask (plusp (logand state (cdr mask))))))

(defun mapping-notify (display request start count)
  ;; Called on a mapping-notify event to update
  ;; the keyboard-mapping cache in DISPLAY
  (declare (type display display)
	   (type (member :modifier :keyboard :pointer) request)
	   (type card8 start count)
	   (ignore count start))
  ;; Invalidate the keyboard mapping to force the next key translation to get it
  (case request
    (:modifier 
     (setf (display-modifier-mapping display) nil))
    (:keyboard
     (setf (display-keysym-mapping display) nil))))

(defun keysym-in-map-p (display keysym keymap)
  ;; Returns T if keysym is found in keymap
  (declare (type display display)
	   (type keysym keysym)
	   (type (bit-vector 256) keymap))
513
  (declare (clx-values generalized-boolean))
ram's avatar
ram committed
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
  ;; The keysym may appear in the keymap more than once,
  ;; So we have to search the entire keysym map.
  (do* ((min (display-min-keycode display))
	(max (display-max-keycode display))
	(map (display-keyboard-mapping display))
	(jmax (min 2 (array-dimension map 1)))
	(i min (1+ i)))
      ((> i max))
    (declare (type card8 min max jmax)
	     (type (simple-array keysym (* *)) map))
    (when (and (plusp (aref keymap i))
	       (dotimes (j jmax)
		 (when (= keysym (aref map i j)) (return t))))
      (return t))))

(defun character-in-map-p (display character keymap)
  ;; Implementation dependent function.
  ;; Returns T if character is found in keymap
  (declare (type display display)
	   (type character character)
	   (type (bit-vector 256) keymap))
535
  (declare (clx-values generalized-boolean))
ram's avatar
ram committed
536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553
  ;; Check all one bits in keymap
  (do* ((min (display-min-keycode display))
	(max (display-max-keycode display))
	(jmax (array-dimension (display-keyboard-mapping display) 1))
	(i min (1+ i)))
      ((> i max))
    (declare (type card8 min max jmax))
    (when (and (plusp (aref keymap i))
	       ;; Match when character is in mapping for this keycode
	       (dotimes (j jmax)
		 (when (eql character (keycode->character display i 0 :keysym-index j))
		   (return t))))
      (return t))))

(defun keysym->keycodes (display keysym)
  ;; Return keycodes for keysym, as multiple values
  (declare (type display display)
	   (type keysym keysym))
ram's avatar
ram committed
554
  (declare (clx-values (or null keycode) (or null keycode) (or null keycode)))
ram's avatar
ram committed
555 556 557 558 559 560 561 562 563 564 565 566 567 568
  ;; The keysym may appear in the keymap more than once,
  ;; So we have to search the entire keysym map.
  (do* ((min (display-min-keycode display))
	(max (display-max-keycode display))
	(map (display-keyboard-mapping display))
	(jmax (min 2 (array-dimension map 1)))
	(i min (1+ i))
	(result nil))
      ((> i max) (values-list result))
    (declare (type card8 min max jmax)
	     (type (simple-array keysym (* *)) map))
    (dotimes (j jmax)
      (when (= keysym (aref map i j))
	(push i result)))))