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 (define-condition kbd-parse
(lice-condition)
33 () (:documentation
"Raised when a kbd string failed to parse."))
35 (defun parse-mods (mods end
)
36 "MODS is a sequence of <MOD CHAR> #\- pairs. Return a list suitable
37 for passing as the last argument to (apply #'make-key ...)"
40 (apply #'nconc
(loop for i from
0 below end by
2
41 if
(char/= (char mods
(1+ i
)) #\-
)
42 do
(signal 'kbd-parse
)
43 collect
(case (char mods i
)
46 (#\C
(list :control t
))
50 (t (signal 'kbd-parse
))))))
52 (defun parse-char-name (string)
53 "Return the character whose name is STRING."
55 ((string= string
"RET") #\Newline
)
56 ((string= string
"TAB") #\Tab
))
58 (and (= (length string
) 1)
61 (defun parse-key (string)
62 "Parse STRING and return a key structure."
63 ;; FIXME: we want to return NIL when we get a kbd-parse error
65 (let* ((p (when (> (length string
) 2)
66 (position #\- string
:from-end t
:end
(- (length string
) 1))))
67 (mods (parse-mods string
(if p
(1+ p
) 0)))
68 (ch (parse-char-name (subseq string
(if p
(1+ p
) 0)))))
70 (apply #'make-key
:char ch mods
))))
72 (defun parse-key-seq (keys)
73 "KEYS is a key sequence. Parse it and return the list of keys."
74 (mapcar 'parse-key
(split-string keys
)))
77 "Convert KEYS to the internal Emacs key representation.
78 KEYS should be a string constant in the format used for
79 saving keyboard macros ***(see `insert-kbd-macro')."
80 ;; XXX: define-key needs to be fixed to handle a list of keys
81 (first (parse-key-seq keys
)))
83 ;; ;; XXX: This is hacky. Convert the class into a sequence. Maybe we should
84 ;; ;; use defstruct then?
85 ;; (defun key-hashid (event)
87 ;; (key (list (key-char event)
88 ;; (key-control event)
92 ;; (key-super event)))
95 (defvar *current-keymap-theme
* :lice
)
97 (defvar *overriding-terminal-local-map
* nil
98 "Per-terminal keymap that overrides all other local keymaps.
99 If this variable is non-nil, it is used as a keymap instead of the
100 buffer's local map, and the minor mode keymaps and text property keymaps.
101 It also replaces `overriding-local-map'.
103 This variable is intended to let commands such as `universal-argument'
104 set up a different keymap for reading the next command.")
106 (defvar *overriding-local-map
* nil
107 "Keymap that overrides all other local keymaps.
108 If this variable is non-nil, it is used as a keymap--replacing the
109 buffer's local map, the minor mode keymaps, and char property keymaps.")
112 ((parent :initform nil
:initarg
:parent
:accessor keymap-parent
)
113 (prompt :initform nil
:initarg
:prompt
:accessor keymap-prompt
)
114 (themes :initform
(make-hash-table) :accessor keymap-themes
)))
116 (defun keymapp (object)
117 (typep object
'keymap
))
119 (defun make-sparse-keymap (&optional prompt
)
120 "Construct and return a new sparse keymap.
121 The optional arg STRING supplies a menu name for the keymap
122 in case you use it as a menu with `x-popup-menu'."
123 (make-instance 'keymap
:prompt prompt
))
125 (defun get-keymap-theme (keymap theme
)
126 (gethash theme
(keymap-themes keymap
)))
128 (defun get-keymap-theme-create (keymap theme
)
129 (or (get-keymap-theme keymap theme
)
130 (setf (gethash theme
(keymap-themes keymap
)) (make-hash-table :size
200 :test
'equalp
))))
132 (defun define-key (keymap key def
&optional
(theme :lice
))
133 (let ((map (get-keymap-theme-create keymap theme
)))
134 (setf (gethash #|
(key-hashid key
)|
# key map
) def
)))
136 (defun lookup-key-internal (keymap key accept-default theme norecurse
)
137 (let* ((map (get-keymap-theme keymap theme
))
138 ;; some maps may not have a hash table for the theme.
139 (cmd (and map
(gethash #|
(key-hashid key
)|
# key map
))))
141 ;; if the binding is another keymap, then lookup the rest of the key sequence
143 ((and (keymapp cmd
) (not norecurse
))
144 (lookup-key-internal cmd
(cdr key
) accept-default theme norecurse
))
146 ;; check parent for binding
147 (when (keymap-parent keymap
)
148 (lookup-key-internal (keymap-parent keymap
) key nil theme norecurse
))
150 (and map
(gethash t map
))))))
152 (defun lookup-key (keymap key
&optional accept-default
(theme :lice
))
153 "In keymap KEYMAP, look up key sequence KEY. Return the definition.
154 nil means undefined. See doc of `define-key' for kinds of definitions.
156 Normally, `lookup-key' ignores bindings for t, which act as default
157 bindings, used when nothing else in the keymap applies; this makes it
158 usable as a general function for probing keymaps. However, if the
159 third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
160 recognize the default bindings, just as `read-key-sequence' does."
161 (check-type keymap keymap
)
162 (lookup-key-internal keymap key accept-default theme nil
))
164 (depricate set-keymap-parent
(setf keymap-parent
))
165 (defun set-keymap-parent (keymap parent
)
166 "Modify keymap to set its parent map to parent.
167 Return parent. parent should be nil or another keymap."
168 (setf (keymap-parent keymap
) parent
))
170 (defun make-keymap (&optional string
)
171 (declare (ignore string
))
172 (error "unimplemented"))
174 (defun map-keymap (function keymap
&optional
(theme :lice
))
175 "Call FUNCTION once for each event binding in KEYMAP.
176 FUNCTION is called with two arguments: the event that is bound, and
177 the definition it is bound to. If the event is an integer, it may be
178 a generic character (see Info node `(elisp)Splitting Characters'), and
179 that means that all actual character events belonging to that generic
180 character are bound to the definition.
182 If KEYMAP has a parent, the parent's bindings are included as well.
183 This works recursively: if the parent has itself a parent, then the
184 grandparent's bindings are also included and so on."
185 (let ((map (get-keymap-theme keymap theme
)))
186 (maphash function map
)
187 (when (keymap-parent keymap
)
188 (map-keymap function
(keymap-parent keymap
) theme
))))
190 (defvar *global-map
* (make-sparse-keymap)
191 "The top level global keymap.")
193 (defvar *ctl-x-4-map
* (make-sparse-keymap)
196 (defvar *ctl-x-map
* (make-sparse-keymap)
199 (defvar *ctl-c-map
* (make-sparse-keymap)
202 (defvar *ctl-h-map
* (make-sparse-keymap)
205 (defvar *current-global-map
* *global-map
*)
207 (defvar *current-kmap
* nil
208 "The key map that the next key event will use to find a
209 corresponding command.")
211 (defun make-ctrl-h-map ()
212 (let ((kmap (make-sparse-keymap)))
213 (define-key kmap
(make-key :char
#\f) 'describe-symbol
)
216 (defun make-ctrl-x-4-map ()
217 (let ((kmap (make-sparse-keymap)))
218 (define-key kmap
(make-key :char
#\b) 'switch-to-buffer-other-window
)
221 (defun make-ctrl-x-map (ctl-x-4-map)
222 (let ((kmap (make-sparse-keymap)))
223 (define-key kmap
(make-key :char
#\e
:control t
) 'eval-last-sexp
)
224 (define-key kmap
(make-key :char
#\b) 'switch-to-buffer
)
225 (define-key kmap
(make-key :char
#\c
:control t
) 'save-buffers-kill-emacs
)
226 (define-key kmap
(make-key :char
#\f :control t
) 'find-file
)
227 (define-key kmap
(make-key :char
#\s
:control t
) 'save-buffer
)
228 (define-key kmap
(make-key :char
#\k
) 'kill-buffer
)
229 (define-key kmap
(make-key :char
#\o
) 'other-window
)
230 (define-key kmap
(make-key :char
#\
1) 'delete-other-windows
)
231 (define-key kmap
(make-key :char
#\
2) 'split-window-vertically
)
232 (define-key kmap
(make-key :char
#\
3) 'split-window-horizontally
)
233 (define-key kmap
(make-key :char
#\x
:control t
) 'exchange-point-and-mark
)
234 (define-key kmap
(make-key :char
#\t :control t
) 'transpose-lines
)
235 (define-key kmap
(make-key :char
#\
4) ctl-x-4-map
)
238 (defun make-ctrl-c-map ()
239 (let ((kmap (make-sparse-keymap)))
242 (defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix
)
243 "Generate self-insert commands for all printable characters. And
245 (let ((kmap (make-sparse-keymap)))
246 (loop for i in
'(#\
0 #\
1 #\
2 #\
3 #\
4 #\
5 #\
6 #\
7 #\
8 #\
9
247 #\a #\b #\c
#\d
#\e
#\f #\g
#\h
#\i
#\j
248 #\k
#\l
#\m
#\n #\o
#\p
#\q
#\r #\s
#\t
249 #\u
#\v #\w
#\x
#\y
#\z
250 #\A
#\B
#\C
#\D
#\E
#\F
#\G
#\H
#\I
#\J
251 #\K
#\L
#\M
#\N
#\O
#\P
#\Q
#\R
#\S
#\T
252 #\U
#\V
#\W
#\X
#\Y
#\Z
253 #\Space
#\
! #\" #\
# #\$
#\%
#\
& #\' #\
(
254 #\
) #\
* #\
+ #\
, #\-
#\.
#\
/ #\
: #\
; #\<
255 #\
= #\
> #\? #\
@ #\
[ #\\ #\
] #\^
#\_
#\
`
257 do
(define-key kmap
(make-key :char i
) 'self-insert-command
))
258 (define-key kmap
(make-key :char
#\Return
) 'newline
)
259 (define-key kmap
(make-key :char
#\Newline
) 'newline
)
260 (define-key kmap
(make-key :char
#\o
:control t
) 'open-line
)
261 (define-key kmap
(make-key :char
#\j
:control t
) 'newline
)
262 (define-key kmap
(make-key :char
#\m
:control t
) 'newline
)
263 (define-key kmap
(make-key :char
#\f :control t
) 'forward-char
)
264 (define-key kmap
(make-key :char
#\f :meta t
) 'forward-word
)
265 (define-key kmap
(make-key :char
#\f :control t
:meta t
) 'forward-sexp
)
266 (define-key kmap
(make-key :char
#\b :control t
:meta t
) 'backward-sexp
)
267 (define-key kmap
(make-key :char
#\n :control t
) 'next-line
)
268 (define-key kmap
(make-key :char
#\p
:control t
) 'previous-line
)
269 (define-key kmap
(make-key :char
#\b :control t
) 'backward-char
)
270 (define-key kmap
(make-key :char
#\b :meta t
) 'backward-word
)
271 (define-key kmap
(make-key :char
#\d
:control t
) 'delete-char
)
272 (define-key kmap
(make-key :char
#\d
:meta t
) 'kill-word
)
273 (define-key kmap
(make-key :char
#\Rubout
:meta t
) 'backward-kill-word
)
274 (define-key kmap
(make-key :char
#\Rubout
) 'delete-backward-char
)
275 (define-key kmap
(make-key :char
#\Delete
) 'delete-backward-char
)
276 (define-key kmap
(make-key :char
#\t :meta t
) 'transpose-words
)
277 (define-key kmap
(make-key :char
#\t :control t
) 'transpose-chars
)
278 ;;(define-key kmap (make-key :char #\h :control t) 'delete-backward-char)
279 (define-key kmap
(make-key :char
#\u
:control t
) 'universal-argument
)
280 (define-key kmap
(make-key :char
#\a :control t
) 'beginning-of-line
)
281 (define-key kmap
(make-key :char
#\e
:control t
) 'end-of-line
)
282 (define-key kmap
(make-key :char
#\g
:control t
) 'keyboard-quit
)
283 (define-key kmap
(make-key :char
#\v :control t
) 'scroll-up
)
284 (define-key kmap
(make-key :char
#\v :meta t
) 'scroll-down
)
285 (define-key kmap
(make-key :char
#\k
:control t
) 'kill-line
)
286 (define-key kmap
(make-key :char
#\w
:control t
) 'kill-region
)
287 (define-key kmap
(make-key :char
#\y
:control t
) 'yank
)
288 (define-key kmap
(make-key :char
#\y
:meta t
) 'yank-pop
)
289 (define-key kmap
(make-key :char
#\w
:meta t
) 'kill-ring-save
)
290 (define-key kmap
(make-key :char
#\
> :meta t
) 'end-of-buffer
)
291 (define-key kmap
(make-key :char
#\
< :meta t
) 'beginning-of-buffer
)
292 (define-key kmap
(make-key :char
#\x
:meta t
) 'execute-extended-command
)
293 (define-key kmap
(make-key :char
#\
: :meta t
) 'eval-expression
)
294 (define-key kmap
(make-key :char
#\Space
:control t
) 'set-mark-command
)
295 (define-key kmap
(make-key :char
#\
` :control t
) 'set-mark-command
)
296 (define-key kmap
(make-key :char
#\
! :meta t
) 'shell-command
)
297 (define-key kmap
(make-key :char
#\Space
:meta t
) 'just-one-space
)
298 (define-key kmap
(make-key :char
#\\ :control t
:meta t
) 'indent-region
)
299 (define-key kmap
(make-key :char
#\a :control t
:meta t
) 'beginning-of-defun
)
300 (define-key kmap
(make-key :char
#\e
:control t
:meta t
) 'end-of-defun
)
301 (define-key kmap
(make-key :char
#\_
:control t
) 'undo
)
302 (define-key kmap
(make-key :char
#\
/ :control t
) 'undo
)
303 (define-key kmap
(make-key :char
#\
} :meta t
) 'forward-paragraph
)
304 (define-key kmap
(make-key :char
#\
{ :meta t
) 'backward-paragraph
)
305 (define-key kmap
(make-key :char
#\x
:control t
) ctl-x-prefix
)
306 (define-key kmap
(make-key :char
#\c
:control t
) ctl-c-prefix
)
307 (define-key kmap
(make-key :char
#\h
:control t
) ctl-h-prefix
)
310 (defun make-global-keymaps ()
311 "Create the default global keymaps and store them in *global-kmap
313 (setf *ctl-x-4-map
* (make-ctrl-x-4-map)
314 *ctl-x-map
* (make-ctrl-x-map *ctl-x-4-map
*)
315 *ctl-c-map
* (make-ctrl-c-map)
316 *ctl-h-map
* (make-ctrl-h-map)
317 *global-map
* (make-global-map *ctl-x-map
* *ctl-c-map
* *ctl-h-map
*)))
319 (defun copy-keymap (keymap)
320 (declare (ignore keymap
))
321 (error "unimplemented"))
323 (defun command-remapping ()
324 (error "unimplemented"))
326 (defun key-binding (key &optional accept-default no-remap
)
327 (declare (ignore key accept-default no-remap
))
328 (error "unimplemented"))
330 (defun local-key-binding ()
331 (error "unimplemented"))
333 (defun global-key-binding ()
334 (error "unimplemented"))
336 (defun minor-mode-key-binding ()
337 (error "unimplemented"))
339 (defun define-prefix-command ()
340 (error "unimplemented"))
342 (defun use-global-map (keymap)
343 (check-type keymap keymap
)
344 (setf *current-global-map
* keymap
))
346 (defun use-local-map (keymap)
347 "Select KEYMAP as the local keymap.
348 If KEYMAP is nil, that means no local keymap."
349 (check-type keymap keymap
)
350 (setf (buffer-local-map (current-buffer)) keymap
))
352 (defun current-local-map ()
353 "Return current buffer's local keymap, or nil if it has none.
355 LICE: the local map in really the major mode map. Except it might
356 not be in the future."
357 (buffer-local-map (current-buffer)))
359 (defun current-global-map ()
360 "Return the current global keymap."
361 *current-global-map
*)
363 (defun current-minor-mode-maps ()
364 (error "unimplemented"))
366 (defun current-active-maps ()
367 (error "unimplemented"))
369 (defun accessible-keymaps ()
370 (error "unimplemented"))
372 (defun key-description ()
373 (error "unimplemented"))
375 (defun describe-vector ()
376 (error "unimplemented"))
378 (defun single-key-description ()
379 (error "unimplemented"))
381 (defun text-char-description ()
382 (error "unimplemented"))
384 (defun where-is-internal ()
385 (error "unimplemented"))
387 (defun describe-buffer-bindings ()
388 (error "unimplemented"))
390 (defun apropos-internal ()
391 (error "unimplemented"))