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