/[cmucl]/src/hemlock/input.lisp
ViewVC logotype

Contents of /src/hemlock/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Mar 13 15:49:53 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.7: +4 -4 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/input.lisp,v 1.8 2001/03/13 15:49:53 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the code that handles input to Hemlock.
13 ;;;
14 (in-package "HEMLOCK-INTERNALS")
15
16 (export '(get-key-event unget-key-event clear-editor-input listen-editor-input
17 *last-key-event-typed* *key-event-history* *editor-input*
18 *real-editor-input* input-waiting last-key-event-cursorpos))
19 ;;;
20 ;;; INPUT-WAITING is exported solely as a hack for the kbdmac definition
21 ;;; mechanism.
22 ;;;
23
24
25 ;;; These are public variables users hand to the four basic editor input
26 ;;; routines for method dispatching:
27 ;;; GET-KEY-EVENT
28 ;;; UNGET-KEY-EVENT
29 ;;; LISTEN-EDITOR-INPUT
30 ;;; CLEAR-EDITOR-INPUT
31 ;;;
32 (defvar *editor-input* nil
33 "A structure used to do various operations on terminal input.")
34
35 (defvar *real-editor-input* ()
36 "Useful when we want to read from the terminal when *editor-input* is
37 rebound.")
38
39
40
41 ;;;; editor-input structure.
42
43 (defstruct (editor-input (:print-function
44 (lambda (s stream d)
45 (declare (ignore s d))
46 (write-string "#<Editor-Input stream>" stream))))
47 get ; A function that returns the next key-event in the queue.
48 unget ; A function that puts a key-event at the front of the queue.
49 listen ; A function that tells whether the queue is empty.
50 clear ; A function that empties the queue.
51 ;;
52 ;; Queue of events on this stream. The queue always contains at least one
53 ;; one element, which is the key-event most recently read. If no event has
54 ;; been read, the event is a dummy with a nil key-event.
55 head
56 tail)
57
58
59 ;;; These are the elements of the editor-input event queue.
60 ;;;
61 (defstruct (input-event (:constructor make-input-event ()))
62 next ; Next queued event, or NIL if none.
63 hunk ; Screen hunk event was read from.
64 key-event ; Key-event read.
65 x ; X and Y character position of mouse cursor.
66 y
67 unread-p)
68
69 (defvar *free-input-events* ())
70
71 (defun new-event (key-event x y hunk next &optional unread-p)
72 (let ((res (if *free-input-events*
73 (shiftf *free-input-events*
74 (input-event-next *free-input-events*))
75 (make-input-event))))
76 (setf (input-event-key-event res) key-event)
77 (setf (input-event-x res) x)
78 (setf (input-event-y res) y)
79 (setf (input-event-hunk res) hunk)
80 (setf (input-event-next res) next)
81 (setf (input-event-unread-p res) unread-p)
82 res))
83
84 ;;; This is a public variable.
85 ;;;
86 (defvar *last-key-event-typed* ()
87 "This variable contains the last key-event typed by the user and read as
88 input.")
89
90 ;;; This is a public variable. SITE-INIT initializes this.
91 ;;;
92 (defvar *key-event-history* nil
93 "This ring holds the last 60 key-events read by the command interpreter.")
94
95 (declaim (special *input-transcript*))
96
97 ;;; DQ-EVENT is used in editor stream methods for popping off input.
98 ;;; If there is an event not yet read in Stream, then pop the queue
99 ;;; and return the character. If there is none, return NIL.
100 ;;;
101 (defun dq-event (stream)
102 (without-interrupts
103 (let* ((head (editor-input-head stream))
104 (next (input-event-next head)))
105 (if next
106 (let ((key-event (input-event-key-event next)))
107 (setf (editor-input-head stream) next)
108 (shiftf (input-event-next head) *free-input-events* head)
109 (ring-push key-event *key-event-history*)
110 (setf *last-key-event-typed* key-event)
111 (when *input-transcript*
112 (vector-push-extend key-event *input-transcript*))
113 key-event)))))
114
115 ;;; Q-EVENT is used in low level input fetching routines to add input to the
116 ;;; editor stream.
117 ;;;
118 (defun q-event (stream key-event &optional x y hunk)
119 (without-interrupts
120 (let ((new (new-event key-event x y hunk nil))
121 (tail (editor-input-tail stream)))
122 (setf (input-event-next tail) new)
123 (setf (editor-input-tail stream) new))))
124
125 (defun un-event (key-event stream)
126 (without-interrupts
127 (let* ((head (editor-input-head stream))
128 (next (input-event-next head))
129 (new (new-event key-event (input-event-x head) (input-event-y head)
130 (input-event-hunk head) next t)))
131 (setf (input-event-next head) new)
132 (unless next (setf (editor-input-tail stream) new)))))
133
134
135
136 ;;;; Keyboard macro hacks.
137
138 (defvar *input-transcript* ()
139 "If this variable is non-null then it should contain an adjustable vector
140 with a fill pointer into which all keyboard input will be pushed.")
141
142 ;;; INPUT-WAITING -- Internal
143 ;;;
144 ;;; An Evil hack that tells us whether there is an unread key-event on
145 ;;; *editor-input*. Note that this is applied to the real *editor-input*
146 ;;; rather than to a kbdmac stream.
147 ;;;
148 (defun input-waiting ()
149 "Returns true if there is a key-event which has been unread-key-event'ed
150 on *editor-input*. Used by the keyboard macro stuff."
151 (let ((next (input-event-next
152 (editor-input-head *real-editor-input*))))
153 (and next (input-event-unread-p next))))
154
155
156
157 ;;;; Input method macro.
158
159 (defvar *in-hemlock-stream-input-method* nil
160 "This keeps us from undefined nasties like re-entering Hemlock stream
161 input methods from input hooks and scheduled events.")
162
163 (declaim (special *screen-image-trashed*))
164
165 ;;; These are the characters GET-KEY-EVENT notices when it pays attention
166 ;;; to aborting input. This happens via EDITOR-INPUT-METHOD-MACRO.
167 ;;;
168 (defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
169
170 (defun cleanup-for-wm-closed-display(closed-display)
171 ;; Remove fd-handlers
172 (ext:disable-clx-event-handling closed-display)
173 ;; Close file descriptor and note DEAD.
174 (xlib:close-display closed-display)
175 ;;
176 ;; At this point there is not much sense to returning to Lisp
177 ;; as the editor cannot be re-entered (there are lots of pointers
178 ;; to the dead display around that will cause subsequent failures).
179 ;; Maybe could switch to tty mode then (save-all-files-and-exit)?
180 ;; For now, just assume user wanted an easy way to kill the session.
181 (ext:quit))
182
183 (defmacro abort-key-event-p (key-event)
184 `(member ,key-event editor-abort-key-events))
185
186 ;;; EDITOR-INPUT-METHOD-MACRO -- Internal.
187 ;;;
188 ;;; WINDOWED-GET-KEY-EVENT and TTY-GET-KEY-EVENT use this. Somewhat odd stuff
189 ;;; goes on here because this is the place where Hemlock waits, so this is
190 ;;; where we redisplay, check the time for scheduled events, etc. In the loop,
191 ;;; we call the input hook when we get a character and leave the loop. If
192 ;;; there isn't any input, invoke any scheduled events whose time is up.
193 ;;; Unless SERVE-EVENT returns immediately and did something, (serve-event 0),
194 ;;; call redisplay, note that we are going into a read wait, and call
195 ;;; SERVE-EVENT with a wait or infinite timeout. Upon exiting the loop, turn
196 ;;; off the read wait note and check for the abort character. Return the
197 ;;; key-event we got. We bind an error condition handler here because the
198 ;;; default Hemlock error handler goes into a little debugging prompt loop, but
199 ;;; if we got an error in getting input, we should prompt the user using the
200 ;;; input method (recursively even).
201 ;;;
202 (eval-when (compile eval)
203
204 (defmacro editor-input-method-macro ()
205 `(handler-bind
206 ((error
207 (lambda (condition)
208 (when (typep condition 'stream-error)
209 (let* ((stream (stream-error-stream condition))
210 (display *editor-windowed-input*)
211 (display-stream
212 #+CLX
213 (and display (xlib::display-input-stream display))))
214 (when (eq stream display-stream)
215 ;;(format *error-output* "~%Hemlock: Display died!~%~%")
216 (cleanup-for-wm-closed-display display)
217 (exit-hemlock nil))
218 (let ((device
219 (device-hunk-device (window-hunk (current-window)))))
220 (funcall (device-exit device) device))
221 (invoke-debugger condition)))))
222 #+(and CLX )
223 (xlib:closed-display
224 (lambda(condition)
225 (let ((display (xlib::closed-display-display condition)))
226 (format *error-output*
227 "Closed display on stream ~a~%"
228 (xlib::display-input-stream display)))
229 (exit-hemlock nil)))
230 )
231 ; (when *in-hemlock-stream-input-method*
232 ; (error "Entering Hemlock stream input method recursively!"))
233 (let ((*in-hemlock-stream-input-method* t)
234 (nrw-fun (device-note-read-wait
235 (device-hunk-device (window-hunk (current-window)))))
236 key-event)
237 (loop
238 (when (setf key-event (dq-event stream))
239 (dolist (f (variable-value 'ed::input-hook)) (funcall f))
240 (return))
241 (invoke-scheduled-events)
242 (unless (or (system:serve-event 0)
243 (internal-redisplay))
244 (internal-redisplay)
245 (when nrw-fun (funcall nrw-fun t))
246 (let ((wait (next-scheduled-event-wait)))
247 (if wait (system:serve-event wait) (system:serve-event)))))
248 (when nrw-fun (funcall nrw-fun nil))
249 (when (and (abort-key-event-p key-event)
250 ;; ignore-abort-attempts-p must exist outside the macro.
251 ;; in this case it is bound in GET-KEY-EVENT.
252 (not ignore-abort-attempts-p))
253 (beep)
254 (throw 'editor-top-level-catcher nil))
255 key-event)))
256 ) ;eval-when
257
258
259
260 ;;;; Editor input from windowing system.
261 #+clx
262 (defstruct (windowed-editor-input
263 (:include editor-input
264 (:get #'windowed-get-key-event)
265 (:unget #'windowed-unget-key-event)
266 (:listen #'windowed-listen)
267 (:clear #'windowed-clear-input))
268 (:print-function
269 (lambda (s stream d)
270 (declare (ignore s d))
271 (write-string "#<Editor-Window-Input stream>" stream)))
272 (:constructor make-windowed-editor-input
273 (&optional (head (make-input-event)) (tail head))))
274 hunks) ; List of bitmap-hunks which input to this stream.
275
276 #+clx
277 ;;; There's actually no difference from the TTY case...
278 (defun windowed-get-key-event (stream ignore-abort-attempts-p)
279 (tty-get-key-event stream ignore-abort-attempts-p))
280
281 #+clx
282 (defun windowed-unget-key-event (key-event stream)
283 (un-event key-event stream))
284
285 #+clx
286 (defun windowed-clear-input (stream)
287 (loop (unless (system:serve-event 0) (return)))
288 (without-interrupts
289 (let* ((head (editor-input-head stream))
290 (next (input-event-next head)))
291 (when next
292 (setf (input-event-next head) nil)
293 (shiftf (input-event-next (editor-input-tail stream))
294 *free-input-events* next)
295 (setf (editor-input-tail stream) head)))))
296
297 #+clx
298 (defun windowed-listen (stream)
299 (loop
300 ;; Don't service anymore events if we just got some input.
301 (when (input-event-next (editor-input-head stream))
302 (return t))
303 ;;
304 ;; If nothing is pending, check the queued input.
305 (unless (system:serve-event 0)
306 (return (not (null (input-event-next (editor-input-head stream))))))))
307
308
309 ;;;; Editor input from a tty.
310
311 (defstruct (tty-editor-input
312 (:include editor-input
313 (:get #'tty-get-key-event)
314 (:unget #'tty-unget-key-event)
315 (:listen #'tty-listen)
316 (:clear #'tty-clear-input))
317 (:print-function
318 (lambda (obj stream n)
319 (declare (ignore obj n))
320 (write-string "#<Editor-Tty-Input stream>" stream)))
321 (:constructor make-tty-editor-input
322 (fd &optional (head (make-input-event)) (tail head))))
323 fd)
324
325 (defun tty-get-key-event (stream ignore-abort-attempts-p)
326 (editor-input-method-macro))
327
328 (defun tty-unget-key-event (key-event stream)
329 (un-event key-event stream))
330
331 (defun tty-clear-input (stream)
332 (without-interrupts
333 (let* ((head (editor-input-head stream))
334 (next (input-event-next head)))
335 (when next
336 (setf (input-event-next head) nil)
337 (shiftf (input-event-next (editor-input-tail stream))
338 *free-input-events* next)
339 (setf (editor-input-tail stream) head)))))
340
341 ;;; Note that we never return NIL as long as there are events to be served with
342 ;;; SERVE-EVENT. Thus non-keyboard input (i.e. process output)
343 ;;; effectively causes LISTEN to block until either all the non-keyboard input
344 ;;; has happened, or there is some real keyboard input.
345 ;;;
346 (defun tty-listen (stream)
347 (loop
348 ;; Don't service anymore events if we just got some input.
349 (when (or (input-event-next (editor-input-head stream))
350 (editor-tty-listen stream))
351 (return t))
352 ;; If nothing is pending, check the queued input.
353 (unless (system:serve-event 0)
354 (return (not (null (input-event-next (editor-input-head stream))))))))
355
356
357 ;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT.
358
359 ;;; GET-KEY-EVENT -- Public.
360 ;;;
361 (defun get-key-event (editor-input &optional ignore-abort-attempts-p)
362 "This function returns a key-event as soon as it is available on
363 editor-input. Editor-input is either *editor-input* or *real-editor-input*.
364 Ignore-abort-attempts-p indicates whether #k\"C-g\" and #k\"C-G\" throw to
365 the editor's top-level command loop; when this is non-nil, this function
366 returns those key-events when the user types them. Otherwise, it aborts the
367 editor's current state, returning to the command loop."
368 (funcall (editor-input-get editor-input) editor-input ignore-abort-attempts-p))
369
370 ;;; UNGET-KEY-EVENT -- Public.
371 ;;;
372 (defun unget-key-event (key-event editor-input)
373 "This function returns the key-event to editor-input, so the next invocation
374 of GET-KEY-EVENT will return the key-event. If the key-event is #k\"C-g\"
375 or #k\"C-G\", then whether GET-KEY-EVENT returns it depends on its second
376 argument. Editor-input is either *editor-input* or *real-editor-input*."
377 (funcall (editor-input-unget editor-input) key-event editor-input))
378
379 ;;; CLEAR-EDITOR-INPUT -- Public.
380 ;;;
381 (defun clear-editor-input (editor-input)
382 "This function flushes any pending input on editor-input. Editor-input
383 is either *editor-input* or *real-editor-input*."
384 (funcall (editor-input-clear editor-input) editor-input))
385
386 ;;; LISTEN-EDITOR-INPUT -- Public.
387 ;;;
388 (defun listen-editor-input (editor-input)
389 "This function returns whether there is any input available on editor-input.
390 Editor-input is either *editor-input* or *real-editor-input*."
391 (funcall (editor-input-listen editor-input) editor-input))
392
393
394
395 ;;;; LAST-KEY-EVENT-CURSORPOS and WINDOW-INPUT-HANDLER.
396
397 ;;; LAST-KEY-EVENT-CURSORPOS -- Public
398 ;;;
399 ;;; Just look up the saved info in the last read key event.
400 ;;;
401 (defun last-key-event-cursorpos ()
402 "Return as values, the (X, Y) character position and window where the
403 last key event happened. If this cannot be determined, Nil is returned.
404 If in the modeline, return a Y position of NIL and the correct X and window.
405 Returns nil for terminal input."
406 (let* ((ev (editor-input-head *real-editor-input*))
407 (hunk (input-event-hunk ev))
408 (window (and hunk (device-hunk-window hunk))))
409 (when window
410 (values (input-event-x ev) (input-event-y ev) window))))
411
412 ;;; WINDOW-INPUT-HANDLER -- Internal
413 ;;;
414 ;;; This is the input-handler function for hunks that implement windows. It
415 ;;; just queues the events on *real-editor-input*.
416 ;;;
417 (defun window-input-handler (hunk char x y)
418 (q-event *real-editor-input* char x y hunk))
419
420
421
422 ;;;; Random typeout input routines.
423
424 (defun wait-for-more (stream)
425 (let ((key-event (more-read-key-event)))
426 (cond ((logical-key-event-p key-event :yes))
427 ((or (logical-key-event-p key-event :do-all)
428 (logical-key-event-p key-event :exit))
429 (setf (random-typeout-stream-no-prompt stream) t)
430 (random-typeout-cleanup stream))
431 ((logical-key-event-p key-event :keep)
432 (setf (random-typeout-stream-no-prompt stream) t)
433 (maybe-keep-random-typeout-window stream)
434 (random-typeout-cleanup stream))
435 ((logical-key-event-p key-event :no)
436 (random-typeout-cleanup stream)
437 (throw 'more-punt nil))
438 (t
439 (unget-key-event key-event *editor-input*)
440 (random-typeout-cleanup stream)
441 (throw 'more-punt nil)))))
442
443 (declaim (special *more-prompt-action*))
444
445 (defun maybe-keep-random-typeout-window (stream)
446 (let* ((window (random-typeout-stream-window stream))
447 (buffer (window-buffer window))
448 (start (buffer-start-mark buffer)))
449 (when (typep (hi::device-hunk-device (hi::window-hunk window))
450 'hi::bitmap-device)
451 (let ((*more-prompt-action* :normal))
452 (update-modeline-field buffer window :more-prompt)
453 (random-typeout-redisplay window))
454 (buffer-start (buffer-point buffer))
455 (let* ((xwindow (make-xwindow-like-hwindow window))
456 (window (make-window start :window xwindow)))
457 (unless window
458 #+clx(xlib:destroy-window xwindow)
459 (editor-error "Could not create random typeout window."))))))
460
461 (defun end-random-typeout (stream)
462 (let ((*more-prompt-action* :flush)
463 (window (random-typeout-stream-window stream)))
464 (update-modeline-field (window-buffer window) window :more-prompt)
465 (random-typeout-redisplay window))
466 (unless (random-typeout-stream-no-prompt stream)
467 (let* ((key-event (more-read-key-event))
468 (keep-p (logical-key-event-p key-event :keep)))
469 (when keep-p (maybe-keep-random-typeout-window stream))
470 (random-typeout-cleanup stream)
471 (unless (or (logical-key-event-p key-event :do-all)
472 (logical-key-event-p key-event :exit)
473 (logical-key-event-p key-event :no)
474 (logical-key-event-p key-event :yes)
475 keep-p)
476 (unget-key-event key-event *editor-input*)))))
477
478 ;;; MORE-READ-KEY-EVENT -- Internal.
479 ;;;
480 ;;; This gets some input from the type of stream bound to *editor-input*. Need
481 ;;; to loop over SERVE-EVENT since it returns on any kind of event (not
482 ;;; necessarily a key or button event).
483 ;;;
484 ;;; Currently this does not work for keyboard macro streams!
485 ;;;
486 (defun more-read-key-event ()
487 (clear-editor-input *editor-input*)
488 (let ((key-event (loop
489 (let ((key-event (dq-event *editor-input*)))
490 (when key-event (return key-event))
491 (system:serve-event)))))
492 (when (abort-key-event-p key-event)
493 (beep)
494 (throw 'editor-top-level-catcher nil))
495 key-event))

  ViewVC Help
Powered by ViewVC 1.1.5