1 ;;; Handle input and key command dispatching
5 (defvar help-event-list nil
6 "List of input events to recognize as meaning Help.
7 These work just like the value of `help-char' (see that).")
9 (define-condition quit
(lice-condition)
10 () (:documentation
"A condition raised when the user aborted the
11 operation (by pressing C-g, for instance)."))
13 (defvar *last-command
* nil
14 "The last command executed.")
16 (defvar *this-command
* nil
17 "The command that was executed. This is to the command being
18 executed before it is executed. *last-command* will be set to this
19 when the command finishes. The command can change this value if it
20 wants to change what *last-command* will be set to. Used in the `yank'
21 and `yank-pop' commands.")
23 (defvar *current-prefix-arg
* nil
24 "The value of the prefix argument for this editing command.
25 It may be a number, or the symbol `-' for just a minus sign as arg,
26 or a list whose car is a number for just one or more C-u's
27 or nil if no argument has been specified.
28 This is what `(interactive \"P\")' returns.")
30 ;; (defun collect-command-args (cmd)
31 ;; "Return a list of values (some collected from the user) to pass to the CMD function."
32 ;; (mapcar (lambda (arg)
33 ;; (funcall (gethash (second arg) *command-arg-type-hash*)))
34 ;; (command-args cmd)))
36 (defvar *this-command-keys
* nil
37 "The key sequence that invoked the current command.")
39 (defun this-command-keys ()
40 "Return the key sequence that invoked this command.
41 The value is a list of KEYs."
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 (funcall (command-fn 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
)
180 (defun top-level-next-event ()
181 ;; Bind this locally so its value is restored after the
182 ;; command is dispatched. Otherwise, calls to set-buffer
184 (setf *current-buffer
* (window-buffer (frame-selected-window (selected-frame))))
190 (define-key *global-map
* "C-z" 'suspend-emacs
)
191 (define-key *ctl-x-map
* "C-z" 'suspend-emacs
)
192 (define-key *global-map
* "M-C-c" 'exit-recursive-edit
)
193 (define-key *global-map
* "C-]" 'abort-recursive-edit
)
194 (define-key *global-map
* "M-x" 'execute-extended-command
)
196 (provide :lice-0.1
/input
)