1 ;;; Handle input and key command dispatching
5 (define-condition quit
(lice-condition)
6 () (:documentation
"A condition raised when the user aborted the
7 operation (by pressing C-g, for instance)."))
9 (defvar *last-command
* nil
10 "The last command executed.")
12 (defvar *this-command
* nil
13 "The command that was executed. This is to the command being
14 executed before it is executed. *last-command* will be set to this
15 when the command finishes. The command can change this value if it
16 wants to change what *last-command* will be set to. Used in the `yank'
17 and `yank-pop' commands.")
19 (defvar *current-prefix-arg
* nil
20 "The value of the prefix argument for this editing command.
21 It may be a number, or the symbol `-' for just a minus sign as arg,
22 or a list whose car is a number for just one or more C-u's
23 or nil if no argument has been specified.
24 This is what `(interactive \"P\")' returns.")
26 ;; (defun collect-command-args (cmd)
27 ;; "Return a list of values (some collected from the user) to pass to the CMD function."
28 ;; (mapcar (lambda (arg)
29 ;; (funcall (gethash (second arg) *command-arg-type-hash*)))
30 ;; (command-args cmd)))
32 (defvar *this-command-keys
* nil
33 "The key sequence that invoked the current command.")
35 (defun this-command-keys ()
36 "Return the key sequence that invoked this command.
37 The value is a list of KEYs."
40 (defun dispatch-command (name)
41 (let* ((cmd (lookup-command name
))
42 ;; (args (collect-command-args cmd))
43 (*this-command
* (command-name cmd
))
44 (*current-prefix-arg
* *prefix-arg
*))
52 (invoke-restart 'abort-command
))))
57 (invoke-restart 'just-print-error c
))))
62 (invoke-restart 'just-print-error c
)))))
63 (funcall (command-fn cmd
)))
65 :report
"Abort the command."
68 :report
"Abort and print error."
71 (setf *last-command
* *this-command
*
72 ;; reset command keys, since the command is over.
73 *this-command-keys
* nil
)
79 (defvar *unread-command-events
* nil
80 "List of events to be read as the command input.
81 These events are processed first, before actual keyboard input.")
83 (defun last-command-char ()
84 "Return the character of the last key event in the list of key
85 events that invoked the current command."
86 (key-char (car *this-command-keys
*)))
88 ;; This is really TTY specific
90 (let* ((*current-event
* (if *unread-command-events
*
91 (pop *unread-command-events
*)
93 (def (if *current-kmap
*
94 (lookup-key-internal *current-kmap
* *current-event
* t
*current-keymap-theme
* t
)
97 (when *overriding-terminal-local-map
*
98 (lookup-key-internal *overriding-terminal-local-map
* *current-event
* t
*current-keymap-theme
* t
))
99 (when *overriding-local-map
*
100 (lookup-key-internal *overriding-local-map
* *current-event
* t
*current-keymap-theme
* t
))
101 (when (current-local-map)
102 (lookup-key-internal (current-local-map) *current-event
* t
*current-keymap-theme
* t
))
103 ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t)
104 ;; TODO: minor mode maps
105 ;; check the global map
106 (lookup-key-internal *global-map
* *current-event
* t
*current-keymap-theme
* t
)))))
107 (dformat +debug-v
+ "~a ~s ~a~%"
108 def
#|
(key-hashid *current-event
*)|
# *current-event
* (key-char *current-event
*))
110 (handle-key-binding def
*current-event
*)
112 (message "~{~a ~}is undefined" (mapcar 'print-key
(reverse (cons *current-event
* (this-command-keys)))))
113 (setf *this-command-keys
* nil
)
114 (throw :unbound-key nil
)))))
116 (defgeneric handle-key-binding
(binding key-seq
))
118 (defmethod handle-key-binding ((binding keymap
) key-seq
)
119 (let ((*current-kmap
* binding
))
120 (push key-seq
*this-command-keys
*)
121 ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
124 (defmethod handle-key-binding ((binding symbol
) key-seq
)
125 ;; reset the current-kmap in case the command reads input. XXX: Is
127 (let ((*current-kmap
* nil
))
128 ;; TODO: handle gathering args
129 (push key-seq
*this-command-keys
*)
130 (dispatch-command binding
)))
132 ;; XXX: this is temporary
133 (defconstant +key-backspace
+ 0407)
134 (defconstant +key-enter
+ 0527)
135 (defconstant +key-tab
+ 0407)
136 (defconstant +key-escape
+ 27)
138 (defun wait-for-event (&optional time
)
139 ;; don't let the user C-g when reading for input
140 (let ((*waiting-for-input
* t
)
141 (now (get-internal-real-time)))
143 for event
= (frame-read-event (selected-frame))
144 for procs
= (poll-processes) do
145 ;; they hit the interrupt key so simulate that key press
147 (setf *quit-flag
* nil
149 :char
(code-char (+ *quit-code
* 96))
153 ;; handle subprocesses
155 ;; let the user break out of this stuff
156 (let ((*waiting-for-input
* nil
))
157 (dispatch-processes procs
)
158 (frame-render (selected-frame))))
160 ;; FIXME: Yes, I'd love to be able to sleep until there was
161 ;; activity on one of the streams lice is waiting for input on
162 ;; but i don't know how to do that. So just sleep for a tiny
163 ;; bit to pass control over to the operating system and then
166 ;; let the loop run once
167 until
(and time
(>= (/ (- (get-internal-real-time) now
)
168 internal-time-units-per-second
)
172 (defun top-level-next-event ()
173 ;; Bind this locally so its value is restored after the
174 ;; command is dispatched. Otherwise, calls to set-buffer
176 (setf *current-buffer
* (window-buffer (frame-selected-window (selected-frame))))
180 (provide :lice-0.1
/input
)