diff options
Diffstat (limited to 'lisp/compat/keymap.el')
-rw-r--r-- | lisp/compat/keymap.el | 590 |
1 files changed, 590 insertions, 0 deletions
diff --git a/lisp/compat/keymap.el b/lisp/compat/keymap.el new file mode 100644 index 0000000..3e9189f --- /dev/null +++ b/lisp/compat/keymap.el | |||
@@ -0,0 +1,590 @@ | |||
1 | ;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2021-2022 Free Software Foundation, Inc. | ||
4 | |||
5 | ;; This file is part of GNU Emacs. | ||
6 | |||
7 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
8 | ;; it under the terms of the GNU General Public License as published by | ||
9 | ;; the Free Software Foundation, either version 3 of the License, or | ||
10 | ;; (at your option) any later version. | ||
11 | |||
12 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
15 | ;; GNU General Public License for more details. | ||
16 | |||
17 | ;; You should have received a copy of the GNU General Public License | ||
18 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
19 | |||
20 | ;;; Commentary: | ||
21 | |||
22 | ;; This library deals with the "new" keymap binding interface: The | ||
23 | ;; only key syntax allowed by these functions is the `kbd' one. | ||
24 | |||
25 | ;;; Code: | ||
26 | |||
27 | |||
28 | |||
29 | (defun keymap--check (key) | ||
30 | "Signal an error if KEY doesn't have a valid syntax." | ||
31 | (unless (key-valid-p key) | ||
32 | (error "%S is not a valid key definition; see `key-valid-p'" key))) | ||
33 | |||
34 | (defun keymap--compile-check (&rest keys) | ||
35 | (dolist (key keys) | ||
36 | (when (or (vectorp key) | ||
37 | (and (stringp key) (not (key-valid-p key)))) | ||
38 | (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) | ||
39 | |||
40 | (defun keymap-set (keymap key definition) | ||
41 | "Set KEY to DEFINITION in KEYMAP. | ||
42 | KEY is a string that satisfies `key-valid-p'. | ||
43 | |||
44 | DEFINITION is anything that can be a key's definition: | ||
45 | nil (means key is undefined in this keymap), | ||
46 | a command (a Lisp function suitable for interactive calling), | ||
47 | a string (treated as a keyboard macro), | ||
48 | a keymap (to define a prefix key), | ||
49 | a symbol (when the key is looked up, the symbol will stand for its | ||
50 | function definition, which should at that time be one of the above, | ||
51 | or another symbol whose function definition is used, etc.), | ||
52 | a cons (STRING . DEFN), meaning that DEFN is the definition | ||
53 | (DEFN should be a valid definition in its own right) and | ||
54 | STRING is the menu item name (which is used only if the containing | ||
55 | keymap has been created with a menu name, see `make-keymap'), | ||
56 | or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, | ||
57 | or an extended menu item definition. | ||
58 | (See info node `(elisp)Extended Menu Items'.)" | ||
59 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
60 | (keymap--check key) | ||
61 | ;; If we're binding this key to another key, then parse that other | ||
62 | ;; key, too. | ||
63 | (when (stringp definition) | ||
64 | (keymap--check definition) | ||
65 | (setq definition (key-parse definition))) | ||
66 | (define-key keymap (key-parse key) definition)) | ||
67 | |||
68 | (defun keymap-global-set (key command) | ||
69 | "Give KEY a global binding as COMMAND. | ||
70 | COMMAND is the command definition to use; usually it is | ||
71 | a symbol naming an interactively-callable function. | ||
72 | |||
73 | KEY is a string that satisfies `key-valid-p'. | ||
74 | |||
75 | Note that if KEY has a local binding in the current buffer, | ||
76 | that local binding will continue to shadow any global binding | ||
77 | that you make with this function." | ||
78 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
79 | (interactive | ||
80 | (let* ((menu-prompting nil) | ||
81 | (key (read-key-sequence "Set key globally: " nil t))) | ||
82 | (list key | ||
83 | (read-command (format "Set key %s to command: " | ||
84 | (key-description key)))))) | ||
85 | (keymap-set (current-global-map) key command)) | ||
86 | |||
87 | (defun keymap-local-set (key command) | ||
88 | "Give KEY a local binding as COMMAND. | ||
89 | COMMAND is the command definition to use; usually it is | ||
90 | a symbol naming an interactively-callable function. | ||
91 | |||
92 | KEY is a string that satisfies `key-valid-p'. | ||
93 | |||
94 | The binding goes in the current buffer's local map, which in most | ||
95 | cases is shared with all other buffers in the same major mode." | ||
96 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
97 | (interactive "KSet key locally: \nCSet key %s locally to command: ") | ||
98 | (let ((map (current-local-map))) | ||
99 | (unless map | ||
100 | (use-local-map (setq map (make-sparse-keymap)))) | ||
101 | (keymap-set map key command))) | ||
102 | |||
103 | (defun keymap-global-unset (key &optional remove) | ||
104 | "Remove global binding of KEY (if any). | ||
105 | KEY is a string that satisfies `key-valid-p'. | ||
106 | |||
107 | If REMOVE (interactively, the prefix arg), remove the binding | ||
108 | instead of unsetting it. See `keymap-unset' for details." | ||
109 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
110 | (interactive | ||
111 | (list (key-description (read-key-sequence "Set key locally: ")) | ||
112 | current-prefix-arg)) | ||
113 | (keymap-unset (current-global-map) key remove)) | ||
114 | |||
115 | (defun keymap-local-unset (key &optional remove) | ||
116 | "Remove local binding of KEY (if any). | ||
117 | KEY is a string that satisfies `key-valid-p'. | ||
118 | |||
119 | If REMOVE (interactively, the prefix arg), remove the binding | ||
120 | instead of unsetting it. See `keymap-unset' for details." | ||
121 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
122 | (interactive | ||
123 | (list (key-description (read-key-sequence "Unset key locally: ")) | ||
124 | current-prefix-arg)) | ||
125 | (when (current-local-map) | ||
126 | (keymap-unset (current-local-map) key remove))) | ||
127 | |||
128 | (defun keymap-unset (keymap key &optional remove) | ||
129 | "Remove key sequence KEY from KEYMAP. | ||
130 | KEY is a string that satisfies `key-valid-p'. | ||
131 | |||
132 | If REMOVE, remove the binding instead of unsetting it. This only | ||
133 | makes a difference when there's a parent keymap. When unsetting | ||
134 | a key in a child map, it will still shadow the same key in the | ||
135 | parent keymap. Removing the binding will allow the key in the | ||
136 | parent keymap to be used." | ||
137 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
138 | (keymap--check key) | ||
139 | (define-key keymap (key-parse key) nil remove)) | ||
140 | |||
141 | (defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) | ||
142 | "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. | ||
143 | In other words, OLDDEF is replaced with NEWDEF wherever it appears. | ||
144 | Alternatively, if optional fourth argument OLDMAP is specified, we redefine | ||
145 | in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. | ||
146 | |||
147 | If you don't specify OLDMAP, you can usually get the same results | ||
148 | in a cleaner way with command remapping, like this: | ||
149 | (define-key KEYMAP [remap OLDDEF] NEWDEF) | ||
150 | \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" | ||
151 | ;; Don't document PREFIX in the doc string because we don't want to | ||
152 | ;; advertise it. It's meant for recursive calls only. Here's its | ||
153 | ;; meaning | ||
154 | |||
155 | ;; If optional argument PREFIX is specified, it should be a key | ||
156 | ;; prefix, a string. Redefined bindings will then be bound to the | ||
157 | ;; original key, with PREFIX added at the front. | ||
158 | (unless prefix | ||
159 | (setq prefix "")) | ||
160 | (let* ((scan (or oldmap keymap)) | ||
161 | (prefix1 (vconcat prefix [nil])) | ||
162 | (key-substitution-in-progress | ||
163 | (cons scan key-substitution-in-progress))) | ||
164 | ;; Scan OLDMAP, finding each char or event-symbol that | ||
165 | ;; has any definition, and act on it with hack-key. | ||
166 | (map-keymap | ||
167 | (lambda (char defn) | ||
168 | (aset prefix1 (length prefix) char) | ||
169 | (substitute-key-definition-key defn olddef newdef prefix1 keymap)) | ||
170 | scan))) | ||
171 | |||
172 | (defun keymap-set-after (keymap key definition &optional after) | ||
173 | "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. | ||
174 | This is like `keymap-set' except that the binding for KEY is placed | ||
175 | just after the binding for the event AFTER, instead of at the beginning | ||
176 | of the map. Note that AFTER must be an event type (like KEY), NOT a command | ||
177 | \(like DEFINITION). | ||
178 | |||
179 | If AFTER is t or omitted, the new binding goes at the end of the keymap. | ||
180 | AFTER should be a single event type--a symbol or a character, not a sequence. | ||
181 | |||
182 | Bindings are always added before any inherited map. | ||
183 | |||
184 | The order of bindings in a keymap matters only when it is used as | ||
185 | a menu, so this function is not useful for non-menu keymaps." | ||
186 | (declare (indent defun) | ||
187 | (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
188 | (keymap--check key) | ||
189 | (when after | ||
190 | (keymap--check after)) | ||
191 | (define-key-after keymap (key-parse key) definition | ||
192 | (and after (key-parse after)))) | ||
193 | |||
194 | (defun key-parse (keys) | ||
195 | "Convert KEYS to the internal Emacs key representation. | ||
196 | See `kbd' for a descripion of KEYS." | ||
197 | (declare (pure t) (side-effect-free t)) | ||
198 | ;; A pure function is expected to preserve the match data. | ||
199 | (save-match-data | ||
200 | (let ((case-fold-search nil) | ||
201 | (len (length keys)) ; We won't alter keys in the loop below. | ||
202 | (pos 0) | ||
203 | (res [])) | ||
204 | (while (and (< pos len) | ||
205 | (string-match "[^ \t\n\f]+" keys pos)) | ||
206 | (let* ((word-beg (match-beginning 0)) | ||
207 | (word-end (match-end 0)) | ||
208 | (word (substring keys word-beg len)) | ||
209 | (times 1) | ||
210 | key) | ||
211 | ;; Try to catch events of the form "<as df>". | ||
212 | (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) | ||
213 | (setq word (match-string 0 word) | ||
214 | pos (+ word-beg (match-end 0))) | ||
215 | (setq word (substring keys word-beg word-end) | ||
216 | pos word-end)) | ||
217 | (when (string-match "\\([0-9]+\\)\\*." word) | ||
218 | (setq times (string-to-number (substring word 0 (match-end 1)))) | ||
219 | (setq word (substring word (1+ (match-end 1))))) | ||
220 | (cond ((string-match "^<<.+>>$" word) | ||
221 | (setq key (vconcat (if (eq (key-binding [?\M-x]) | ||
222 | 'execute-extended-command) | ||
223 | [?\M-x] | ||
224 | (or (car (where-is-internal | ||
225 | 'execute-extended-command)) | ||
226 | [?\M-x])) | ||
227 | (substring word 2 -2) "\r"))) | ||
228 | ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) | ||
229 | (progn | ||
230 | (setq word (concat (match-string 1 word) | ||
231 | (match-string 3 word))) | ||
232 | (not (string-match | ||
233 | "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" | ||
234 | word)))) | ||
235 | (setq key (list (intern word)))) | ||
236 | ((or (equal word "REM") (string-match "^;;" word)) | ||
237 | (setq pos (string-match "$" keys pos))) | ||
238 | (t | ||
239 | (let ((orig-word word) (prefix 0) (bits 0)) | ||
240 | (while (string-match "^[ACHMsS]-." word) | ||
241 | (setq bits (+ bits | ||
242 | (cdr | ||
243 | (assq (aref word 0) | ||
244 | '((?A . ?\A-\^@) (?C . ?\C-\^@) | ||
245 | (?H . ?\H-\^@) (?M . ?\M-\^@) | ||
246 | (?s . ?\s-\^@) (?S . ?\S-\^@)))))) | ||
247 | (setq prefix (+ prefix 2)) | ||
248 | (setq word (substring word 2))) | ||
249 | (when (string-match "^\\^.$" word) | ||
250 | (setq bits (+ bits ?\C-\^@)) | ||
251 | (setq prefix (1+ prefix)) | ||
252 | (setq word (substring word 1))) | ||
253 | (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") | ||
254 | ("LFD" . "\n") ("TAB" . "\t") | ||
255 | ("ESC" . "\e") ("SPC" . " ") | ||
256 | ("DEL" . "\177"))))) | ||
257 | (when found (setq word (cdr found)))) | ||
258 | (when (string-match "^\\\\[0-7]+$" word) | ||
259 | (let ((n 0)) | ||
260 | (dolist (ch (cdr (string-to-list word))) | ||
261 | (setq n (+ (* n 8) ch -48))) | ||
262 | (setq word (vector n)))) | ||
263 | (cond ((= bits 0) | ||
264 | (setq key word)) | ||
265 | ((and (= bits ?\M-\^@) (stringp word) | ||
266 | (string-match "^-?[0-9]+$" word)) | ||
267 | (setq key (mapcar (lambda (x) (+ x bits)) | ||
268 | (append word nil)))) | ||
269 | ((/= (length word) 1) | ||
270 | (error "%s must prefix a single character, not %s" | ||
271 | (substring orig-word 0 prefix) word)) | ||
272 | ((and (/= (logand bits ?\C-\^@) 0) (stringp word) | ||
273 | ;; We used to accept . and ? here, | ||
274 | ;; but . is simply wrong, | ||
275 | ;; and C-? is not used (we use DEL instead). | ||
276 | (string-match "[@-_a-z]" word)) | ||
277 | (setq key (list (+ bits (- ?\C-\^@) | ||
278 | (logand (aref word 0) 31))))) | ||
279 | (t | ||
280 | (setq key (list (+ bits (aref word 0))))))))) | ||
281 | (when key | ||
282 | (dolist (_ (number-sequence 1 times)) | ||
283 | (setq res (vconcat res key)))))) | ||
284 | (if (and (>= (length res) 4) | ||
285 | (eq (aref res 0) ?\C-x) | ||
286 | (eq (aref res 1) ?\() | ||
287 | (eq (aref res (- (length res) 2)) ?\C-x) | ||
288 | (eq (aref res (- (length res) 1)) ?\))) | ||
289 | (apply #'vector (let ((lres (append res nil))) | ||
290 | ;; Remove the first and last two elements. | ||
291 | (setq lres (cdr (cdr lres))) | ||
292 | (nreverse lres) | ||
293 | (setq lres (cdr (cdr lres))) | ||
294 | (nreverse lres))) | ||
295 | res)))) | ||
296 | |||
297 | (defun key-valid-p (keys) | ||
298 | "Say whether KEYS is a valid key. | ||
299 | A key is a string consisting of one or more key strokes. | ||
300 | The key strokes are separated by single space characters. | ||
301 | |||
302 | Each key stroke is either a single character, or the name of an | ||
303 | event, surrounded by angle brackets. In addition, any key stroke | ||
304 | may be preceded by one or more modifier keys. Finally, a limited | ||
305 | number of characters have a special shorthand syntax. | ||
306 | |||
307 | Here's some example key sequences. | ||
308 | |||
309 | \"f\" (the key 'f') | ||
310 | \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') | ||
311 | \"C-c o\" (a two key sequence of the keys 'c' with the control modifier | ||
312 | and then the key 'o') | ||
313 | \"H-<left>\" (the key named \"left\" with the hyper modifier) | ||
314 | \"M-RET\" (the \"return\" key with a meta modifier) | ||
315 | \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) | ||
316 | |||
317 | These are the characters that have shorthand syntax: | ||
318 | NUL, RET, TAB, LFD, ESC, SPC, DEL. | ||
319 | |||
320 | Modifiers have to be specified in this order: | ||
321 | |||
322 | A-C-H-M-S-s | ||
323 | |||
324 | which is | ||
325 | |||
326 | Alt-Control-Hyper-Meta-Shift-super" | ||
327 | (declare (pure t) (side-effect-free t)) | ||
328 | (and | ||
329 | (stringp keys) | ||
330 | (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) | ||
331 | (save-match-data | ||
332 | (catch 'exit | ||
333 | (let ((prefixes | ||
334 | "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") | ||
335 | (case-fold-search nil)) | ||
336 | (dolist (key (split-string keys " ")) | ||
337 | ;; Every key might have these modifiers, and they should be | ||
338 | ;; in this order. | ||
339 | (when (string-match (concat "\\`" prefixes) key) | ||
340 | (setq key (substring key (match-end 0)))) | ||
341 | (unless (or (and (= (length key) 1) | ||
342 | ;; Don't accept control characters as keys. | ||
343 | (not (< (aref key 0) ?\s)) | ||
344 | ;; Don't accept Meta'd characters as keys. | ||
345 | (or (multibyte-string-p key) | ||
346 | (not (<= 127 (aref key 0) 255)))) | ||
347 | (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) | ||
348 | ;; Don't allow <M-C-down>. | ||
349 | (= (progn | ||
350 | (string-match | ||
351 | (concat "\\`<" prefixes) key) | ||
352 | (match-end 0)) | ||
353 | 1)) | ||
354 | (string-match-p | ||
355 | "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" | ||
356 | key)) | ||
357 | ;; Invalid. | ||
358 | (throw 'exit nil))) | ||
359 | t))))) | ||
360 | |||
361 | (defun key-translate (from to) | ||
362 | "Translate character FROM to TO on the current terminal. | ||
363 | This function creates a `keyboard-translate-table' if necessary | ||
364 | and then modifies one entry in it. | ||
365 | |||
366 | Both KEY and TO are strings that satisfy `key-valid-p'." | ||
367 | (declare (compiler-macro | ||
368 | (lambda (form) (keymap--compile-check from to) form))) | ||
369 | (keymap--check from) | ||
370 | (keymap--check to) | ||
371 | (or (char-table-p keyboard-translate-table) | ||
372 | (setq keyboard-translate-table | ||
373 | (make-char-table 'keyboard-translate-table nil))) | ||
374 | (aset keyboard-translate-table (key-parse from) (key-parse to))) | ||
375 | |||
376 | (defun keymap-lookup (keymap key &optional accept-default no-remap position) | ||
377 | "Return the binding for command KEY. | ||
378 | KEY is a string that satisfies `key-valid-p'. | ||
379 | |||
380 | If KEYMAP is nil, look up in the current keymaps. If non-nil, it | ||
381 | should either be a keymap or a list of keymaps, and only these | ||
382 | keymap(s) will be consulted. | ||
383 | |||
384 | The binding is probably a symbol with a function definition. | ||
385 | |||
386 | Normally, `keymap-lookup' ignores bindings for t, which act as | ||
387 | default bindings, used when nothing else in the keymap applies; | ||
388 | this makes it usable as a general function for probing keymaps. | ||
389 | However, if the optional second argument ACCEPT-DEFAULT is | ||
390 | non-nil, `keymap-lookup' does recognize the default bindings, | ||
391 | just as `read-key-sequence' does. | ||
392 | |||
393 | Like the normal command loop, `keymap-lookup' will remap the | ||
394 | command resulting from looking up KEY by looking up the command | ||
395 | in the current keymaps. However, if the optional third argument | ||
396 | NO-REMAP is non-nil, `keymap-lookup' returns the unmapped | ||
397 | command. | ||
398 | |||
399 | If KEY is a key sequence initiated with the mouse, the used keymaps | ||
400 | will depend on the clicked mouse position with regard to the buffer | ||
401 | and possible local keymaps on strings. | ||
402 | |||
403 | If the optional argument POSITION is non-nil, it specifies a mouse | ||
404 | position as returned by `event-start' and `event-end', and the lookup | ||
405 | occurs in the keymaps associated with it instead of KEY. It can also | ||
406 | be a number or marker, in which case the keymap properties at the | ||
407 | specified buffer position instead of point are used." | ||
408 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
409 | (keymap--check key) | ||
410 | (when (and keymap position) | ||
411 | (error "Can't pass in both keymap and position")) | ||
412 | (if keymap | ||
413 | (let ((value (lookup-key keymap (key-parse key) accept-default))) | ||
414 | (if (and (not no-remap) | ||
415 | (symbolp value)) | ||
416 | (or (command-remapping value) value) | ||
417 | value)) | ||
418 | (key-binding (kbd key) accept-default no-remap position))) | ||
419 | |||
420 | (defun keymap-local-lookup (keys &optional accept-default) | ||
421 | "Return the binding for command KEYS in current local keymap only. | ||
422 | KEY is a string that satisfies `key-valid-p'. | ||
423 | |||
424 | The binding is probably a symbol with a function definition. | ||
425 | |||
426 | If optional argument ACCEPT-DEFAULT is non-nil, recognize default | ||
427 | bindings; see the description of `keymap-lookup' for more details | ||
428 | about this." | ||
429 | (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) | ||
430 | (when-let ((map (current-local-map))) | ||
431 | (keymap-lookup map keys accept-default))) | ||
432 | |||
433 | (defun keymap-global-lookup (keys &optional accept-default message) | ||
434 | "Return the binding for command KEYS in current global keymap only. | ||
435 | KEY is a string that satisfies `key-valid-p'. | ||
436 | |||
437 | The binding is probably a symbol with a function definition. | ||
438 | This function's return values are the same as those of `keymap-lookup' | ||
439 | \(which see). | ||
440 | |||
441 | If optional argument ACCEPT-DEFAULT is non-nil, recognize default | ||
442 | bindings; see the description of `keymap-lookup' for more details | ||
443 | about this. | ||
444 | |||
445 | If MESSAGE (and interactively), message the result." | ||
446 | (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) | ||
447 | (interactive | ||
448 | (list (key-description (read-key-sequence "Look up key in global keymap: ")) | ||
449 | nil t)) | ||
450 | (let ((def (keymap-lookup (current-global-map) keys accept-default))) | ||
451 | (when message | ||
452 | (message "%s is bound to %s globally" keys def)) | ||
453 | def)) | ||
454 | |||
455 | |||
456 | ;;; define-keymap and defvar-keymap | ||
457 | |||
458 | (defun define-keymap--compile (form &rest args) | ||
459 | ;; This compiler macro is only there for compile-time | ||
460 | ;; error-checking; it does not change the call in any way. | ||
461 | (while (and args | ||
462 | (keywordp (car args)) | ||
463 | (not (eq (car args) :menu))) | ||
464 | (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) | ||
465 | (byte-compile-warn "Invalid keyword: %s" (car args))) | ||
466 | (setq args (cdr args)) | ||
467 | (when (null args) | ||
468 | (byte-compile-warn "Uneven number of keywords in %S" form)) | ||
469 | (setq args (cdr args))) | ||
470 | ;; Bindings. | ||
471 | (while args | ||
472 | (let ((key (pop args))) | ||
473 | (when (and (stringp key) (not (key-valid-p key))) | ||
474 | (byte-compile-warn "Invalid `kbd' syntax: %S" key))) | ||
475 | (when (null args) | ||
476 | (byte-compile-warn "Uneven number of key bindings in %S" form)) | ||
477 | (setq args (cdr args))) | ||
478 | form) | ||
479 | |||
480 | (defun define-keymap (&rest definitions) | ||
481 | "Create a new keymap and define KEY/DEFINITION pairs as key bindings. | ||
482 | The new keymap is returned. | ||
483 | |||
484 | Options can be given as keywords before the KEY/DEFINITION | ||
485 | pairs. Available keywords are: | ||
486 | |||
487 | :full If non-nil, create a chartable alist (see `make-keymap'). | ||
488 | If nil (i.e., the default), create a sparse keymap (see | ||
489 | `make-sparse-keymap'). | ||
490 | |||
491 | :suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). | ||
492 | If `nodigits', treat digits like other chars. | ||
493 | |||
494 | :parent If non-nil, this should be a keymap to use as the parent | ||
495 | (see `set-keymap-parent'). | ||
496 | |||
497 | :keymap If non-nil, instead of creating a new keymap, the given keymap | ||
498 | will be destructively modified instead. | ||
499 | |||
500 | :name If non-nil, this should be a string to use as the menu for | ||
501 | the keymap in case you use it as a menu with `x-popup-menu'. | ||
502 | |||
503 | :prefix If non-nil, this should be a symbol to be used as a prefix | ||
504 | command (see `define-prefix-command'). If this is the case, | ||
505 | this symbol is returned instead of the map itself. | ||
506 | |||
507 | KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can | ||
508 | also be the special symbol `:menu', in which case DEFINITION | ||
509 | should be a MENU form as accepted by `easy-menu-define'. | ||
510 | |||
511 | \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" | ||
512 | (declare (indent defun) | ||
513 | (compiler-macro define-keymap--compile)) | ||
514 | (let (full suppress parent name prefix keymap) | ||
515 | ;; Handle keywords. | ||
516 | (while (and definitions | ||
517 | (keywordp (car definitions)) | ||
518 | (not (eq (car definitions) :menu))) | ||
519 | (let ((keyword (pop definitions))) | ||
520 | (unless definitions | ||
521 | (error "Missing keyword value for %s" keyword)) | ||
522 | (let ((value (pop definitions))) | ||
523 | (pcase keyword | ||
524 | (:full (setq full value)) | ||
525 | (:keymap (setq keymap value)) | ||
526 | (:parent (setq parent value)) | ||
527 | (:suppress (setq suppress value)) | ||
528 | (:name (setq name value)) | ||
529 | (:prefix (setq prefix value)) | ||
530 | (_ (error "Invalid keyword: %s" keyword)))))) | ||
531 | |||
532 | (when (and prefix | ||
533 | (or full parent suppress keymap)) | ||
534 | (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) | ||
535 | |||
536 | (when (and keymap full) | ||
537 | (error "Invalid combination: :keymap with :full")) | ||
538 | |||
539 | (let ((keymap (cond | ||
540 | (keymap keymap) | ||
541 | (prefix (define-prefix-command prefix nil name)) | ||
542 | (full (make-keymap name)) | ||
543 | (t (make-sparse-keymap name))))) | ||
544 | (when suppress | ||
545 | (suppress-keymap keymap (eq suppress 'nodigits))) | ||
546 | (when parent | ||
547 | (set-keymap-parent keymap parent)) | ||
548 | |||
549 | ;; Do the bindings. | ||
550 | (while definitions | ||
551 | (let ((key (pop definitions))) | ||
552 | (unless definitions | ||
553 | (error "Uneven number of key/definition pairs")) | ||
554 | (let ((def (pop definitions))) | ||
555 | (if (eq key :menu) | ||
556 | (easy-menu-define nil keymap "" def) | ||
557 | (keymap-set keymap key def))))) | ||
558 | keymap))) | ||
559 | |||
560 | (defmacro defvar-keymap (variable-name &rest defs) | ||
561 | "Define VARIABLE-NAME as a variable with a keymap definition. | ||
562 | See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. | ||
563 | |||
564 | In addition to the keywords accepted by `define-keymap', this | ||
565 | macro also accepts a `:doc' keyword, which (if present) is used | ||
566 | as the variable documentation string. | ||
567 | |||
568 | \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" | ||
569 | (declare (indent 1)) | ||
570 | (let ((opts nil) | ||
571 | doc) | ||
572 | (while (and defs | ||
573 | (keywordp (car defs)) | ||
574 | (not (eq (car defs) :menu))) | ||
575 | (let ((keyword (pop defs))) | ||
576 | (unless defs | ||
577 | (error "Uneven number of keywords")) | ||
578 | (if (eq keyword :doc) | ||
579 | (setq doc (pop defs)) | ||
580 | (push keyword opts) | ||
581 | (push (pop defs) opts)))) | ||
582 | (unless (zerop (% (length defs) 2)) | ||
583 | (error "Uneven number of key/definition pairs: %s" defs)) | ||
584 | `(defvar ,variable-name | ||
585 | (define-keymap ,@(nreverse opts) ,@defs) | ||
586 | ,@(and doc (list doc))))) | ||
587 | |||
588 | (provide 'keymap) | ||
589 | |||
590 | ;;; keymap.el ends here | ||