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

Contents of /src/hemlock/display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5