5 (defstruct key char control meta alt shift hyper super
)
7 ;; ((char :type character :initarg :char :reader key-char)
8 ;; (control :type boolean :initform nil :initarg :control :reader key-control)
9 ;; (meta :type boolean :initform nil :initarg :meta :reader key-meta)
10 ;; (alt :type boolean :initform nil :initarg :alt :reader key-alt)
11 ;; (shift :type boolean :initform nil :initarg :shift :reader key-shift)
12 ;; (hyper :type boolean :initform nil :initarg :hyper :reader key-hyper)
13 ;; (super :type boolean :initform nil :initarg :super :reader key-super))
14 ;; (:documentation "A key event."))
16 (defun print-mods (key)
18 (when (key-control key
) "C-")
19 (when (key-meta key
) "M-")
20 (when (key-alt key
) "A-")
21 (when (key-shift key
) "S-")
22 (when (key-super key
) "s-")
23 (when (key-hyper key
) "H-")))
25 (defun print-key (key)
26 (format nil
"~a~a" (print-mods key
) (or (char-name (key-char key
)) (key-char key
))))
28 (defmethod print-object ((obj key
) stream
)
29 (print-unreadable-object (obj stream
:type t
:identity t
)
30 (format stream
"~s" (print-key obj
))))
32 ;; ;; XXX: This is hacky. Convert the class into a sequence. Maybe we should
33 ;; ;; use defstruct then?
34 ;; (defun key-hashid (event)
36 ;; (key (list (key-char event)
37 ;; (key-control event)
41 ;; (key-super event)))
44 (defvar *current-keymap-theme
* :lice
)
46 (defvar *overriding-terminal-local-map
* nil
47 "Per-terminal keymap that overrides all other local keymaps.
48 If this variable is non-nil, it is used as a keymap instead of the
49 buffer's local map, and the minor mode keymaps and text property keymaps.
50 It also replaces `overriding-local-map'.
52 This variable is intended to let commands such as `universal-argument'
53 set up a different keymap for reading the next command.")
55 (defvar *overriding-local-map
* nil
56 "Keymap that overrides all other local keymaps.
57 If this variable is non-nil, it is used as a keymap--replacing the
58 buffer's local map, the minor mode keymaps, and char property keymaps.")
61 ((parent :initform nil
:initarg
:parent
:accessor keymap-parent
)
62 (prompt :initform nil
:initarg
:prompt
:accessor keymap-prompt
)
63 (themes :initform
(make-hash-table) :accessor keymap-themes
)))
65 (defun make-sparse-keymap (&optional prompt
)
66 "Construct and return a new sparse keymap.
67 The optional arg STRING supplies a menu name for the keymap
68 in case you use it as a menu with `x-popup-menu'."
69 (make-instance 'keymap
:prompt prompt
))
71 (defun get-keymap-theme (keymap theme
)
72 (gethash theme
(keymap-themes keymap
)))
74 (defun get-keymap-theme-create (keymap theme
)
75 (or (get-keymap-theme keymap theme
)
76 (setf (gethash theme
(keymap-themes keymap
)) (make-hash-table :size
200 :test
'equalp
))))
78 (defun define-key (keymap key def
&optional
(theme :lice
))
79 (let ((map (get-keymap-theme-create keymap theme
)))
80 (setf (gethash #|
(key-hashid key
)|
# key map
) def
)))
82 (defun lookup-key-internal (keymap key accept-default theme norecurse
)
83 (let* ((map (get-keymap-theme keymap theme
))
84 ;; some maps may not have a hash table for the theme.
85 (cmd (and map
(gethash #|
(key-hashid key
)|
# key map
))))
87 ;; if the binding is another keymap, then lookup the rest of the key sequence
89 ((and (keymapp cmd
) (not norecurse
))
90 (lookup-key cmd
(cdr key
) accept-default theme
))
92 ;; check parent for binding
93 (when (keymap-parent keymap
)
94 (lookup-key (keymap-parent keymap
) key nil theme
))
96 (and map
(gethash t map
))))))
98 (defun lookup-key (keymap key
&optional accept-default
(theme :lice
))
99 "In keymap KEYMAP, look up key sequence KEY. Return the definition.
100 nil means undefined. See doc of `define-key' for kinds of definitions.
102 Normally, `lookup-key' ignores bindings for t, which act as default
103 bindings, used when nothing else in the keymap applies; this makes it
104 usable as a general function for probing keymaps. However, if the
105 third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
106 recognize the default bindings, just as `read-key-sequence' does."
107 (check-type keymap keymap
)
108 (lookup-key-internal keymap key accept-default theme nil
))
110 (defun keymapp (object)
111 (typep object
'keymap
))
113 (depricate set-keymap-parent
(setf keymap-parent
))
114 (defun set-keymap-parent (keymap parent
)
115 "Modify keymap to set its parent map to parent.
116 Return parent. parent should be nil or another keymap."
117 (setf (keymap-parent keymap
) parent
))
119 (defun make-keymap (&optional string
)
120 (declare (ignore string
))
121 (error 'unimplemented
))
123 (defun map-keymap (function keymap
&optional
(theme :lice
))
124 "Call FUNCTION once for each event binding in KEYMAP.
125 FUNCTION is called with two arguments: the event that is bound, and
126 the definition it is bound to. If the event is an integer, it may be
127 a generic character (see Info node `(elisp)Splitting Characters'), and
128 that means that all actual character events belonging to that generic
129 character are bound to the definition.
131 If KEYMAP has a parent, the parent's bindings are included as well.
132 This works recursively: if the parent has itself a parent, then the
133 grandparent's bindings are also included and so on."
134 (let ((map (get-keymap-theme keymap theme
)))
135 (maphash function map
)
136 (when (keymap-parent keymap
)
137 (map-keymap function
(keymap-parent keymap
) theme
))))
139 (defvar *global-map
* (make-sparse-keymap)
140 "The top level global keymap.")
142 (defvar *ctl-x-4-map
* (make-sparse-keymap)
145 (defvar *ctl-x-map
* (make-sparse-keymap)
148 (defvar *ctl-c-map
* (make-sparse-keymap)
151 (defvar *ctl-h-map
* (make-sparse-keymap)
154 (defvar *current-global-map
* *global-map
*)
156 (defvar *current-kmap
* nil
157 "The key map that the next key event will use to find a
158 corresponding command.")
160 (defun make-ctrl-h-map ()
161 (let ((kmap (make-sparse-keymap)))
162 (define-key kmap
(make-key :char
#\f) 'describe-symbol
)
165 (defun make-ctrl-x-4-map ()
166 (let ((kmap (make-sparse-keymap)))
167 (define-key kmap
(make-key :char
#\b) 'switch-to-buffer-other-window
)
170 (defun make-ctrl-x-map (ctl-x-4-map)
171 (let ((kmap (make-sparse-keymap)))
172 (define-key kmap
(make-key :char
#\e
:control t
) 'eval-last-sexp
)
173 (define-key kmap
(make-key :char
#\b) 'switch-to-buffer
)
174 (define-key kmap
(make-key :char
#\c
:control t
) 'save-buffers-kill-emacs
)
175 (define-key kmap
(make-key :char
#\f :control t
) 'find-file
)
176 (define-key kmap
(make-key :char
#\s
:control t
) 'save-buffer
)
177 (define-key kmap
(make-key :char
#\k
) 'kill-buffer
)
178 (define-key kmap
(make-key :char
#\o
) 'other-window
)
179 (define-key kmap
(make-key :char
#\
1) 'delete-other-windows
)
180 (define-key kmap
(make-key :char
#\
2) 'split-window-vertically
)
181 (define-key kmap
(make-key :char
#\
3) 'split-window-horizontally
)
182 (define-key kmap
(make-key :char
#\x
:control t
) 'exchange-point-and-mark
)
183 (define-key kmap
(make-key :char
#\t :control t
) 'transpose-lines
)
184 (define-key kmap
(make-key :char
#\
4) ctl-x-4-map
)
187 (defun make-ctrl-c-map ()
188 (let ((kmap (make-sparse-keymap)))
191 (defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix
)
192 "Generate self-insert commands for all printable characters. And
194 (let ((kmap (make-sparse-keymap)))
195 (loop for i in
'(#\
0 #\
1 #\
2 #\
3 #\
4 #\
5 #\
6 #\
7 #\
8 #\
9
196 #\a #\b #\c
#\d
#\e
#\f #\g
#\h
#\i
#\j
197 #\k
#\l
#\m
#\n #\o
#\p
#\q
#\r #\s
#\t
198 #\u
#\v #\w
#\x
#\y
#\z
199 #\A
#\B
#\C
#\D
#\E
#\F
#\G
#\H
#\I
#\J
200 #\K
#\L
#\M
#\N
#\O
#\P
#\Q
#\R
#\S
#\T
201 #\U
#\V
#\W
#\X
#\Y
#\Z
202 #\Space
#\
! #\" #\
# #\$
#\%
#\
& #\' #\
(
203 #\
) #\
* #\
+ #\
, #\-
#\.
#\
/ #\
: #\
; #\<
204 #\
= #\
> #\? #\
@ #\
[ #\\ #\
] #\^
#\_
#\
`
206 do
(define-key kmap
(make-key :char i
) 'self-insert-command
))
207 (define-key kmap
(make-key :char
#\Return
) 'newline
)
208 (define-key kmap
(make-key :char
#\Newline
) 'newline
)
209 (define-key kmap
(make-key :char
#\o
:control t
) 'open-line
)
210 (define-key kmap
(make-key :char
#\j
:control t
) 'newline
)
211 (define-key kmap
(make-key :char
#\m
:control t
) 'newline
)
212 (define-key kmap
(make-key :char
#\f :control t
) 'forward-char
)
213 (define-key kmap
(make-key :char
#\f :meta t
) 'forward-word
)
214 (define-key kmap
(make-key :char
#\f :control t
:meta t
) 'forward-sexp
)
215 (define-key kmap
(make-key :char
#\b :control t
:meta t
) 'backward-sexp
)
216 (define-key kmap
(make-key :char
#\n :control t
) 'next-line
)
217 (define-key kmap
(make-key :char
#\p
:control t
) 'previous-line
)
218 (define-key kmap
(make-key :char
#\b :control t
) 'backward-char
)
219 (define-key kmap
(make-key :char
#\b :meta t
) 'backward-word
)
220 (define-key kmap
(make-key :char
#\d
:control t
) 'delete-char
)
221 (define-key kmap
(make-key :char
#\d
:meta t
) 'kill-word
)
222 (define-key kmap
(make-key :char
#\Rubout
:meta t
) 'backward-kill-word
)
223 (define-key kmap
(make-key :char
#\Rubout
) 'delete-backward-char
)
224 (define-key kmap
(make-key :char
#\Delete
) 'delete-backward-char
)
225 (define-key kmap
(make-key :char
#\t :meta t
) 'transpose-words
)
226 (define-key kmap
(make-key :char
#\t :control t
) 'transpose-chars
)
227 ;;(define-key kmap (make-key :char #\h :control t) 'delete-backward-char)
228 (define-key kmap
(make-key :char
#\u
:control t
) 'universal-argument
)
229 (define-key kmap
(make-key :char
#\a :control t
) 'beginning-of-line
)
230 (define-key kmap
(make-key :char
#\e
:control t
) 'end-of-line
)
231 (define-key kmap
(make-key :char
#\g
:control t
) 'keyboard-quit
)
232 (define-key kmap
(make-key :char
#\v :control t
) 'scroll-up
)
233 (define-key kmap
(make-key :char
#\v :meta t
) 'scroll-down
)
234 (define-key kmap
(make-key :char
#\k
:control t
) 'kill-line
)
235 (define-key kmap
(make-key :char
#\w
:control t
) 'kill-region
)
236 (define-key kmap
(make-key :char
#\y
:control t
) 'yank
)
237 (define-key kmap
(make-key :char
#\y
:meta t
) 'yank-pop
)
238 (define-key kmap
(make-key :char
#\w
:meta t
) 'kill-ring-save
)
239 (define-key kmap
(make-key :char
#\
> :meta t
) 'end-of-buffer
)
240 (define-key kmap
(make-key :char
#\
< :meta t
) 'beginning-of-buffer
)
241 (define-key kmap
(make-key :char
#\x
:meta t
) 'execute-extended-command
)
242 (define-key kmap
(make-key :char
#\
: :meta t
) 'eval-expression
)
243 (define-key kmap
(make-key :char
#\Space
:control t
) 'set-mark-command
)
244 (define-key kmap
(make-key :char
#\
` :control t
) 'set-mark-command
)
245 (define-key kmap
(make-key :char
#\
! :meta t
) 'shell-command
)
246 (define-key kmap
(make-key :char
#\Space
:meta t
) 'just-one-space
)
247 (define-key kmap
(make-key :char
#\\ :control t
:meta t
) 'indent-region
)
248 (define-key kmap
(make-key :char
#\a :control t
:meta t
) 'beginning-of-defun
)
249 (define-key kmap
(make-key :char
#\e
:control t
:meta t
) 'end-of-defun
)
250 (define-key kmap
(make-key :char
#\_
:control t
) 'undo
)
251 (define-key kmap
(make-key :char
#\
/ :control t
) 'undo
)
252 (define-key kmap
(make-key :char
#\
} :meta t
) 'forward-paragraph
)
253 (define-key kmap
(make-key :char
#\
{ :meta t
) 'backward-paragraph
)
254 (define-key kmap
(make-key :char
#\x
:control t
) ctl-x-prefix
)
255 (define-key kmap
(make-key :char
#\c
:control t
) ctl-c-prefix
)
256 (define-key kmap
(make-key :char
#\h
:control t
) ctl-h-prefix
)
259 (defun make-global-keymaps ()
260 "Create the default global keymaps and store them in *global-kmap
262 (setf *ctl-x-4-map
* (make-ctrl-x-4-map)
263 *ctl-x-map
* (make-ctrl-x-map *ctl-x-4-map
*)
264 *ctl-c-map
* (make-ctrl-c-map)
265 *ctl-h-map
* (make-ctrl-h-map)
266 *global-map
* (make-global-map *ctl-x-map
* *ctl-c-map
* *ctl-h-map
*)))
268 (defun copy-keymap (keymap)
269 (declare (ignore keymap
))
270 (error 'unimplemented
))
272 (defun command-remapping ()
273 (error 'unimplemented
))
275 (defun key-binding (key &optional accept-default no-remap
)
276 (declare (ignore key accept-default no-remap
))
277 (error 'unimplemented
))
279 (defun local-key-binding ()
280 (error 'unimplemented
))
282 (defun global-key-binding ()
283 (error 'unimplemented
))
285 (defun minor-mode-key-binding ()
286 (error 'unimplemented
))
288 (defun define-prefix-command ()
289 (error 'unimplemented
))
291 (defun use-global-map (keymap)
292 (check-type keymap keymap
)
293 (setf *current-global-map
* keymap
))
295 (defun use-local-map (keymap)
296 "Select KEYMAP as the local keymap.
297 If KEYMAP is nil, that means no local keymap.
299 LICE: a buffer's local map is really the major mode map. Except
300 it might not be in the future."
301 (check-type keymap keymap
)
302 (error 'unimplemented
))
304 (defun current-local-map ()
305 "Return current buffer's local keymap, or nil if it has none.
307 LICE: the local map in really the major mode map. Except it might
308 not be in the future."
309 (buffer-local-map (current-buffer)))
311 (defun current-global-map ()
312 "Return the current global keymap."
313 *current-global-map
*)
315 (defun current-minor-mode-maps ()
316 (error 'unimplemented
))
318 (defun current-active-maps ()
319 (error 'unimplemented
))
321 (defun accessible-keymaps ()
322 (error 'unimplemented
))
324 (defun key-description ()
325 (error 'unimplemented
))
327 (defun describe-vector ()
328 (error 'unimplemented
))
330 (defun single-key-description ()
331 (error 'unimplemented
))
333 (defun text-char-description ()
334 (error 'unimplemented
))
336 (defun where-is-internal ()
337 (error 'unimplemented
))
339 (defun describe-buffer-bindings ()
340 (error 'unimplemented
))
342 (defun apropos-internal ()
343 (error 'unimplemented
))