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