Mercurial > hg > xemacs-beta

comparison lisp/prim/keymap.el @ 207:e45d5e7c476e r20-4b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b2
author cvs
date Mon, 13 Aug 2007 10:03:52 +0200
parents 850242ba4a81
children
comparison
equal deleted inserted replaced
206:d3e9274cbc4e 207:e45d5e7c476e
345 (aset new i event)) 345 (aset new i event))
346 (t 346 (t
347 (signal 'wrong-type-argument (list 'eventp event)))) 347 (signal 'wrong-type-argument (list 'eventp event))))
348 (setq i (1+ i))) 348 (setq i (1+ i)))
349 new)))) 349 new))))
350
350 351
351 ;FSFmacs #### 352 (defun next-key-event ()
353 "Return the next available keyboard event."
354 (let (event)
355 (while (not (key-press-event-p (setq event (next-event))))
356 (dispatch-event event))
357 event))
358
359 (defun key-sequence-list-description (keys)
360 "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
361 Argument KEYS can be in any form accepted by `define-key' function."
362 (let ((vec
363 (cond ((vectorp keys)
364 keys)
365 ((stringp keys)
366 (vconcat keys))
367 (t
368 (vector keys))))
369 (event-to-list
370 #'(lambda (ev)
371 (append (event-modifiers ev) (list (event-key ev))))))
372 (mapvector
373 #'(lambda (key)
374 (cond ((key-press-event-p key)
375 (funcall event-to-list key))
376 ((characterp key)
377 (funcall event-to-list (character-to-event key)))
378 ((listp key)
379 key)
380 (t
381 (list key))))
382 vec)))
383
384
352 ;;; Support keyboard commands to turn on various modifiers. 385 ;;; Support keyboard commands to turn on various modifiers.
353 386
354 ;;; These functions -- which are not commands -- each add one modifier 387 ;;; These functions -- which are not commands -- each add one modifier
355 ;;; to the following event. 388 ;;; to the following event.
356 389
365 (defun event-apply-control-modifier (ignore-prompt) 398 (defun event-apply-control-modifier (ignore-prompt)
366 (event-apply-modifier 'control)) 399 (event-apply-modifier 'control))
367 (defun event-apply-meta-modifier (ignore-prompt) 400 (defun event-apply-meta-modifier (ignore-prompt)
368 (event-apply-modifier 'meta)) 401 (event-apply-modifier 'meta))
369 402
403 ;;; #### `key-translate-map' is ignored for now.
370 (defun event-apply-modifier (symbol) 404 (defun event-apply-modifier (symbol)
371 "Return the next key event, with a modifier flag applied. 405 "Return the next key event, with a modifier flag applied.
372 SYMBOL is the name of this modifier, as a symbol." 406 SYMBOL is the name of this modifier, as a symbol.
373 (let (event) 407 `function-key-map' is scanned for prefix bindings."
374 (while (not (key-press-event-p (setq event (next-command-event)))) 408 (let (events binding)
375 (dispatch-event event)) 409 ;; read keystrokes scanning `function-key-map'
376 (vconcat (list symbol) 410 (while (keymapp
377 (delq symbol (event-modifiers event)) 411 (setq binding
378 (list (event-key event))))) 412 (lookup-key
413 function-key-map
414 (vconcat
415 (setq events
416 (append events (list (next-key-event)))))))))
417 (if binding ; found a binding
418 (progn
419 ;; allow for several modifiers
420 (if (and (symbolp binding) (fboundp binding))
421 (setq binding (funcall binding nil)))
422 (setq events (append binding nil))
423 ;; put remaining keystrokes back into input queue
424 (setq unread-command-events
425 (mapcar 'character-to-event (cdr events))))
426 (setq unread-command-events (cdr events)))
427 ;; add a modifier SYMBOL to the first keystroke or event
428 (vector
429 (append (list symbol)
430 (delq symbol
431 (aref (key-sequence-list-description (car events)) 0))))))
379 432
380 ;; This looks dirty. The following code should maybe go to another 433 ;; This looks dirty. The following code should maybe go to another
381 ;; file, and `create-console-hook' should maybe default to nil. 434 ;; file, and `create-console-hook' should maybe default to nil.
382 (add-hook 435 (add-hook
383 'create-console-hook 436 'create-console-hook
384 (lambda (console) 437 #'(lambda (console)
385 (letf (((selected-console) console)) 438 (letf (((selected-console) console))
386 (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) 439 (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
387 (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) 440 (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
388 (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) 441 (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
389 (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier) 442 (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)