1 ;; keymap.el --- Keymap functions for SXEmacs.
3 ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
6 ;; Maintainer: SXEmacs Development Team
7 ;; Keywords: internals, dumped
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: FSF 19.28.
28 ;; This file is dumped with SXEmacs.
30 ;;; Note: FSF does not have a file keymap.el. This stuff is
33 ;Prevent the \{...} documentation construct
34 ;from mentioning keys that run this command.
38 (put 'undefined 'suppress-keymap t)
45 (globally-declare-fboundp 'read-kbd-macro))
48 "Convert KEYS to the internal Emacs key representation.
49 KEYS should be a string in the format used for saving keyboard macros
50 \(see `insert-kbd-macro')."
51 (if (or (stringp keys)
54 `(read-kbd-macro ,keys)))
56 (defun suppress-keymap (map &optional nodigits)
57 "Make MAP override all normally self-inserting keys to be undefined.
58 Normally, as an exception, digits and minus-sign are set to make prefix args,
59 but optional second arg NODIGITS non-nil treats them like other chars."
60 (substitute-key-definition 'self-insert-command 'undefined map global-map)
62 (let ((string (make-string 1 ?0)))
63 (define-key map "-" 'negative-argument)
64 ;; Make plain numbers do numeric args.
65 (while (<= (aref string 0) ?9)
66 (define-key map string 'digit-argument)
67 (incf (aref string 0))))))
69 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
70 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
71 In other words, OLDDEF is replaced with NEWDEF wherever it appears.
72 Prefix keymaps are checked recursively. If optional fourth argument OLDMAP
73 is specified, we redefine in KEYMAP as NEWDEF those chars which are defined
74 as OLDDEF in OLDMAP, unless that keybinding is already present in KEYMAP.
75 If optional fifth argument PREFIX is non-nil, then only those occurrences of
76 OLDDEF found in keymaps accessible through the keymap bound to PREFIX in
77 KEYMAP are redefined. See also `accessible-keymaps'."
78 (let ((maps (accessible-keymaps (or oldmap keymap) prefix))
79 (shadowing (not (null oldmap)))
82 (setq prefix (car (car maps))
85 ;; Substitute in this keymap
86 (map-keymap #'(lambda (key binding)
87 (if (eq binding olddef)
88 ;; The new bindings always go in KEYMAP even if we
89 ;; found them in OLDMAP or one of its children.
90 ;; If KEYMAP will be shadowing OLDMAP, then do not
91 ;; redefine the key if there is another binding
92 ;; in KEYMAP that will shadow OLDDEF.
94 (lookup-key keymap key))
95 ;; define-key will give an error if a prefix
96 ;; of the key is already defined. Otherwise
97 ;; it will define the key in the map.
98 ;; #### - Perhaps this should be protected?
101 (vconcat prefix (list key))
107 ;; This used to wrap forms into an interactive lambda. It is unclear
108 ;; to me why this is needed in this function. Anyway,
109 ;; `key-or-menu-binding' doesn't do it, so this function no longer
111 (defun insert-key-binding (key) ; modeled after describe-key
112 "Insert the command bound to KEY."
113 (interactive "kInsert command bound to key: ")
114 (let ((defn (key-or-menu-binding key)))
115 (if (or (null defn) (integerp defn))
116 (error "%s is undefined" (key-description key))
117 (if (or (stringp defn) (vectorp defn))
118 (setq defn (key-binding defn))) ;; a keyboard macro
119 (insert (format "%s" defn)))))
121 (defun read-command-or-command-sexp (prompt)
122 "Read a command symbol or command sexp.
123 A command sexp is wrapped in an interactive lambda if needed.
124 Prompts with PROMPT."
125 ;; Todo: it would be better if we could reject symbols that are not
126 ;; commandp (as does 'read-command') but that is not easy to do
127 ;; because we must supply arg4 = require-match = nil for sexp case.
128 (let ((result (car (read-from-string
129 (completing-read prompt obarray 'commandp)))))
130 (if (and (consp result)
131 (not (eq (car result) 'lambda)))
137 (defun local-key-binding (keys &optional accept-defaults)
138 "Return the binding for command KEYS in current local keymap only.
139 KEYS is a string, a vector of events, or a vector of key-description lists
140 as described in the documentation for the `define-key' function.
141 The binding is probably a symbol with a function definition; see
142 the documentation for `lookup-key' for more information."
143 (let ((map (current-local-map)))
145 (lookup-key map keys accept-defaults)
148 (defun global-key-binding (keys &optional accept-defaults)
149 "Return the binding for command KEYS in current global keymap only.
150 KEYS is a string or vector of events, a sequence of keystrokes.
151 The binding is probably a symbol with a function definition; see
152 the documentation for `lookup-key' for more information."
153 (lookup-key (current-global-map) keys accept-defaults))
155 (defun global-set-key (key command)
156 "Give KEY a global binding as COMMAND.
157 COMMAND is a symbol naming an interactively-callable function.
158 KEY is a string, a vector of events, or a vector of key-description lists
159 as described in the documentation for the `define-key' function.
160 Note that if KEY has a local binding in the current buffer
161 that local binding will continue to shadow any global binding."
162 ;;(interactive "KSet key globally: \nCSet key %s to command: ")
163 (interactive (list (setq key (read-key-sequence "Set key globally: "))
164 ;; Command sexps are allowed here so that this arg
165 ;; may be supplied interactively via insert-key-binding.
166 (read-command-or-command-sexp
167 (format "Set key %s to command: "
168 (key-description key)))))
169 (define-key (current-global-map) key command)
172 (defun local-set-key (key command)
173 "Give KEY a local binding as COMMAND.
174 COMMAND is a symbol naming an interactively-callable function.
175 KEY is a string, a vector of events, or a vector of key-description lists
176 as described in the documentation for the `define-key' function.
177 The binding goes in the current buffer's local map,
178 which is shared with other buffers in the same major mode."
179 ;;(interactive "KSet key locally: \nCSet key %s locally to command: ")
180 (interactive (list (setq key (read-key-sequence "Set key locally: "))
181 ;; Command sexps are allowed here so that this arg
182 ;; may be supplied interactively via insert-key-binding.
183 (read-command-or-command-sexp
184 (format "Set key %s locally to command: "
185 (key-description key)))))
186 (if (null (current-local-map))
187 (use-local-map (make-sparse-keymap)))
188 (define-key (current-local-map) key command)
191 (defun global-unset-key (key)
192 "Remove global binding of KEY.
193 KEY is a string, a vector of events, or a vector of key-description lists
194 as described in the documentation for the `define-key' function."
195 (interactive "kUnset key globally: ")
196 (global-set-key key nil))
198 (defun local-unset-key (key)
199 "Remove local binding of KEY.
200 KEY is a string, a vector of events, or a vector of key-description lists
201 as described in the documentation for the `define-key' function."
202 (interactive "kUnset key locally: ")
203 (if (current-local-map)
204 (define-key (current-local-map) key nil)))
207 ;; FSF-inherited brain-death.
208 (defun minor-mode-key-binding (key &optional accept-default)
209 "Find the visible minor mode bindings of KEY.
210 Return an alist of pairs (MODENAME . BINDING), where MODENAME is
211 the symbol which names the minor mode binding KEY, and BINDING is
212 KEY's definition in that mode. In particular, if KEY has no
213 minor-mode bindings, return nil. If the first binding is a
214 non-prefix, all subsequent bindings will be omitted, since they would
215 be ignored. Similarly, the list doesn't include non-prefix bindings
216 that come after prefix bindings.
218 If optional argument ACCEPT-DEFAULT is non-nil, recognize default
219 bindings; see the description of `lookup-key' for more details about this."
220 (let ((tail minor-mode-map-alist)
226 (symbolp (setq s (car a)))
229 ;; indirect-function deals with autoloadable keymaps
230 (setq v (indirect-function (cdr a)))
231 (setq v (lookup-key v key accept-default))
232 ;; Terminate loop, with v set to non-nil value
237 (defun current-minor-mode-maps ()
238 "Return a list of keymaps for the minor modes of the current buffer."
240 (tail minor-mode-map-alist)
246 (symbolp (setq s (car a)))
249 ;; indirect-function deals with autoloadable keymaps
250 (setq v (indirect-function (cdr a)))
251 (setq l (cons v l))))
256 (defun define-prefix-command (name &optional mapvar)
257 "Define COMMAND as a prefix command.
258 A new sparse keymap is stored as COMMAND's function definition.
259 If second optional argument MAPVAR is not specified,
260 COMMAND's value (as well as its function definition) is set to the keymap.
261 If a second optional argument MAPVAR is given and is not `t',
262 the map is stored as its value.
263 Regardless of MAPVAR, COMMAND's function-value is always set to the keymap."
264 (let ((map (make-sparse-keymap name)))
275 ;;; Converting vectors of events to a read-equivalent form.
276 ;;; This is used both by call-interactively (for the command history)
277 ;;; and by macros.el (for saving keyboard macros to a file).
279 ;; #### why does (events-to-keys [backspace]) return "\C-h"?
280 ;; BTW, this function is a mess, and macros.el does *not* use it, in
281 ;; spite of the above comment. `format-kbd-macro' is used to save
282 ;; keyboard macros to a file.
283 (defun events-to-keys (events &optional no-mice)
284 "Given a vector of event objects, returns a vector of key descriptors,
285 or a string (if they all fit in the ASCII range).
286 Optional arg NO-MICE means that button events are not allowed."
287 (if (and events (symbolp events)) (setq events (vector events)))
288 (cond ((stringp events)
290 ((not (vectorp events))
291 (signal 'wrong-type-argument (list 'vectorp events)))
292 ((let* ((length (length events))
293 (string (make-string length 0))
297 (setq ce (aref events i))
298 (or (eventp ce) (setq ce (character-to-event ce)))
299 ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
300 ;; By passing t for the `allow-meta' arg we could get kbd macros
301 ;; with meta in them to translate to the string form instead of
302 ;; the list/symbol form; but I expect that would cause confusion,
303 ;; so let's use the list/symbol form whenever there's
305 (setq c (event-to-character ce))
307 character-set-property
308 (key-press-event-p ce))
309 (cond ((symbolp (event-key ce))
310 (if (get (event-key ce) character-set-property)
311 ;; Don't use a string for `backspace' and `tab' to
312 ;; avoid that unpleasant little ambiguity.
314 ((and (= (event-modifier-bits ce) 1) ;control
315 (integerp (event-key ce)))
316 (let* ((te (character-to-event c)))
317 (if (and (symbolp (event-key te))
318 (get (event-key te) character-set-property))
319 ;; Don't "normalize" (control i) to tab
320 ;; to avoid the ambiguity in the other direction
322 (deallocate-event te)))))
325 (setq i length string nil))
329 (let* ((length (length events))
330 (new (copy-sequence events))
334 (setq event (aref events i))
335 (cond ((key-press-event-p event)
336 (setq mods (event-modifiers event)
337 key (event-key event))
339 (setq key (intern (make-string 1 key))))
341 (nconc mods (cons key nil))
343 ((misc-user-event-p event)
344 (aset new i (list 'menu-selection
345 (event-function event)
346 (event-object event))))
347 ((or (button-press-event-p event)
348 (button-release-event-p event))
351 "Mouse events can't be saved in keyboard macros."))
352 (setq mods (event-modifiers event)
353 key (intern (format "button%d%s"
355 (if (button-release-event-p event)
358 (nconc mods (cons key nil))
360 ((or (and event (symbolp event))
361 (and (consp event) (symbolp (car event))))
364 (signal 'wrong-type-argument (list 'eventp event))))
369 (defun next-key-event ()
370 "Return the next available keyboard event."
372 (while (not (key-press-event-p (setq event (next-command-event))))
373 (dispatch-event event))
376 (defun key-sequence-list-description (keys)
377 "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
378 Argument KEYS can be in any form accepted by `define-key' function."
380 (cond ((vectorp keys)
388 (append (event-modifiers ev) (list (event-key ev))))))
391 (cond ((key-press-event-p key)
392 (funcall event-to-list key))
394 (funcall event-to-list (character-to-event key)))
402 ;;; Support keyboard commands to turn on various modifiers.
404 ;;; These functions -- which are not commands -- each add one modifier
405 ;;; to the following event.
407 (defun event-apply-alt-modifier (ignore-prompt)
408 (event-apply-modifier 'alt))
409 (defun event-apply-super-modifier (ignore-prompt)
410 (event-apply-modifier 'super))
411 (defun event-apply-hyper-modifier (ignore-prompt)
412 (event-apply-modifier 'hyper))
413 (defun event-apply-shift-modifier (ignore-prompt)
414 (event-apply-modifier 'shift))
415 (defun event-apply-control-modifier (ignore-prompt)
416 (event-apply-modifier 'control))
417 (defun event-apply-meta-modifier (ignore-prompt)
418 (event-apply-modifier 'meta))
420 ;;; #### `key-translate-map' is ignored for now.
421 (defun event-apply-modifier (symbol)
422 "Return the next key event, with a modifier flag applied.
423 SYMBOL is the name of this modifier, as a symbol.
424 `function-key-map' is scanned for prefix bindings."
425 (let (events binding)
426 ;; read keystrokes scanning `function-key-map'
433 (append events (list (next-key-event)))))))))
434 (if binding ; found a binding
436 ;; allow for several modifiers
437 (if (and (symbolp binding) (fboundp binding))
438 (setq binding (funcall binding nil)))
439 (setq events (append binding nil))
440 ;; put remaining keystrokes back into input queue
441 (setq unread-command-events
442 (mapcar 'character-to-event (cdr events))))
443 (setq unread-command-events (cdr events)))
444 ;; add a modifier SYMBOL to the first keystroke or event
446 (append (list symbol)
448 (aref (key-sequence-list-description (car events)) 0))))))
450 (defun synthesize-keysym (ignore-prompt)
451 "Read a sequence of keys, and returned the corresponding key symbol.
452 The characters must be from the [-_a-zA-Z0-9]. Reading is terminated
453 by RET (which is discarded)."
457 (setq event (next-key-event))
458 (cond ((and (setq char (event-to-character event))
459 (or (memq char '(?- ?_))
460 (eq ?w (char-syntax char (standard-syntax-table)))))
461 ;; Advance a character.
463 ((or (memq char '(?\r ?\n))
464 (memq (event-key event) '(return newline)))
465 ;; Legal termination.
466 (setq continuep nil))
468 ;; Illegal character.
469 (error "Illegal character in keysym: %c" char))
472 (error "Event has no character equivalent: %s" event))))
473 (vector (intern (concat "" (nreverse list))))))
475 ;; This looks dirty. The following code should maybe go to another
476 ;; file, and `create-console-hook' should maybe default to nil.
480 (letf (((selected-console) console))
481 (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
482 (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
483 (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
484 (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
485 (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
486 (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
487 (define-key function-key-map [?\C-x ?@ ?k] 'synthesize-keysym))))
491 ;;; keymap.el ends here