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

Contents of /src/hemlock/bit-display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
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, RELEASE_18d, 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, RELEASE_18a, RELEASE_18b, RELEASE_18c, 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, RELENG_18, 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.2: +0 -2 lines
Fix headed boilerplate.
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/bit-display.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Rob MacLachlan
13 ;;; Modified by Bill Chiles to run under X on IBM RT's.
14 ;;;
15
16 (in-package "HEMLOCK-INTERNALS")
17
18 (export '(redisplay redisplay-all))
19
20
21
22 ;;; prepare-window-for-redisplay -- Internal
23 ;;;
24 ;;; Called by make-window to do whatever redisplay wants to set up
25 ;;; a new window.
26 ;;;
27 (defun prepare-window-for-redisplay (window)
28 (setf (window-old-lines window) 0))
29
30
31
32 ;;;; Dumb window redisplay.
33
34 ;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay.
35 ;;; This assumes the cursor has been lifted if necessary.
36 ;;;
37 (defun dumb-window-redisplay (window)
38 (let* ((hunk (window-hunk window))
39 (first (window-first-line window)))
40 (hunk-reset hunk)
41 (do ((i 0 (1+ i))
42 (dl (cdr first) (cdr dl)))
43 ((eq dl the-sentinel)
44 (setf (window-old-lines window) (1- i)))
45 (dumb-line-redisplay hunk (car dl)))
46 (setf (window-first-changed window) the-sentinel
47 (window-last-changed window) first)
48 (when (window-modeline-buffer window)
49 (hunk-replace-modeline hunk)
50 (setf (dis-line-flags (window-modeline-dis-line window))
51 unaltered-bits))
52 (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))
53
54
55 ;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already.
56 ;;;
57 (defun dumb-line-redisplay (hunk dl)
58 (hunk-write-line hunk dl)
59 (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))
60
61
62
63 ;;;; Smart window redisplay.
64
65 ;;; We scan through the changed dis-lines, and condense the information
66 ;;; obtained into five categories: Unchanged lines moved down, unchanged
67 ;;; lines moved up, lines that need to be cleared, lines that are in the
68 ;;; same place (but changed), and new or moved-and-changed lines to write.
69 ;;; Each such instance of a thing that needs to be done is remembered be
70 ;;; throwing needed information on a stack specific to the thing to be
71 ;;; done. We cannot do any of these things right away because each may
72 ;;; confict with the previous.
73 ;;;
74 ;;; Each stack is represented by a simple-vector big enough to hold the
75 ;;; worst-case number of entries and a pointer to the next free entry. The
76 ;;; pointers are local variables returned from COMPUTE-CHANGES and used by
77 ;;; SMART-WINDOW-REDISPLAY. Note that the order specified in these tuples
78 ;;; is the order in which they were pushed.
79 ;;;
80 (defvar *display-down-move-stack* (make-array (* hunk-height-limit 2))
81 "This is the vector that we stash info about which lines moved down in
82 as (Start, End, Count) triples.")
83 (defvar *display-up-move-stack* (make-array (* hunk-height-limit 2))
84 "This is the vector that we stash info about which lines moved up in
85 as (Start, End, Count) triples.")
86 (defvar *display-erase-stack* (make-array hunk-height-limit)
87 "This is the vector that we stash info about which lines need to be erased
88 as (Start, Count) pairs.")
89 (defvar *display-write-stack* (make-array hunk-height-limit)
90 "This is the vector that we stash dis-lines in that need to be written.")
91 (defvar *display-rewrite-stack* (make-array hunk-height-limit)
92 "This is the vector that we stash dis-lines in that need to be written.
93 with clear-to-end.")
94
95 ;;; Accessor macros to push and pop on the stacks:
96 ;;;
97 (eval-when (compile eval)
98
99 (defmacro spush (thing stack stack-pointer)
100 `(progn
101 (setf (svref ,stack ,stack-pointer) ,thing)
102 (incf ,stack-pointer)))
103
104 (defmacro spop (stack stack-pointer)
105 `(svref ,stack (decf ,stack-pointer)))
106
107 (defmacro snext (stack stack-pointer)
108 `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer)))
109
110 ); eval-when (compile eval)
111
112
113 ;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed,
114 ;;; and updates them with smart-line-redisplay if not very much has changed.
115 ;;; Lines which have moved are copied. We must be careful not to redisplay
116 ;;; the window with the cursor down since it is not guaranteed to be out of
117 ;;; the way just because we are in redisplay; LIFT-CURSOR is called just before
118 ;;; the screen may be altered, and it takes care to know whether the cursor
119 ;;; is lifted already or not. At the end, if the cursor had been down,
120 ;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called
121 ;;; since it does nothing if the cursor is already down.
122 ;;;
123 (defun smart-window-redisplay (window)
124 (let* ((hunk (window-hunk window))
125 (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)))
126 (when (bitmap-hunk-trashed hunk)
127 (when liftp (lift-cursor))
128 (dumb-window-redisplay window)
129 (when liftp (drop-cursor))
130 (return-from smart-window-redisplay nil))
131 (let ((first-changed (window-first-changed window))
132 (last-changed (window-last-changed window)))
133 ;; Is there anything to do?
134 (unless (eq first-changed the-sentinel)
135 (when liftp (lift-cursor))
136 (if (and (eq first-changed last-changed)
137 (zerop (dis-line-delta (car first-changed))))
138 ;; One line changed.
139 (smart-line-redisplay hunk (car first-changed))
140 ;; More than one line changed.
141 (multiple-value-bind (up down erase write rewrite)
142 (compute-changes first-changed last-changed)
143 (do-down-moves hunk down)
144 (do-up-moves hunk up)
145 (do-erases hunk erase)
146 (do-writes hunk write)
147 (do-rewrites hunk rewrite)))
148 ;; Set the bounds so we know we displayed...
149 (setf (window-first-changed window) the-sentinel
150 (window-last-changed window) (window-first-line window))))
151 ;;
152 ;; Clear any extra lines at the end of the window.
153 (let ((pos (dis-line-position (car (window-last-line window)))))
154 (when (< pos (window-old-lines window))
155 (when liftp (lift-cursor))
156 (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1)))
157 (setf (window-old-lines window) pos))
158 ;;
159 ;; Update the modeline if needed.
160 (when (window-modeline-buffer window)
161 (when (/= (dis-line-flags (window-modeline-dis-line window))
162 unaltered-bits)
163 (hunk-replace-modeline hunk)
164 (setf (dis-line-flags (window-modeline-dis-line window))
165 unaltered-bits)))
166 ;;
167 (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
168 (when liftp (drop-cursor))))
169
170 ;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans
171 ;;; through the changed dis-lines in a window, computes the changes needed
172 ;;; to bring the screen into corespondence, and throws the information
173 ;;; needed to do the change onto the apropriate stack. The pointers into
174 ;;; the stacks (up, down, erase, write, and rewrite) are returned.
175 ;;;
176 ;;; The algorithm is as follows:
177 ;;; 1] If the line is moved-and-changed or new then throw the line on
178 ;;; the write stack and increment the clear count. Repeat until no more
179 ;;; such lines are found.
180 ;;; 2] If the line is moved then flush any pending clear, find how many
181 ;;; consecutive lines are moved the same amount, and put the numbers
182 ;;; on the correct move stack.
183 ;;; 3] If the line is changed and unmoved throw it on a write stack.
184 ;;; If a clear is pending throw it in the write stack and bump the clear
185 ;;; count, otherwise throw it on the rewrite stack.
186 ;;; 4] The line is unchanged, do nothing.
187 ;;;
188 (defun compute-changes (first-changed last-changed)
189 (let* ((dl first-changed)
190 (flags (dis-line-flags (car dl)))
191 (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values.
192 (clear-count 0)
193 prev clear-start)
194 (declare (fixnum up down erase write rewrite clear-count))
195 (loop
196 (cond
197 ;; Line moved-and-changed or new.
198 ((> flags moved-bit)
199 (when (zerop clear-count)
200 (setq clear-start (dis-line-position (car dl))))
201 (loop
202 (setf (dis-line-delta (car dl)) 0)
203 (spush (car dl) *display-write-stack* write)
204 (incf clear-count)
205 (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))
206 (when (<= flags moved-bit) (return nil))))
207 ;; Line moved, unchanged.
208 ((= flags moved-bit)
209 (unless (zerop clear-count)
210 (spush clear-count *display-erase-stack* erase)
211 (spush clear-start *display-erase-stack* erase)
212 (setq clear-count 0))
213 (do ((delta (dis-line-delta (car dl)))
214 (end (dis-line-position (car dl)))
215 (count 1 (1+ count)))
216 (())
217 (setf (dis-line-delta (car dl)) 0
218 (dis-line-flags (car dl)) unaltered-bits)
219 (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))
220 (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit))
221 ;; We push in different order because we pop in different order.
222 (cond
223 ((minusp delta)
224 (spush (- end delta) *display-up-move-stack* up)
225 (spush end *display-up-move-stack* up)
226 (spush count *display-up-move-stack* up))
227 (t
228 (spush count *display-down-move-stack* down)
229 (spush end *display-down-move-stack* down)
230 (spush (- end delta) *display-down-move-stack* down)))
231 (return nil))))
232 ;; Line changed, unmoved.
233 ((= flags changed-bit)
234 (cond ((zerop clear-count)
235 (spush (car dl) *display-rewrite-stack* rewrite))
236 (t
237 (spush (car dl) *display-write-stack* write)
238 (incf clear-count)))
239 (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))))
240 ;; Line unmoved, unchanged.
241 (t
242 (unless (zerop clear-count)
243 (spush clear-count *display-erase-stack* erase)
244 (spush clear-start *display-erase-stack* erase)
245 (setq clear-count 0))
246 (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))))
247
248 (when (eq prev last-changed)
249 ;; If done flush any pending clear.
250 (unless (zerop clear-count)
251 (spush clear-count *display-erase-stack* erase)
252 (spush clear-start *display-erase-stack* erase))
253 (return (values up down erase write rewrite))))))
254
255 (defun do-up-moves (hunk up)
256 (do ((i 0))
257 ((= i up))
258 (hunk-copy-lines hunk (snext *display-up-move-stack* i)
259 (snext *display-up-move-stack* i)
260 (snext *display-up-move-stack* i))))
261
262 (defun do-down-moves (hunk down)
263 (do ()
264 ((zerop down))
265 (hunk-copy-lines hunk (spop *display-down-move-stack* down)
266 (spop *display-down-move-stack* down)
267 (spop *display-down-move-stack* down))))
268
269 (defun do-erases (hunk erase)
270 (do ()
271 ((zerop erase))
272 (hunk-clear-lines hunk (spop *display-erase-stack* erase)
273 (spop *display-erase-stack* erase))))
274
275 (defun do-writes (hunk write)
276 (do ((i 0))
277 ((= i write))
278 (dumb-line-redisplay hunk (snext *display-write-stack* i))))
279
280 (defun do-rewrites (hunk rewrite)
281 (do ()
282 ((zerop rewrite))
283 (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite))))
284
285
286 ;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same,
287 ;;; clear to eol after we write it to avoid annoying flicker.
288 ;;;
289 (defun smart-line-redisplay (hunk dl)
290 (hunk-replace-line hunk dl)
291 (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))

  ViewVC Help
Powered by ViewVC 1.1.5