1 ;;; Handle input and key command dispatching
5 (defvar deactivate-mark nil
6 "If an editing command sets this to t, deactivate the mark afterward.
7 The command loop sets this to nil before each command,
8 and tests the value when the command returns.
9 Buffer modification stores t in this variable.")
11 (defvar help-event-list nil
12 "List of input events to recognize as meaning Help.
13 These work just like the value of `help-char' (see that).")
15 (define-condition quit
(lice-condition)
16 () (:documentation
"A condition raised when the user aborted the
17 operation (by pressing C-g, for instance)."))
19 (defvar *last-command
* nil
20 "The last command executed.")
22 (defvar *this-command
* nil
23 "The command that was executed. This is to the command being
24 executed before it is executed. *last-command* will be set to this
25 when the command finishes. The command can change this value if it
26 wants to change what *last-command* will be set to. Used in the `yank'
27 and `yank-pop' commands.")
29 ;; (defun collect-command-args (cmd)
30 ;; "Return a list of values (some collected from the user) to pass to the CMD function."
31 ;; (mapcar (lambda (arg)
32 ;; (funcall (gethash (second arg) *command-arg-type-hash*)))
33 ;; (command-args cmd)))
35 (defvar *this-command-keys
* nil
36 "The key sequence that invoked the current command.")
38 (defun this-command-keys ()
39 "Return the key sequence that invoked this command.
40 The value is a list of KEYs."
43 ;; FIXME some of this should go in call-interactively
44 (defun dispatch-command (name)
45 (let* ((cmd (lookup-command name
))
46 ;; (args (collect-command-args cmd))
47 (*this-command
* (and cmd
(command-name cmd
)))
48 (*current-prefix-arg
* *prefix-arg
*))
58 (invoke-restart 'abort-command
))))
63 (invoke-restart 'just-print-error c
))))
68 (invoke-restart 'just-print-error c
)))))
69 (call-interactively cmd
))
71 :report
"Abort the command."
74 :report
"Abort and print error."
77 (setf *last-command
* *this-command
*)
81 (message "Symbol's command is void: ~a" name
))
82 ;; reset command keys, since the command is over.
83 *this-command-keys
* nil
))
87 (defvar *unread-command-events
* nil
88 "List of events to be read as the command input.
89 These events are processed first, before actual keyboard input.")
91 (defun last-command-char ()
92 "Return the character of the last key event in the list of key
93 events that invoked the current command."
94 (key-char (car *this-command-keys
*)))
96 ;; This is really TTY specific
98 (let* ((*current-event
* (if *unread-command-events
*
99 (pop *unread-command-events
*)
101 (def (if *current-kmap
*
102 (lookup-key-internal *current-kmap
* *current-event
* t
*current-keymap-theme
* t nil t
)
105 (when *overriding-terminal-local-map
*
106 (lookup-key-internal *overriding-terminal-local-map
* *current-event
* t
*current-keymap-theme
* t nil t
))
107 (when *overriding-local-map
*
108 (lookup-key-internal *overriding-local-map
* *current-event
* t
*current-keymap-theme
* t nil t
))
109 (when (current-local-map)
110 (lookup-key-internal (current-local-map) *current-event
* t
*current-keymap-theme
* t nil t
))
111 ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t)
112 ;; TODO: minor mode maps
113 ;; check the global map
114 (lookup-key-internal *global-map
* *current-event
* t
*current-keymap-theme
* t nil t
)))))
115 (dformat +debug-v
+ "~a ~s ~a~%"
116 def
#|
(key-hashid *current-event
*)|
# *current-event
* (key-char *current-event
*))
118 (handle-key-binding def
*current-event
*)
120 (message "~{~a ~}is undefined" (mapcar 'print-key
(reverse (cons *current-event
* (this-command-keys)))))
121 (setf *this-command-keys
* nil
)
122 (throw :unbound-key nil
)))))
124 (defgeneric handle-key-binding
(binding key-seq
))
126 (defmethod handle-key-binding ((binding keymap
) key-seq
)
127 (let ((*current-kmap
* binding
))
128 (push key-seq
*this-command-keys
*)
129 ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
132 (defmethod handle-key-binding ((binding symbol
) key-seq
)
133 ;; reset the current-kmap in case the command reads input. XXX: Is
135 (let ((*current-kmap
* nil
))
136 ;; TODO: handle gathering args
137 (push key-seq
*this-command-keys
*)
138 (dispatch-command binding
)))
140 ;; XXX: this is temporary
141 (defconstant +key-backspace
+ 0407)
142 (defconstant +key-enter
+ 0527)
143 (defconstant +key-tab
+ 0407)
144 (defconstant +key-escape
+ 27)
146 (defun wait-for-event (&optional time
)
147 ;; don't let the user C-g when reading for input
148 (let ((*waiting-for-input
* t
)
149 (now (get-internal-real-time)))
151 for event
= (frame-read-event (selected-frame))
152 for procs
= (poll-processes) do
153 ;; they hit the interrupt key so simulate that key press
155 (setf *quit-flag
* nil
157 :char
(code-char (+ *quit-code
* 96))
161 ;; handle subprocesses
163 ;; let the user break out of this stuff
164 (let ((*waiting-for-input
* nil
))
165 (dispatch-processes procs
)
166 (frame-render (selected-frame))))
168 ;; FIXME: Yes, I'd love to be able to sleep until there was
169 ;; activity on one of the streams lice is waiting for input on
170 ;; but i don't know how to do that. So just sleep for a tiny
171 ;; bit to pass control over to the operating system and then
174 ;; let the loop run once
175 until
(and time
(>= (/ (- (get-internal-real-time) now
)
176 internal-time-units-per-second
)
179 (defun command-loop ()
180 (labels ((ensure-current-buffer ()
181 ;; Make sure the current window's buffer is selected.
182 (unless (eq *current-buffer
* (window-buffer (selected-window)))
183 (setf *current-buffer
* (window-buffer (selected-window))))))
184 (setf *prefix-arg
* nil
185 *last-prefix-arg
* nil
)
187 (ensure-current-buffer)
188 (setf deactivate-mark nil
)
190 (frame-render (selected-frame))
195 ;; A filter may have run while we were reading the input.
196 (ensure-current-buffer)
202 (define-key *global-map
* "C-z" 'suspend-emacs
)
203 (define-key *ctl-x-map
* "C-z" 'suspend-emacs
)
204 (define-key *global-map
* "M-C-c" 'exit-recursive-edit
)
205 (define-key *global-map
* "C-]" 'abort-recursive-edit
)
206 (define-key *global-map
* "M-x" 'execute-extended-command
)
208 (provide :lice-0.1
/input
)