source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/winimage.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.0 KB
Line 
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#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;;    Written by Rob MacLachlan
13;;;
14;;; This file contains implementation independant functions that
15;;; build window images from the buffer structure.
16;;;
17(in-package :hemlock-internals)
18
19(defvar *the-sentinel*
20  (list (make-window-dis-line ""))
21  "This dis-line, which has several interesting properties, is used to end
22  lists of dis-lines.")
23(setf (dis-line-line (car *the-sentinel*))
24      (make-line :number most-positive-fixnum :chars ""))
25(setf (dis-line-position (car *the-sentinel*)) most-positive-fixnum)
26(setf (dis-line-old-chars (car *the-sentinel*)) :unique-thing)
27
28
29
30
31;;; move-lines  --  Internal
32;;;
33;;;    This function is called by Maybe-Change-Window when it believes that
34;;; a line needs to be inserted or deleted.  When called it finishes the
35;;; image-update for the entire rest of the window.  Here and many other
36;;; places the phrase "dis-line" is often used to mean a pointer into the
37;;; window's list of dis-lines.
38;;;
39;;; Window - The window whose image needs to be updated.
40;;; Changed - True if the first-changed line has already been set, if false
41;;;  we must set it.
42;;; String - The overhang string to be added to the beginning of the first
43;;;  line image we build.  If no overhang then this is NIL.
44;;; Underhang - The number of trailing chars of String to use.
45;;; Line - The line at which we are to continue building the image.  This
46;;;  may be NIL, in which case we are at the end of the buffer.
47;;; Offset - The charpos within Line to continue at.
48;;; Current - The dis-line which caused Maybe-Change-Window to choke; it
49;;;  may be *the-sentinel*, it may not be the dummy line at head of the
50;;;  window's dis-lines.  This is the dis-line at which Maybe-Change-Window
51;;;  turns over control, it should not be one whose image it built.
52;;; Trail - This is the dis-line which immediately precedes Current in the
53;;;  dis-line list.  It may be the dummy dis-line, it may not be the sentinel.
54;;; Width - (window-width window)
55(defun move-lines (window changed string underhang line offset trail current
56                          width)
57 
58  (do* ((delta 0)
59        (cc (car current))
60        (old-line (dis-line-line cc))
61        ;; Can't use current, since might be *the-sentinel*.
62        (pos (1+ (dis-line-position (car trail))))
63        ;; Are we on an extension line?
64        (is-wrapped (eq line (dis-line-line (car trail))))
65        (last (window-last-line window))
66        (last-line (dis-line-line (car last)))
67        (save trail)
68        (height (window-height window))
69        (spare-lines (window-spare-lines window))
70        ;; Make *the-sentinel* in this buffer so we don't delete it.
71        (buffer (setf (line-%buffer (dis-line-line (car *the-sentinel*)))
72                      (window-buffer window)))
73        (start offset) new-num)
74       ((or (= pos height) (null line))
75        ;;    If we have run off the bottom or run out of lines then we are
76        ;; done.  At this point Trail is the last line displayed and Current is
77        ;; whatever comes after it, possibly *the-sentinel*.
78        ;;    We always say that last-changed is the last line so that we
79        ;; don't have to max in the old last-changed.
80        (setf (window-last-changed window) trail)
81        ;; If there are extra lines at the end that need to be deleted
82        ;; and haven't been already then link them into the free-list.
83        (unless (eq last trail)
84          ;; This test works, because if the old last line was either
85          ;; deleted or another line was inserted after it then it's
86          ;; cdr would be something else.
87          (when (eq (cdr last) *the-sentinel*)
88            (shiftf (cdr last) spare-lines (cdr trail) *the-sentinel*))
89          (setf (window-last-line window) trail))
90        (setf (window-spare-lines window) spare-lines)
91        ;;    If first-changed has not been set then we set the first-changed
92        ;; to the first line we looked at if it does not come after the
93        ;; new position of the old first-changed.
94        (unless changed
95          (when (> (dis-line-position (car (window-first-changed window)))
96                   (dis-line-position (car save)))
97            (setf (window-first-changed window) (cdr save)))))
98
99    (setq new-num (line-number line))
100    ;; If a line has been deleted, it's line-%buffer is smashed; we unlink
101    ;; any dis-line which displayed such a line.
102    (cond
103     ((neq (line-%buffer old-line) buffer)
104      (do ((ptr (cdr current) (cdr ptr))
105           (prev current ptr))
106          ((eq (line-%buffer (dis-line-line (car ptr))) buffer)
107           (setq delta (- pos (1+ (dis-line-position (car prev)))))
108           (shiftf (cdr trail) (cdr prev) spare-lines current ptr)))
109      (setq cc (car current)  old-line (dis-line-line cc)))
110     ;; If the line-number of the old line is less than the line-number
111     ;; of the line we want to display then the old line must be off the top
112     ;; of the screen - delete it.  *The-Sentinel* fails this test because
113     ;; it's line-number is most-positive-fixnum.
114     ((< (line-number old-line) new-num)
115      (do ((ptr (cdr current) (cdr ptr))
116           (prev current ptr))
117          ((>= (line-number (dis-line-line (car ptr))) new-num)
118           (setq delta (- pos (1+ (dis-line-position (car prev)))))
119           (shiftf (cdr trail) (cdr prev) spare-lines current ptr)))
120      (setq cc (car current)  old-line (dis-line-line cc)))
121     ;; New line comes before old line, insert it, punting when
122     ;; we hit the bottom of the screen.
123     ((neq line old-line)
124      (do ((chars (unless is-wrapped (line-%chars line)) nil) new)
125          (())
126        (setq new (car spare-lines))
127        (setf (dis-line-old-chars new) chars
128              (dis-line-position new) pos
129              (dis-line-line new) line
130              (dis-line-delta new) 0
131              (dis-line-flags new) new-bit)
132        (setq pos (1+ pos)  delta (1+ delta))
133        (multiple-value-setq (string underhang start)
134          (compute-line-image string underhang line start new width))
135        (rotatef (cdr trail) spare-lines (cdr spare-lines))
136        (setq trail (cdr trail))
137        (cond ((= pos height)
138               (return nil))
139              ((null underhang)
140               (setq start 0  line (line-next line))
141               (return nil))))
142      (setq is-wrapped nil))
143     ;; The line is the same, possibly moved.  We add in the delta and
144     ;; or in the moved bit so that if redisplay punts in the middle
145     ;; the information is not lost.
146     ((eq (line-%chars line) (dis-line-old-chars cc))
147      ;; If the line is the old bottom line on the screen and it has moved and
148      ;; is full length, then mash the old-chars and quit so that the image
149      ;; will be recomputed the next time around the loop, since the line might
150      ;; have been wrapped off the bottom of the screen.
151      (cond
152       ((and (eq line last-line)
153             (= (dis-line-length cc) width)
154             (not (zerop delta)))
155        (setf (dis-line-old-chars cc) :another-unique-thing))
156       (t
157        (do ()
158            ((= pos height))
159          (unless (zerop delta)
160            (setf (dis-line-position cc) pos)
161            (incf (dis-line-delta cc) delta)
162            (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit)))
163          (shiftf trail current (cdr current))
164          (setq cc (car current)  old-line (dis-line-line cc)  pos (1+ pos))
165          (when (not (eq old-line line))
166            (setq start 0  line (line-next line))
167            (return nil))))))
168     ;; The line is changed, possibly moved.
169     (t
170      (do ((chars (line-%chars line) nil))
171          (())
172        (multiple-value-setq (string underhang start)
173          (compute-line-image string underhang line start cc width))
174        (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)
175              (dis-line-old-chars cc) chars
176              (dis-line-position cc) pos)
177        (unless (zerop delta)
178          (incf (dis-line-delta cc) delta)
179          (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit)))
180        (shiftf trail current (cdr current))
181        (setq cc (car current)  old-line (dis-line-line cc)  pos (1+ pos))
182        (cond ((= pos height)
183               (return nil))
184              ((null underhang)
185               (setq start 0  line (line-next line))
186               (return nil))
187              ((not (eq old-line line))
188               (setq is-wrapped t)
189               (return nil))))))))
190
191
192;;; maybe-change-window  --  Internal
193;;;
194;;;    This macro is "Called" in update-window-image whenever it finds that
195;;; the chars of the line and the dis-line don't match.  This may happen for
196;;; several reasons:
197;;;
198;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars
199;;; are nil.  In this case we just skip over the extension lines.
200;;;
201;;; 2] A line is changed but not moved; update the line noting whether the
202;;; next line is moved because of this, and bugging out to Move-Lines if
203;;; it is.
204;;;
205;;; 3] A line is deleted, off the top of the screen, or moved.  Bug out
206;;; to Move-Lines.
207;;;
208;;;    There are two possible results, either we return NIL, and Line,
209;;; Trail and Current are updated, or we return T, in which case
210;;; Update-Window-Image should terminate immediately.  Changed is true
211;;; if a changed line changed lines has been found.
212;;;
213(eval-when (:compile-toplevel :execute)
214(defmacro maybe-change-window (window changed line offset trail current width)
215  `(let* ((cc (car ,current))
216          (old-line (dis-line-line cc)))
217     (cond
218      ;; We have run into a continuation line, skip over any.
219      ((and (null (dis-line-old-chars cc))
220            (eq old-line (dis-line-line (car ,trail))))
221       (do ((ptr (cdr ,current) (cdr ptr))
222            (prev ,current ptr))
223           ((not (eq (dis-line-line (car ptr)) old-line))
224            (setq ,trail prev  ,current ptr) nil)))
225      ;; A line is changed.
226      ((eq old-line ,line)
227       (unless ,changed
228         (when (< (dis-line-position cc)
229                  (dis-line-position (car (window-first-changed ,window))))
230           (setf (window-first-changed ,window) ,current)
231           (setq ,changed t)))
232       (do ((chars (line-%chars ,line) nil)
233            (start ,offset) string underhang)
234           (())
235         (multiple-value-setq (string underhang start)
236           (compute-line-image string underhang ,line start cc ,width))
237         (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit))
238         (setf (dis-line-old-chars cc) chars)
239         (setq ,trail ,current  ,current (cdr ,current)  cc (car ,current))
240         (cond
241          ((eq (dis-line-line cc) ,line)
242           (unless underhang
243             (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current
244                         ,width)
245             (return t)))
246          (underhang
247           (move-lines ,window t string underhang ,line start ,trail
248                       ,current ,width)
249           (return t))
250          (t
251           (setq ,line (line-next ,line))
252           (when (> (dis-line-position (car ,trail))
253                    (dis-line-position (car (window-last-changed ,window))))
254             (setf (window-last-changed ,window) ,trail))
255           (return nil)))))
256      (t
257       (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current
258                   ,width)
259       t))))
260); eval-when
261
262;;; update-window-image  --  Internal
263;;;
264;;;    This is the function which redisplay calls when it wants to ensure that
265;;; a window-image is up-to-date.  The main loop here is just to zoom through
266;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever
267;;; something interesting happens.
268;;;
269(defun update-window-image (window)
270  (let* ((trail (window-first-line window))
271         (current (cdr trail))
272         (display-start (window-display-start window))
273         (line (mark-line display-start))
274         (width (window-width window)) changed)
275    (cond
276     ;; If the first line or its charpos has changed then bug out.
277     ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line))
278                  (mark= display-start (window-old-start window)))
279             (setq trail current  current (cdr current)  line (line-next line))
280             nil)
281            (t
282             ;; Force the line image to be invalid in case the start moved
283             ;; and the line wrapped onto the screen.  If we started at the
284             ;; beginning of the line then we don't need to.
285             (unless (zerop (mark-charpos (window-old-start window)))
286               (unless (eq current *the-sentinel*)
287                 (setf (dis-line-old-chars (car current)) :another-unique-thing)))
288             (let ((start-charpos (mark-charpos display-start)))
289               (move-mark (window-old-start window) display-start)
290               (maybe-change-window window changed line start-charpos
291                                    trail current width)))))
292     (t
293      (prog ()
294        (go TOP)
295       STEP
296        (setf (dis-line-line (car current)) line)
297        (setq trail current  current (cdr current)  line (line-next line))
298       TOP
299        (cond ((null line)
300               (go DONE))
301              ((eq (line-%chars line) (dis-line-old-chars (car current)))
302               (go STEP)))
303        ;;
304        ;; We found a suspect line.
305        ;; See if anything needs to be updated, if we bugged out, punt.
306        (when (and (eq current *the-sentinel*)
307                   (= (dis-line-position (car trail))
308                      (1- (window-height window))))
309          (return nil))
310        (when (maybe-change-window window changed line 0 trail current width)
311          (return nil))
312        (go TOP)
313
314       DONE
315        ;;
316        ;; We hit the end of the buffer. If lines need to be deleted bug out.
317        (unless (eq current *the-sentinel*)
318          (maybe-change-window window changed line 0 trail current width))
319        (return nil))))
320    ;;
321    ;; Update the display-end mark.
322    (let ((dl (car (window-last-line window))))
323      (move-to-position (window-display-end window) (dis-line-end dl)
324                        (dis-line-line dl)))))
Note: See TracBrowser for help on using the repository browser.