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

Contents of /src/hemlock/display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Mon Nov 11 18:12:44 1991 UTC (22 years, 5 months ago) by chiles
Branch: MAIN
Changes since 1.7: +8 -2 lines
Fixed REDISPLAY-LOOP to return :editor-input correctly if the
after-redisplay-method allowed any input to be queued.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 chiles 1.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/display.lisp,v 1.8 1991/11/11 18:12:44 chiles Exp $")
11 ram 1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Written by Bill Chiles.
15     ;;;
16     ;;; This is the device independent redisplay entry points for Hemlock.
17     ;;;
18    
19     (in-package "HEMLOCK-INTERNALS")
20    
21     (export '(redisplay redisplay-all))
22    
23    
24    
25     ;;;; Main redisplay entry points.
26    
27     (defvar *things-to-do-once* ()
28     "This is a list of lists of functions and args to be applied to. The
29     functions are called with args supplied at the top of the command loop.")
30    
31     (defvar *screen-image-trashed* ()
32     "This variable is set to true if the screen has been trashed by some screen
33     manager operation, and thus should be totally refreshed. This is currently
34     only used by tty redisplay.")
35    
36 ram 1.6 ;;; True if we are in redisplay, and thus don't want to enter it recursively.
37     ;;;
38     (defvar *in-redisplay* nil)
39    
40 ram 1.1 (proclaim '(special *window-list*))
41    
42     (eval-when (compile eval)
43    
44 chiles 1.7 ;;; REDISPLAY-LOOP -- Internal.
45 ram 1.1 ;;;
46 chiles 1.7 ;;; This executes internal redisplay routines on all windows interleaved with
47     ;;; checking for input, and if any input shows up we punt returning
48     ;;; :editor-input. Special-fun is for windows that the redisplay interface
49     ;;; wants to recenter to keep the window's buffer's point visible. General-fun
50     ;;; is for other windows.
51 ram 1.5 ;;;
52 chiles 1.7 ;;; Whenever we invoke one of the internal routines, we keep track of the
53     ;;; non-nil return values, so we can return t when we are done. Returning t
54     ;;; means redisplay should run again to make sure it converged. To err on the
55     ;;; safe side, if any window had any changed lines, then let's go through
56     ;;; redisplay again; that is, return t.
57 ram 1.5 ;;;
58 chiles 1.7 ;;; After checking each window, we put the cursor in the appropriate place and
59     ;;; force output. When we try to position the cursor, it may no longer lie
60     ;;; within the window due to buffer modifications during redisplay. If it is
61     ;;; out of the window, return t to indicate we need to finish redisplaying.
62     ;;;
63     ;;; Then we check for the after-redisplay method. Routines such as REDISPLAY
64     ;;; and REDISPLAY-ALL want to invoke the after method to make sure we handle
65     ;;; any events generated from redisplaying. There wouldn't be a problem with
66     ;;; handling these events if we were going in and out of Hemlock's event
67     ;;; handling, but some user may loop over one of these interface functions for
68     ;;; a long time without going through Hemlock's input loop; when that happens,
69     ;;; each call to redisplay may not result in a complete redisplay of the
70     ;;; device. Routines such as INTERNAL-REDISPLAY don't want to worry about this
71     ;;; since Hemlock calls them while going in and out of the input/event-handling
72     ;;; loop.
73     ;;;
74     ;;; Around all of this, we establish the 'redisplay-catcher tag. Some device
75     ;;; redisplay methods throw to this to abort redisplay in addition to this
76     ;;; code.
77     ;;;
78     (defmacro redisplay-loop (general-fun special-fun &optional (afterp t))
79     (let* ((device (gensym)) (point (gensym)) (hunk (gensym)) (n-res (gensym))
80     (win-var (gensym))
81     (general-form (if (symbolp general-fun)
82     `(,general-fun ,win-var)
83     `(funcall ,general-fun ,win-var)))
84     (special-form (if (symbolp special-fun)
85     `(,special-fun ,win-var)
86     `(funcall ,special-fun ,win-var))))
87 ram 1.6 `(let ((,n-res nil)
88     (*in-redisplay* t))
89 ram 1.5 (catch 'redisplay-catcher
90     (when (listen-editor-input *real-editor-input*)
91     (throw 'redisplay-catcher :editor-input))
92 chiles 1.7 (let ((,win-var *current-window*))
93     (when ,special-form (setf ,n-res t)))
94 ram 1.5 (dolist (,win-var *window-list*)
95     (unless (eq ,win-var *current-window*)
96     (when (listen-editor-input *real-editor-input*)
97     (throw 'redisplay-catcher :editor-input))
98 chiles 1.7 (when (if (window-display-recentering ,win-var)
99     ,special-form
100     ,general-form)
101     (setf ,n-res t))))
102 ram 1.5 (let* ((,hunk (window-hunk *current-window*))
103     (,device (device-hunk-device ,hunk))
104     (,point (window-point *current-window*)))
105     (move-mark ,point (buffer-point (window-buffer *current-window*)))
106     (multiple-value-bind (x y)
107     (mark-to-cursorpos ,point *current-window*)
108     (if x
109     (funcall (device-put-cursor ,device) ,hunk x y)
110 chiles 1.7 (setf ,n-res t)))
111 ram 1.5 (when (device-force-output ,device)
112     (funcall (device-force-output ,device)))
113     ,@(if afterp
114     `((when (device-after-redisplay ,device)
115 chiles 1.8 (funcall (device-after-redisplay ,device) ,device)
116     ;; The after method may have queued input that the input
117     ;; loop won't see until the next input arrives, so check
118     ;; here to return the correct value as per the redisplay
119     ;; contract.
120     (when (listen-editor-input *real-editor-input*)
121     (setf ,n-res :editor-input)))))
122 ram 1.5 ,n-res)))))
123 ram 1.1
124     ) ;eval-when
125    
126    
127 chiles 1.7 ;;; REDISPLAY -- Public.
128 ram 1.1 ;;;
129 chiles 1.7 ;;; This function updates the display of all windows which need it. It assumes
130     ;;; it's internal representation of the screen is accurate and attempts to do
131     ;;; the minimal amount of output to bring the screen into correspondence.
132     ;;; *screen-image-trashed* is only used by terminal redisplay.
133 ram 1.1 ;;;
134     (defun redisplay ()
135     "The main entry into redisplay; updates any windows that seem to need it."
136     (when *things-to-do-once*
137     (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
138 chiles 1.7 (setf *things-to-do-once* nil))
139 ram 1.6 (cond (*in-redisplay* t)
140     (*screen-image-trashed*
141 ram 1.5 (when (eq (redisplay-all) t)
142 chiles 1.7 (setf *screen-image-trashed* nil)
143 ram 1.5 t))
144 ram 1.1 (t
145 chiles 1.7 (redisplay-loop redisplay-window redisplay-window-recentering))))
146 ram 1.1
147    
148 chiles 1.7 ;;; REDISPLAY-ALL -- Public.
149 ram 1.1 ;;;
150 chiles 1.7 ;;; Update the screen making no assumptions about its correctness. This is
151     ;;; useful if the screen gets trashed, or redisplay gets lost. Since windows
152     ;;; may be on different devices, we have to go through the list clearing all
153     ;;; possible devices. Always returns T or :EDITOR-INPUT, never NIL.
154 ram 1.1 ;;;
155     (defun redisplay-all ()
156     "An entry into redisplay; causes all windows to be fully refreshed."
157     (let ((cleared-devices nil))
158     (dolist (w *window-list*)
159     (let* ((hunk (window-hunk w))
160     (device (device-hunk-device hunk)))
161     (unless (member device cleared-devices :test #'eq)
162     (when (device-clear device)
163     (funcall (device-clear device) device))
164     ;;
165     ;; It's cleared whether we did clear it or there was no method.
166     (push device cleared-devices)))))
167 chiles 1.7 (redisplay-loop
168     redisplay-window-all
169     #'(lambda (window)
170     (setf (window-tick window) (tick))
171     (update-window-image window)
172     (maybe-recenter-window window)
173     (funcall (device-dumb-redisplay
174     (device-hunk-device (window-hunk window)))
175     window)
176     t)))
177 ram 1.1
178 chiles 1.7
179 ram 1.1
180     ;;;; Internal redisplay entry points.
181    
182     (defun internal-redisplay ()
183     "The main internal entry into redisplay. This is just like REDISPLAY, but it
184     doesn't call the device's after-redisplay method."
185     (when *things-to-do-once*
186     (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
187 chiles 1.7 (setf *things-to-do-once* nil))
188 ram 1.6 (cond (*in-redisplay* t)
189     (*screen-image-trashed*
190 ram 1.5 (when (eq (redisplay-all) t)
191 chiles 1.7 (setf *screen-image-trashed* nil)
192 ram 1.5 t))
193 ram 1.1 (t
194 chiles 1.7 (redisplay-loop redisplay-window redisplay-window-recentering))))
195 ram 1.1
196 chiles 1.7 ;;; REDISPLAY-WINDOWS-FROM-MARK -- Internal Interface.
197 ram 1.1 ;;;
198 chiles 1.7 ;;; hemlock-output-stream methods call this to update the screen. It only
199     ;;; redisplays windows which are displaying the buffer concerned and doesn't
200     ;;; deal with making the cursor track the point. *screen-image-trashed* is
201     ;;; only used by terminal redisplay. This must call the device after-redisplay
202     ;;; method since stream output may occur without ever returning to the
203     ;;; Hemlock input/event-handling loop.
204     ;;;
205 ram 1.1 (defun redisplay-windows-from-mark (mark)
206     (when *things-to-do-once*
207     (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
208 chiles 1.7 (setf *things-to-do-once* nil))
209 ram 1.6 (cond ((or *in-redisplay* (not *in-the-editor*)) t)
210     ((listen-editor-input *real-editor-input*) :editor-input)
211 ram 1.3 (*screen-image-trashed*
212 ram 1.5 (when (eq (redisplay-all) t)
213 chiles 1.7 (setf *screen-image-trashed* nil)
214 ram 1.5 t))
215 ram 1.1 (t
216     (catch 'redisplay-catcher
217     (let ((buffer (line-buffer (mark-line mark))))
218     (when buffer
219     (flet ((frob (win)
220     (let* ((device (device-hunk-device (window-hunk win)))
221     (force (device-force-output device))
222     (after (device-after-redisplay device)))
223     (when force (funcall force))
224     (when after (funcall after device)))))
225     (let ((windows (buffer-windows buffer)))
226     (when (member *current-window* windows :test #'eq)
227     (redisplay-window-recentering *current-window*)
228     (frob *current-window*))
229     (dolist (window windows)
230     (unless (eq window *current-window*)
231     (redisplay-window window)
232     (frob window)))))))))))
233    
234 chiles 1.7 ;;; REDISPLAY-WINDOW -- Internal.
235 ram 1.5 ;;;
236 chiles 1.7 ;;; Return t if there are any changed lines, nil otherwise.
237     ;;;
238 ram 1.1 (defun redisplay-window (window)
239     "Maybe updates the window's image and calls the device's smart redisplay
240     method. NOTE: the smart redisplay method may throw to
241     'hi::redisplay-catcher to abort redisplay."
242     (maybe-update-window-image window)
243 ram 1.5 (prog1
244     (not (eq (window-first-changed window) the-sentinel))
245     (funcall (device-smart-redisplay (device-hunk-device (window-hunk window)))
246     window)))
247 ram 1.1
248     (defun redisplay-window-all (window)
249     "Updates the window's image and calls the device's dumb redisplay method."
250     (setf (window-tick window) (tick))
251     (update-window-image window)
252     (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window)))
253 ram 1.5 window)
254     t)
255 ram 1.1
256     (defun random-typeout-redisplay (window)
257     (catch 'redisplay-catcher
258     (maybe-update-window-image window)
259     (let* ((device (device-hunk-device (window-hunk window)))
260     (force (device-force-output device)))
261     (funcall (device-smart-redisplay device) window)
262     (when force (funcall force)))))
263    
264    
265     ;;;; Support for redisplay entry points.
266    
267 chiles 1.7 ;;; REDISPLAY-WINDOW-RECENTERING -- Internal.
268 ram 1.5 ;;;
269 chiles 1.7 ;;; This tries to be clever about updating the window image unnecessarily,
270     ;;; recenters the window if the window's buffer's point moved off the window,
271     ;;; and does a smart redisplay. We call the redisplay method even if we didn't
272     ;;; update the image or recenter because someone else may have modified the
273     ;;; window's image and already have updated it; if nothing happened, then the
274     ;;; smart method shouldn't do anything anyway. NOTE: the smart redisplay
275     ;;; method may throw to 'hi::redisplay-catcher to abort redisplay.
276     ;;;
277     ;;; This return t if there are any changed lines, nil otherwise.
278 ram 1.1 ;;;
279     (defun redisplay-window-recentering (window)
280     (setup-for-recentering-redisplay window)
281     (invoke-hook ed::redisplay-hook window)
282     (setup-for-recentering-redisplay window)
283 ram 1.5 (prog1
284     (not (eq (window-first-changed window) the-sentinel))
285     (funcall (device-smart-redisplay (device-hunk-device (window-hunk window)))
286     window)))
287 ram 1.1
288     (defun setup-for-recentering-redisplay (window)
289     (let* ((display-start (window-display-start window))
290     (old-start (window-old-start window)))
291     ;;
292     ;; If the start is in the middle of a line and it wasn't before,
293     ;; then move the start there.
294     (when (and (same-line-p display-start old-start)
295     (not (start-line-p display-start))
296     (start-line-p old-start))
297     (line-start display-start))
298     (maybe-update-window-image window)
299     (maybe-recenter-window window)))
300    
301    
302     ;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the
303     ;;; display start.
304     ;;;
305     (defun maybe-update-window-image (window)
306     (when (or (> (buffer-modified-tick (window-buffer window))
307     (window-tick window))
308     (mark/= (window-display-start window)
309     (window-old-start window)))
310     (setf (window-tick window) (tick))
311     (update-window-image window)
312     t))

  ViewVC Help
Powered by ViewVC 1.1.5