| 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, except for the code that implements random typeout,
|
|---|
| 13 | ;;; which was done by Blaine Burks and Bill Chiles. The code for splitting
|
|---|
| 14 | ;;; windows was rewritten by Blaine Burks to allow more than a 50/50 split.
|
|---|
| 15 | ;;;
|
|---|
| 16 | ;;; Terminal device screen management functions.
|
|---|
| 17 | ;;;
|
|---|
| 18 |
|
|---|
| 19 | (in-package :hemlock-internals)
|
|---|
| 20 |
|
|---|
| 21 |
|
|---|
| 22 | |
|---|
| 23 |
|
|---|
| 24 | ;;;; Terminal screen initialization
|
|---|
| 25 |
|
|---|
| 26 | (declaim (special *parse-starting-mark*))
|
|---|
| 27 |
|
|---|
| 28 | (defun init-tty-screen-manager (tty-name)
|
|---|
| 29 | (setf *line-wrap-char* #\!)
|
|---|
| 30 | (setf *window-list* ())
|
|---|
| 31 | (let* ((device (make-tty-device tty-name))
|
|---|
| 32 | (width (tty-device-columns device))
|
|---|
| 33 | (height (tty-device-lines device))
|
|---|
| 34 | (echo-height (value hemlock::echo-area-height))
|
|---|
| 35 | (main-lines (- height echo-height 1)) ;-1 for echo modeline.
|
|---|
| 36 | (main-text-lines (1- main-lines)) ;also main-modeline-pos.
|
|---|
| 37 | (last-text-line (1- main-text-lines)))
|
|---|
| 38 | (setf (device-bottom-window-base device) last-text-line)
|
|---|
| 39 | ;;
|
|---|
| 40 | ;; Make echo area.
|
|---|
| 41 | (let* ((echo-hunk (make-tty-hunk :position (1- height) :height echo-height
|
|---|
| 42 | :text-position (- height 2)
|
|---|
| 43 | :text-height echo-height :device device))
|
|---|
| 44 | (echo (internal-make-window :hunk echo-hunk)))
|
|---|
| 45 | (setf *echo-area-window* echo)
|
|---|
| 46 | (setf (device-hunk-window echo-hunk) echo)
|
|---|
| 47 | (setup-window-image *parse-starting-mark* echo echo-height width)
|
|---|
| 48 | (setup-modeline-image *echo-area-buffer* echo)
|
|---|
| 49 | (setf (device-hunk-previous echo-hunk) echo-hunk
|
|---|
| 50 | (device-hunk-next echo-hunk) echo-hunk)
|
|---|
| 51 | (prepare-window-for-redisplay echo))
|
|---|
| 52 | ;;
|
|---|
| 53 | ;; Make the main window.
|
|---|
| 54 | (let* ((main-hunk (make-tty-hunk :position main-text-lines
|
|---|
| 55 | :height main-lines
|
|---|
| 56 | :text-position last-text-line
|
|---|
| 57 | :text-height main-text-lines
|
|---|
| 58 | :device device))
|
|---|
| 59 | (main (internal-make-window :hunk main-hunk)))
|
|---|
| 60 | (setf (device-hunk-window main-hunk) main)
|
|---|
| 61 | (setf *current-window* main)
|
|---|
| 62 | (setup-window-image (buffer-point *current-buffer*)
|
|---|
| 63 | main main-text-lines width)
|
|---|
| 64 | (setup-modeline-image *current-buffer* main)
|
|---|
| 65 | (prepare-window-for-redisplay main)
|
|---|
| 66 | (setf (device-hunk-previous main-hunk) main-hunk
|
|---|
| 67 | (device-hunk-next main-hunk) main-hunk)
|
|---|
| 68 | (setf (device-hunks device) main-hunk))
|
|---|
| 69 | (defhvar "Paren Pause Period"
|
|---|
| 70 | "This is how long commands that deal with \"brackets\" shows the cursor at
|
|---|
| 71 | the matching \"bracket\" for this number of seconds."
|
|---|
| 72 | :value 0.5
|
|---|
| 73 | :mode "Lisp")))
|
|---|
| 74 |
|
|---|
| 75 |
|
|---|
| 76 | |
|---|
| 77 |
|
|---|
| 78 | ;;;; Building devices from termcaps.
|
|---|
| 79 |
|
|---|
| 80 | ;;; MAKE-TTY-DEVICE returns a device built from a termcap. Some function
|
|---|
| 81 | ;;; slots are set to the appropriate function even though the capability
|
|---|
| 82 | ;;; might not exist; in this case, we simply set the control string value
|
|---|
| 83 | ;;; to the empty string. Some function slots are set differently depending
|
|---|
| 84 | ;;; on available capability.
|
|---|
| 85 | ;;;
|
|---|
| 86 | (defun make-tty-device (name)
|
|---|
| 87 | (let ((termcap (get-termcap name))
|
|---|
| 88 | (device (%make-tty-device :name name)))
|
|---|
| 89 | (when (termcap :overstrikes termcap)
|
|---|
| 90 | (error "Terminal sufficiently irritating -- not currently supported."))
|
|---|
| 91 | ;;
|
|---|
| 92 | ;; Similar device slots.
|
|---|
| 93 | (setf (device-init device) #'init-tty-device)
|
|---|
| 94 | (setf (device-exit device) #'exit-tty-device)
|
|---|
| 95 | (setf (device-smart-redisplay device)
|
|---|
| 96 | (if (and (termcap :open-line termcap) (termcap :delete-line termcap))
|
|---|
| 97 | #'tty-smart-window-redisplay
|
|---|
| 98 | #'tty-semi-dumb-window-redisplay))
|
|---|
| 99 | (setf (device-dumb-redisplay device) #'tty-dumb-window-redisplay)
|
|---|
| 100 | (setf (device-clear device) #'clear-device)
|
|---|
| 101 | (setf (device-put-cursor device) #'tty-put-cursor)
|
|---|
| 102 | (setf (device-show-mark device) #'tty-show-mark)
|
|---|
| 103 | (setf (device-next-window device) #'tty-next-window)
|
|---|
| 104 | (setf (device-previous-window device) #'tty-previous-window)
|
|---|
| 105 | (setf (device-make-window device) #'tty-make-window)
|
|---|
| 106 | (setf (device-delete-window device) #'tty-delete-window)
|
|---|
| 107 | (setf (device-random-typeout-setup device) #'tty-random-typeout-setup)
|
|---|
| 108 | (setf (device-random-typeout-cleanup device) #'tty-random-typeout-cleanup)
|
|---|
| 109 | (setf (device-random-typeout-full-more device) #'do-tty-full-more)
|
|---|
| 110 | (setf (device-random-typeout-line-more device)
|
|---|
| 111 | #'update-tty-line-buffered-stream)
|
|---|
| 112 | (setf (device-force-output device) #'tty-force-output)
|
|---|
| 113 | (setf (device-finish-output device) #'tty-finish-output)
|
|---|
| 114 | (setf (device-beep device) #'tty-beep)
|
|---|
| 115 | ;;
|
|---|
| 116 | ;; A few useful values.
|
|---|
| 117 | (setf (tty-device-dumbp device)
|
|---|
| 118 | (not (and (termcap :open-line termcap)
|
|---|
| 119 | (termcap :delete-line termcap))))
|
|---|
| 120 | ;;
|
|---|
| 121 | ;; Get size and speed.
|
|---|
| 122 | (multiple-value-bind (lines cols speed)
|
|---|
| 123 | (get-terminal-attributes)
|
|---|
| 124 | (setf (tty-device-lines device) (or lines (termcap :lines termcap)))
|
|---|
| 125 | (let ((cols (or cols (termcap :columns termcap))))
|
|---|
| 126 | (setf (tty-device-columns device)
|
|---|
| 127 | (if (termcap :auto-margins-p termcap)
|
|---|
| 128 | (1- cols) cols)))
|
|---|
| 129 | (setf (tty-device-speed device) speed))
|
|---|
| 130 | ;;
|
|---|
| 131 | ;; Some function slots.
|
|---|
| 132 | (setf (tty-device-display-string device)
|
|---|
| 133 | (if (termcap :underlines termcap)
|
|---|
| 134 | #'display-string-checking-underlines
|
|---|
| 135 | #'display-string))
|
|---|
| 136 | (setf (tty-device-standout-init device) #'standout-init)
|
|---|
| 137 | (setf (tty-device-standout-end device) #'standout-end)
|
|---|
| 138 | (setf (tty-device-open-line device)
|
|---|
| 139 | (if (termcap :open-line termcap)
|
|---|
| 140 | #'open-tty-line
|
|---|
| 141 | ;; look for scrolling region stuff
|
|---|
| 142 | ))
|
|---|
| 143 | (setf (tty-device-delete-line device)
|
|---|
| 144 | (if (termcap :delete-line termcap)
|
|---|
| 145 | #'delete-tty-line
|
|---|
| 146 | ;; look for reverse scrolling stuff
|
|---|
| 147 | ))
|
|---|
| 148 | (setf (tty-device-clear-to-eol device)
|
|---|
| 149 | (if (termcap :clear-to-eol termcap)
|
|---|
| 150 | #'clear-to-eol
|
|---|
| 151 | #'space-to-eol))
|
|---|
| 152 | (setf (tty-device-clear-lines device) #'clear-lines)
|
|---|
| 153 | (setf (tty-device-clear-to-eow device) #'clear-to-eow)
|
|---|
| 154 | ;;
|
|---|
| 155 | ;; Insert and delete modes.
|
|---|
| 156 | (let ((init-insert-mode (termcap :init-insert-mode termcap))
|
|---|
| 157 | (init-insert-char (termcap :init-insert-char termcap))
|
|---|
| 158 | (end-insert-char (termcap :end-insert-char termcap)))
|
|---|
| 159 | (when (and init-insert-mode (string/= init-insert-mode ""))
|
|---|
| 160 | (setf (tty-device-insert-string device) #'tty-insert-string)
|
|---|
| 161 | (setf (tty-device-insert-init-string device) init-insert-mode)
|
|---|
| 162 | (setf (tty-device-insert-end-string device)
|
|---|
| 163 | (termcap :end-insert-mode termcap)))
|
|---|
| 164 | (when init-insert-char
|
|---|
| 165 | (setf (tty-device-insert-string device) #'tty-insert-string)
|
|---|
| 166 | (setf (tty-device-insert-char-init-string device) init-insert-char))
|
|---|
| 167 | (when (and end-insert-char (string/= end-insert-char ""))
|
|---|
| 168 | (setf (tty-device-insert-char-end-string device) end-insert-char)))
|
|---|
| 169 | (let ((delete-char (termcap :delete-char termcap)))
|
|---|
| 170 | (when delete-char
|
|---|
| 171 | (setf (tty-device-delete-char device) #'delete-char)
|
|---|
| 172 | (setf (tty-device-delete-char-string device) delete-char)
|
|---|
| 173 | (setf (tty-device-delete-init-string device)
|
|---|
| 174 | (termcap :init-delete-mode termcap))
|
|---|
| 175 | (setf (tty-device-delete-end-string device)
|
|---|
| 176 | (termcap :end-delete-mode termcap))))
|
|---|
| 177 | ;;
|
|---|
| 178 | ;; Some string slots.
|
|---|
| 179 | (setf (tty-device-standout-init-string device)
|
|---|
| 180 | (or (termcap :init-standout-mode termcap) ""))
|
|---|
| 181 | (setf (tty-device-standout-end-string device)
|
|---|
| 182 | (or (termcap :end-standout-mode termcap) ""))
|
|---|
| 183 | (setf (tty-device-clear-to-eol-string device)
|
|---|
| 184 | (termcap :clear-to-eol termcap))
|
|---|
| 185 | (let ((clear-string (termcap :clear-display termcap)))
|
|---|
| 186 | (unless clear-string
|
|---|
| 187 | (error "Terminal not sufficiently powerful enough to run Hemlock."))
|
|---|
| 188 | (setf (tty-device-clear-string device) clear-string))
|
|---|
| 189 | (setf (tty-device-open-line-string device)
|
|---|
| 190 | (termcap :open-line termcap))
|
|---|
| 191 | (setf (tty-device-delete-line-string device)
|
|---|
| 192 | (termcap :delete-line termcap))
|
|---|
| 193 | (let* ((init-string (termcap :init-string termcap))
|
|---|
| 194 | (init-file (termcap :init-file termcap))
|
|---|
| 195 | (init-file-string (if init-file (get-init-file-string init-file)))
|
|---|
| 196 | (init-cm-string (termcap :init-cursor-motion termcap)))
|
|---|
| 197 | (setf (tty-device-init-string device)
|
|---|
| 198 | (concatenate 'simple-string (or init-string "")
|
|---|
| 199 | (or init-file-string "") (or init-cm-string ""))))
|
|---|
| 200 | (setf (tty-device-cm-end-string device)
|
|---|
| 201 | (or (termcap :end-cursor-motion termcap) ""))
|
|---|
| 202 | ;;
|
|---|
| 203 | ;; Cursor motion slots.
|
|---|
| 204 | (let ((cursor-motion (termcap :cursor-motion termcap)))
|
|---|
| 205 | (unless cursor-motion
|
|---|
| 206 | (error "Terminal not sufficiently powerful enough to run Hemlock."))
|
|---|
| 207 | (let ((x-add-char (getf cursor-motion :x-add-char))
|
|---|
| 208 | (y-add-char (getf cursor-motion :y-add-char))
|
|---|
| 209 | (x-condx-char (getf cursor-motion :x-condx-char))
|
|---|
| 210 | (y-condx-char (getf cursor-motion :y-condx-char)))
|
|---|
| 211 | (when x-add-char
|
|---|
| 212 | (setf (tty-device-cm-x-add-char device) (char-code x-add-char)))
|
|---|
| 213 | (when y-add-char
|
|---|
| 214 | (setf (tty-device-cm-y-add-char device) (char-code y-add-char)))
|
|---|
| 215 | (when x-condx-char
|
|---|
| 216 | (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char))
|
|---|
| 217 | (setf (tty-device-cm-x-condx-add-char device)
|
|---|
| 218 | (char-code (getf cursor-motion :x-condx-add-char))))
|
|---|
| 219 | (when y-condx-char
|
|---|
| 220 | (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char))
|
|---|
| 221 | (setf (tty-device-cm-y-condx-add-char device)
|
|---|
| 222 | (char-code (getf cursor-motion :y-condx-add-char)))))
|
|---|
| 223 | (setf (tty-device-cm-string1 device) (getf cursor-motion :string1))
|
|---|
| 224 | (setf (tty-device-cm-string2 device) (getf cursor-motion :string2))
|
|---|
| 225 | (setf (tty-device-cm-string3 device) (getf cursor-motion :string3))
|
|---|
| 226 | (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin))
|
|---|
| 227 | (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep))
|
|---|
| 228 | (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad))
|
|---|
| 229 | (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad)))
|
|---|
| 230 | ;;
|
|---|
| 231 | ;; Screen image initialization.
|
|---|
| 232 | (let* ((lines (tty-device-lines device))
|
|---|
| 233 | (columns (tty-device-columns device))
|
|---|
| 234 | (screen-image (make-array lines)))
|
|---|
| 235 | (dotimes (i lines)
|
|---|
| 236 | (setf (svref screen-image i) (make-si-line columns)))
|
|---|
| 237 | (setf (tty-device-screen-image device) screen-image))
|
|---|
| 238 | device))
|
|---|
| 239 |
|
|---|
| 240 |
|
|---|
| 241 | |
|---|
| 242 |
|
|---|
| 243 | ;;;; Making a window
|
|---|
| 244 |
|
|---|
| 245 | (defun tty-make-window (device start modelinep window font-family
|
|---|
| 246 | ask-user x y width height proportion)
|
|---|
| 247 | (declare (ignore window font-family ask-user x y width height))
|
|---|
| 248 | (let* ((old-window (current-window))
|
|---|
| 249 | (victim (window-hunk old-window))
|
|---|
| 250 | (text-height (tty-hunk-text-height victim))
|
|---|
| 251 | (availability (if modelinep (1- text-height) text-height)))
|
|---|
| 252 | (when (> availability 1)
|
|---|
| 253 | (let* ((new-lines (truncate (* availability proportion)))
|
|---|
| 254 | (old-lines (- availability new-lines))
|
|---|
| 255 | (pos (device-hunk-position victim))
|
|---|
| 256 | (new-height (if modelinep (1+ new-lines) new-lines))
|
|---|
| 257 | (new-text-pos (if modelinep (1- pos) pos))
|
|---|
| 258 | (new-hunk (make-tty-hunk :position pos
|
|---|
| 259 | :height new-height
|
|---|
| 260 | :text-position new-text-pos
|
|---|
| 261 | :text-height new-lines
|
|---|
| 262 | :device device))
|
|---|
| 263 | (new-window (internal-make-window :hunk new-hunk)))
|
|---|
| 264 | (declare (fixnum new-lines old-lines pos new-height new-text-pos))
|
|---|
| 265 | (setf (device-hunk-window new-hunk) new-window)
|
|---|
| 266 | (let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim)))
|
|---|
| 267 | (old-win-new-pos (- pos new-height)))
|
|---|
| 268 | (declare (fixnum old-text-pos-diff old-win-new-pos))
|
|---|
| 269 | (setf (device-hunk-height victim)
|
|---|
| 270 | (- (device-hunk-height victim) new-height))
|
|---|
| 271 | (setf (tty-hunk-text-height victim) old-lines)
|
|---|
| 272 | (setf (device-hunk-position victim) old-win-new-pos)
|
|---|
| 273 | (setf (tty-hunk-text-position victim)
|
|---|
| 274 | (- old-win-new-pos old-text-pos-diff)))
|
|---|
| 275 | (setup-window-image start new-window new-lines
|
|---|
| 276 | (window-width old-window))
|
|---|
| 277 | (prepare-window-for-redisplay new-window)
|
|---|
| 278 | (when modelinep
|
|---|
| 279 | (setup-modeline-image (line-buffer (mark-line start)) new-window))
|
|---|
| 280 | (change-window-image-height old-window old-lines)
|
|---|
| 281 | (shiftf (device-hunk-previous new-hunk)
|
|---|
| 282 | (device-hunk-previous (device-hunk-next victim))
|
|---|
| 283 | new-hunk)
|
|---|
| 284 | (shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk)
|
|---|
| 285 | (setf *currently-selected-hunk* nil)
|
|---|
| 286 | (setf *screen-image-trashed* t)
|
|---|
| 287 | new-window))))
|
|---|
| 288 |
|
|---|
| 289 |
|
|---|
| 290 | |
|---|
| 291 |
|
|---|
| 292 | ;;;; Deleting a window
|
|---|
| 293 |
|
|---|
| 294 | (defun tty-delete-window (window)
|
|---|
| 295 | (let* ((hunk (window-hunk window))
|
|---|
| 296 | (prev (device-hunk-previous hunk))
|
|---|
| 297 | (next (device-hunk-next hunk))
|
|---|
| 298 | (device (device-hunk-device hunk)))
|
|---|
| 299 | (setf (device-hunk-next prev) next)
|
|---|
| 300 | (setf (device-hunk-previous next) prev)
|
|---|
| 301 | (let ((buffer (window-buffer window)))
|
|---|
| 302 | (setf (buffer-windows buffer) (delq window (buffer-windows buffer))))
|
|---|
| 303 | (let ((new-lines (device-hunk-height hunk)))
|
|---|
| 304 | (declare (fixnum new-lines))
|
|---|
| 305 | (cond ((eq hunk (device-hunks (device-hunk-device next)))
|
|---|
| 306 | (incf (device-hunk-height next) new-lines)
|
|---|
| 307 | (incf (tty-hunk-text-height next) new-lines)
|
|---|
| 308 | (let ((w (device-hunk-window next)))
|
|---|
| 309 | (change-window-image-height w (+ new-lines (window-height w)))))
|
|---|
| 310 | (t
|
|---|
| 311 | (incf (device-hunk-height prev) new-lines)
|
|---|
| 312 | (incf (device-hunk-position prev) new-lines)
|
|---|
| 313 | (incf (tty-hunk-text-height prev) new-lines)
|
|---|
| 314 | (incf (tty-hunk-text-position prev) new-lines)
|
|---|
| 315 | (let ((w (device-hunk-window prev)))
|
|---|
| 316 | (change-window-image-height w (+ new-lines (window-height w)))))))
|
|---|
| 317 | (when (eq hunk (device-hunks device))
|
|---|
| 318 | (setf (device-hunks device) next)))
|
|---|
| 319 | (setf *currently-selected-hunk* nil)
|
|---|
| 320 | (setf *screen-image-trashed* t))
|
|---|
| 321 |
|
|---|
| 322 |
|
|---|
| 323 | |
|---|
| 324 |
|
|---|
| 325 | ;;;; Next and Previous window operations.
|
|---|
| 326 |
|
|---|
| 327 | (defun tty-next-window (window)
|
|---|
| 328 | (device-hunk-window (device-hunk-next (window-hunk window))))
|
|---|
| 329 |
|
|---|
| 330 | (defun tty-previous-window (window)
|
|---|
| 331 | (device-hunk-window (device-hunk-previous (window-hunk window))))
|
|---|
| 332 |
|
|---|
| 333 |
|
|---|
| 334 | |
|---|
| 335 |
|
|---|
| 336 | ;;;; Random typeout support
|
|---|
| 337 |
|
|---|
| 338 | (defun tty-random-typeout-setup (device stream height)
|
|---|
| 339 | (declare (fixnum height))
|
|---|
| 340 | (let* ((*more-prompt-action* :empty)
|
|---|
| 341 | (height (min (1- (device-bottom-window-base device)) height))
|
|---|
| 342 | (old-hwindow (random-typeout-stream-window stream))
|
|---|
| 343 | (new-hwindow (if old-hwindow
|
|---|
| 344 | (change-tty-random-typeout-window old-hwindow height)
|
|---|
| 345 | (setf (random-typeout-stream-window stream)
|
|---|
| 346 | (make-tty-random-typeout-window
|
|---|
| 347 | device
|
|---|
| 348 | (buffer-start-mark
|
|---|
| 349 | (line-buffer
|
|---|
| 350 | (mark-line
|
|---|
| 351 | (random-typeout-stream-mark stream))))
|
|---|
| 352 | height)))))
|
|---|
| 353 | (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0)))
|
|---|
| 354 |
|
|---|
| 355 | (defun change-tty-random-typeout-window (window height)
|
|---|
| 356 | (update-modeline-field (window-buffer window) window :more-prompt)
|
|---|
| 357 | (let* ((height-1 (1- height))
|
|---|
| 358 | (hunk (window-hunk window)))
|
|---|
| 359 | (setf (device-hunk-position hunk) height-1
|
|---|
| 360 | (device-hunk-height hunk) height
|
|---|
| 361 | (tty-hunk-text-position hunk) (1- height-1)
|
|---|
| 362 | (tty-hunk-text-height hunk) height-1)
|
|---|
| 363 | (change-window-image-height window height-1)
|
|---|
| 364 | window))
|
|---|
| 365 |
|
|---|
| 366 | (defun make-tty-random-typeout-window (device mark height)
|
|---|
| 367 | (let* ((height-1 (1- height))
|
|---|
| 368 | (hunk (make-tty-hunk :position height-1
|
|---|
| 369 | :height height
|
|---|
| 370 | :text-position (1- height-1)
|
|---|
| 371 | :text-height height-1
|
|---|
| 372 | :device device))
|
|---|
| 373 | (window (internal-make-window :hunk hunk)))
|
|---|
| 374 | (setf (device-hunk-window hunk) window)
|
|---|
| 375 | (setf (device-hunk-device hunk) device)
|
|---|
| 376 | (setup-window-image mark window height-1 (tty-device-columns device))
|
|---|
| 377 | (setf *window-list* (delete window *window-list*))
|
|---|
| 378 | (prepare-window-for-redisplay window)
|
|---|
| 379 | (setup-modeline-image (line-buffer (mark-line mark)) window)
|
|---|
| 380 | (update-modeline-field (window-buffer window) window :more-prompt)
|
|---|
| 381 | window))
|
|---|
| 382 |
|
|---|
| 383 | (defun tty-random-typeout-cleanup (stream degree)
|
|---|
| 384 | (declare (ignore degree))
|
|---|
| 385 | (let* ((window (random-typeout-stream-window stream))
|
|---|
| 386 | (stream-hunk (window-hunk window))
|
|---|
| 387 | (last-line-affected (device-hunk-position stream-hunk))
|
|---|
| 388 | (device (device-hunk-device stream-hunk))
|
|---|
| 389 | (*more-prompt-action* :normal))
|
|---|
| 390 | (declare (fixnum last-line-affected))
|
|---|
| 391 | (update-modeline-field (window-buffer window) window :more-prompt)
|
|---|
| 392 | (funcall (tty-device-clear-to-eow device) stream-hunk 0 0)
|
|---|
| 393 | (do* ((hunk (device-hunks device) (device-hunk-next hunk))
|
|---|
| 394 | (window (device-hunk-window hunk) (device-hunk-window hunk))
|
|---|
| 395 | (last (device-hunk-previous hunk)))
|
|---|
| 396 | ((>= (device-hunk-position hunk) last-line-affected)
|
|---|
| 397 | (if (= (device-hunk-position hunk) last-line-affected)
|
|---|
| 398 | (redisplay-window-all window)
|
|---|
| 399 | (tty-redisplay-n-lines window
|
|---|
| 400 | (- (+ last-line-affected
|
|---|
| 401 | (tty-hunk-text-height hunk))
|
|---|
| 402 | (tty-hunk-text-position hunk)))))
|
|---|
| 403 | (redisplay-window-all window)
|
|---|
| 404 | (when (eq hunk last) (return)))))
|
|---|
