xemacs-beta: lisp/keymap.el comparison

comparison lisp/keymap.el @ 5923:61d7d7bcbe76 cygwin

merged heads after pull -u

author	Henry Thompson <ht@markup.co.uk>
date	Thu, 05 Feb 2015 17:19:05 +0000
parents	1b984807a299
children	c87b776ab0e1

comparison

equal deleted inserted replaced

-:68639fb08af8
+:61d7d7bcbe76
 (signal 'wrong-type-argument
 (list 'key-press-event-p event))))
 (setq i (1+ i)))
 new))))
-(defun next-key-event ()
+(defun next-key-event (&optional event prompt)
 "Return the next available keyboard event."
-(let (event)
+(while (not (key-press-event-p
-(while (not (key-press-event-p (setq event (next-command-event))))
+(setq event (next-command-event event prompt))))
 (dispatch-event event))
-event))
+event)
 (defun key-sequence-list-description (keys)
 "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
 Argument KEYS can be in any form accepted by `define-key' function.
 The output is always in a canonical form, meaning you can use this
 ;;; #### `key-translate-map' is ignored for now.
 (defun event-apply-modifiers (list)
 "Return the next key event, with a list of modifiers applied.
 LIST describes the names of these modifier, a list of symbols.
 `function-key-map' is scanned for prefix bindings."
-(let (events binding)
+(let (events binding key-sequence-list-description symbol-name)
 ;; read keystrokes scanning `function-key-map'
 (while (keymapp
 	    (setq binding
 		  (lookup-key
 		   function-key-map
 		    (setq events
 			  (append events (list (next-key-event)))))))))
 (if binding				; found a binding
 	(progn
 	  ;; allow for several modifiers
-	  (if (and (symbolp binding) (fboundp binding))
+	  (if (functionp binding)
 	      (setq binding (funcall binding nil)))
 	  (setq events (append binding nil))
 	  ;; put remaining keystrokes back into input queue
 	  (setq unread-command-events
 		(mapcar 'character-to-event (cdr events))))
 (setq unread-command-events (cdr events)))
 ;; add modifiers LIST to the first keystroke or event
+(setf key-sequence-list-description
+(aref (key-sequence-list-description (car events)) 0))
+(if (and (member 'shift list)
+	     (symbolp (car (last key-sequence-list-description)))
+(eql 1 (length
+(setq symbol-name
+(symbol-name
+(car (last key-sequence-list-description))))))
+(not (eql (aref symbol-name 0) (upcase (aref symbol-name 0)))))
+(setf (car (last key-sequence-list-description))
+(intern (upcase symbol-name))
+list (remove* 'shift list)))
 (vector
 (append list
-(set-difference (aref (key-sequence-list-description (car events))
+(set-difference key-sequence-list-description list :stable t)))))
-0)
-list :stable t)))))
 (defun event-apply-modifier (symbol)
 "Return the next key event, with a single modifier applied.
 See `event-apply-modifiers'."
 (event-apply-modifiers (list symbol)))
 (defun synthesize-keysym (ignore-prompt)
-"Read a sequence of keys, and returned the corresponding key symbol.
+"Read a sequence of characters, and return the corresponding keysym.
-The characters must be from the [-_a-zA-Z0-9].  Reading is terminated
+The characters must be ?-, or ?_, or have word syntax.  Reading is
-by RET (which is discarded)."
+terminated by RET (which is discarded)."
+;; This has the disadvantage that only X11 keysyms (and space, backspace
+;; and friends, together with the trivial one-character keysyms) are
+;; recognised, and then only on a build with X11 support which has had an
+;; X11 frame open at some point.
 (let ((continuep t)
 	event char list)
 (while continuep
 (setq event (next-key-event))
 (cond ((and (setq char (event-to-character event))
 	    (t
 	     ;; Illegal event.
 	     (error "Event has no character equivalent: %s" event))))
 (vector (intern (concat "" (nreverse list))))))
+(defun synthesize-unicode-codepoint (ignore-prompt)
+"Read a sequence of hexadecimal digits and return a one-char keyboard macro.
+The character has the Unicode code point corresponding to those hexadecimal
+digits."
+(symbol-macrolet ((first-prompt "Unicode hex input: u"))
+(let* ((prompt first-prompt) (integer 0)
+(extent (make-extent (1- (length first-prompt))
+(length first-prompt) prompt))
+	   character digit-char-p)
+(setf (extent-face extent) 'underline
+	    (extent-property extent 'duplicable) t)
+(while (not (member (setq character
+				;; Discard non-enter non-hex-digit characters,
+				;; as GTK does.
+				(read-char-exclusive prompt))
+			  '(?\r ?\n)))
+(when (setq digit-char-p (digit-char-p character 16))
+(setq integer (logior (lsh integer 4) digit-char-p)
+prompt (concat prompt (list character)))
+(if (>= integer #x110000)
+(error 'args-out-of-range "Not a Unicode code point" integer))
+(set-extent-endpoints extent (1- (length first-prompt))
+(length prompt) prompt)))
+(vector (list (decode-char 'ucs integer))))))
 (define-key function-key-map-parent [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?s] 'event-apply-super-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?m] 'event-apply-meta-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?S] 'event-apply-shift-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?c] 'event-apply-control-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?a] 'event-apply-alt-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?k] 'synthesize-keysym)
+(define-key function-key-map-parent [(control U)] 'synthesize-unicode-codepoint)
 ;; The autoloads for the compose map, and their bindings in
 ;; function-key-map-parent are used by GTK as well as X11. And Julian
 ;; Bradfield, at least, uses x-compose on the TTY, it's reasonable to make
 ;; them generally available.

Mercurial > hg > xemacs-beta

comparison lisp/keymap.el @ 5923:61d7d7bcbe76 cygwin