/[cmucl]/src/hemlock/window.lisp
ViewVC logotype

Contents of /src/hemlock/window.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b, RELEASE_18c
Branch point for: RELENG_18
Changes since 1.3: +1 -3 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/window.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains implementation independent code which implements
13 ;;; the Hemlock window primitives and most of the code which defines
14 ;;; other aspects of the interface to redisplay.
15 ;;;
16 ;;; Written by Bill Chiles and Rob MacLachlan.
17 ;;;
18
19 (in-package "HEMLOCK-INTERNALS")
20
21 (export '(current-window window-buffer modeline-field-width
22 modeline-field-function make-modeline-field update-modeline-fields
23 update-modeline-field modeline-field-name modeline-field
24 editor-finish-output *window-list*))
25
26
27
28 ;;;; CURRENT-WINDOW.
29
30 (defvar *current-window* nil "The current window object.")
31 (defvar *window-list* () "A list of all window objects.")
32
33 (proclaim '(inline current-window))
34
35 (defun current-window ()
36 "Return the current window. The current window is specially treated by
37 redisplay in several ways, the most important of which is that is does
38 recentering, ensuring that the Buffer-Point of the current window's
39 Window-Buffer is always displayed. This may be set with Setf."
40 *current-window*)
41
42 (defun %set-current-window (new-window)
43 (invoke-hook ed::set-window-hook new-window)
44 (move-mark (window-point *current-window*)
45 (buffer-point (window-buffer *current-window*)))
46 (move-mark (buffer-point (window-buffer new-window))
47 (window-point new-window))
48 (setq *current-window* new-window))
49
50
51
52 ;;;; Window structure support.
53
54 (defun %print-hwindow (obj stream depth)
55 (declare (ignore depth))
56 (write-string "#<Hemlock Window \"" stream)
57 (write-string (buffer-name (window-buffer obj)) stream)
58 (write-string "\">" stream))
59
60
61 (defun window-buffer (window)
62 "Return the buffer which is displayed in Window."
63 (window-%buffer window))
64
65 (defun %set-window-buffer (window new-buffer)
66 (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer))
67 (unless (windowp window) (error "~S is not a window." window))
68 (unless (eq new-buffer (window-buffer window))
69 (invoke-hook ed::window-buffer-hook window new-buffer)
70 ;;
71 ;; Move the window's marks to the new start.
72 (let ((buffer (window-buffer window)))
73 (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))
74 (move-mark (buffer-display-start buffer) (window-display-start window))
75 (push window (buffer-windows new-buffer))
76 (move-mark (window-point window) (buffer-point new-buffer))
77 (move-mark (window-display-start window) (buffer-display-start new-buffer))
78 (move-mark (window-display-end window) (buffer-display-start new-buffer)))
79 ;;
80 ;; Delete all the dis-lines, and nil out the line and chars so they get
81 ;; gc'ed.
82 (let ((first (window-first-line window))
83 (last (window-last-line window))
84 (free (window-spare-lines window)))
85 (unless (eq (cdr first) the-sentinel)
86 (shiftf (cdr last) free (cdr first) the-sentinel))
87 (dolist (dl free)
88 (setf (dis-line-line dl) nil (dis-line-old-chars dl) nil))
89 (setf (window-spare-lines window) free))
90 ;;
91 ;; Set the last line and first&last changed so we know there's nothing there.
92 (setf (window-last-line window) the-sentinel
93 (window-first-changed window) the-sentinel
94 (window-last-changed window) the-sentinel)
95 ;;
96 ;; Make sure the window gets updated, and set the buffer.
97 (setf (window-tick window) -3)
98 (setf (window-%buffer window) new-buffer)))
99
100
101
102 ;;; %INIT-REDISPLAY sets up redisplay's internal data structures. We create
103 ;;; initial windows, setup some hooks to cause modeline recomputation, and call
104 ;;; any device init necessary. This is called from ED.
105 ;;;
106 (defun %init-redisplay (display)
107 (%init-screen-manager display)
108 (add-hook ed::buffer-major-mode-hook 'queue-buffer-change)
109 (add-hook ed::buffer-minor-mode-hook 'queue-buffer-change)
110 (add-hook ed::buffer-name-hook 'queue-buffer-change)
111 (add-hook ed::buffer-pathname-hook 'queue-buffer-change)
112 (add-hook ed::buffer-modified-hook 'queue-buffer-change)
113 (add-hook ed::window-buffer-hook 'queue-window-change)
114 (let ((device (device-hunk-device (window-hunk (current-window)))))
115 (funcall (device-init device) device))
116 (center-window *current-window* (current-point)))
117
118
119
120 ;;;; Modelines-field structure support.
121
122 (defun print-modeline-field (obj stream ignore)
123 (declare (ignore ignore))
124 (write-string "#<Hemlock Modeline-field " stream)
125 (prin1 (modeline-field-%name obj) stream)
126 (write-string ">" stream))
127
128 (defun print-modeline-field-info (obj stream ignore)
129 (declare (ignore ignore))
130 (write-string "#<Hemlock Modeline-field-info " stream)
131 (prin1 (modeline-field-%name (ml-field-info-field obj)) stream)
132 (write-string ">" stream))
133
134
135 (defvar *modeline-field-names* (make-hash-table))
136
137 (defun make-modeline-field (&key name width function)
138 "Returns a modeline-field object."
139 (unless (or (eq width nil) (and (integerp width) (plusp width)))
140 (error "Width must be nil or a positive integer."))
141 (when (gethash name *modeline-field-names*)
142 (with-simple-restart (continue
143 "Use the new definition for this modeline field.")
144 (error "Modeline field ~S already exists."
145 (gethash name *modeline-field-names*))))
146 (setf (gethash name *modeline-field-names*)
147 (%make-modeline-field name function width)))
148
149 (defun modeline-field (name)
150 "Returns the modeline-field object named name. If none exists, return nil."
151 (gethash name *modeline-field-names*))
152
153
154 (proclaim '(inline modeline-field-name modeline-field-width
155 modeline-field-function))
156
157 (defun modeline-field-name (ml-field)
158 "Returns the name of a modeline field object."
159 (modeline-field-%name ml-field))
160
161 (defun %set-modeline-field-name (ml-field name)
162 (check-type ml-field modeline-field)
163 (when (gethash name *modeline-field-names*)
164 (error "Modeline field ~S already exists."
165 (gethash name *modeline-field-names*)))
166 (remhash (modeline-field-%name ml-field) *modeline-field-names*)
167 (setf (modeline-field-%name ml-field) name)
168 (setf (gethash name *modeline-field-names*) ml-field))
169
170 (defun modeline-field-width (ml-field)
171 "Returns the width of a modeline field."
172 (modeline-field-%width ml-field))
173
174 (proclaim '(special *buffer-list*))
175
176 (defun %set-modeline-field-width (ml-field width)
177 (check-type ml-field modeline-field)
178 (unless (or (eq width nil) (and (integerp width) (plusp width)))
179 (error "Width must be nil or a positive integer."))
180 (unless (eql width (modeline-field-%width ml-field))
181 (setf (modeline-field-%width ml-field) width)
182 (dolist (b *buffer-list*)
183 (when (buffer-modeline-field-p b ml-field)
184 (dolist (w (buffer-windows b))
185 (update-modeline-fields b w)))))
186 width)
187
188 (defun modeline-field-function (ml-field)
189 "Returns the function of a modeline field object. It returns a string."
190 (modeline-field-%function ml-field))
191
192 (defun %set-modeline-field-function (ml-field function)
193 (check-type ml-field modeline-field)
194 (check-type function (or symbol function))
195 (setf (modeline-field-%function ml-field) function)
196 (dolist (b *buffer-list*)
197 (when (buffer-modeline-field-p b ml-field)
198 (dolist (w (buffer-windows b))
199 (update-modeline-field b w ml-field))))
200 function)
201
202
203
204 ;;;; Modelines maintenance.
205
206 ;;; Each window stores a modeline-buffer which is a string hunk-width-limit
207 ;;; long. Whenever a field is updated, we must maintain a maximally long
208 ;;; representation of the modeline in case the window is resized. Updating
209 ;;; then first gets the modeline-buffer setup, and second blasts the necessary
210 ;;; portion into the window's modeline-dis-line, setting the dis-line's changed
211 ;;; flag.
212 ;;;
213
214 (defun update-modeline-fields (buffer window)
215 "Recompute all the fields of buffer's modeline for window, so the next
216 redisplay will reflect changes."
217 (let ((ml-buffer (window-modeline-buffer window)))
218 (declare (simple-string ml-buffer))
219 (when ml-buffer
220 (let* ((ml-buffer-len
221 (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos))
222 (start 0 (blt-modeline-field-buffer
223 ml-buffer (car finfos) buffer window start)))
224 ((null finfos) start)))
225 (dis-line (window-modeline-dis-line window))
226 (len (min (window-width window) ml-buffer-len)))
227 (replace (the simple-string (dis-line-chars dis-line)) ml-buffer
228 :end1 len :end2 len)
229 (setf (window-modeline-buffer-len window) ml-buffer-len)
230 (setf (dis-line-length dis-line) len)
231 (setf (dis-line-flags dis-line) changed-bit)))))
232
233 ;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer
234 ;;; after blt'ing into buffer. Otherwise it has to do all the work
235 ;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars. It
236 ;;; isn't worth it. Since things could have shifted around, after calling
237 ;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long
238 ;;; the buffer is now.
239 ;;;
240 (defun update-modeline-field (buffer window field)
241 "Recompute the field of the buffer's modeline for window, so the next
242 redisplay will reflect the change. Field is either a modeline-field object
243 or the name of one for buffer."
244 (let ((finfo (internal-buffer-modeline-field-p buffer field)))
245 (unless finfo
246 (error "~S is not a modeline-field or the name of one for buffer ~S."
247 field buffer))
248 (let ((ml-buffer (window-modeline-buffer window))
249 (dis-line (window-modeline-dis-line window)))
250 (declare (simple-string ml-buffer))
251 (blt-modeline-field-buffer ml-buffer finfo buffer window
252 (ml-field-info-start finfo) t)
253 (let* ((ml-buffer-len (ml-field-info-end
254 (car (last (buffer-%modeline-fields buffer)))))
255 (dis-len (min (window-width window) ml-buffer-len)))
256 (replace (the simple-string (dis-line-chars dis-line)) ml-buffer
257 :end1 dis-len :end2 dis-len)
258 (setf (window-modeline-buffer-len window) ml-buffer-len)
259 (setf (dis-line-length dis-line) dis-len)
260 (setf (dis-line-flags dis-line) changed-bit)))))
261
262 (defvar *truncated-field-char* #\!)
263
264 ;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the
265 ;;; window's modeline buffer, a modeline-field-info object, a start in the
266 ;;; modeline buffer, and an optional indicating whether a variable width field
267 ;;; should be handled carefully. When the field is fixed-width, this is
268 ;;; simple. When it is variable, we possibly have to shift all the text in the
269 ;;; buffer right or left before storing the new string, updating all the
270 ;;; finfo's after the one we're updating. It is an error for the
271 ;;; modeline-field-function to return anything but a simple-string with
272 ;;; standard-chars. This returns the end of the field blasted into ml-buffer.
273 ;;;
274 (defun blt-modeline-field-buffer (ml-buffer finfo buffer window start
275 &optional fix-other-fields-p)
276 (declare (simple-string ml-buffer))
277 (let* ((f (ml-field-info-field finfo))
278 (width (modeline-field-width f))
279 (string (funcall (modeline-field-function f) buffer window))
280 (str-len (length string)))
281 (declare (simple-string string))
282 (setf (ml-field-info-start finfo) start)
283 (setf (ml-field-info-end finfo)
284 (cond
285 ((not width)
286 (let ((end (min (+ start str-len) hunk-width-limit))
287 (last-end (ml-field-info-end finfo)))
288 (when (and fix-other-fields-p (/= end last-end))
289 (blt-ml-field-buffer-fix ml-buffer finfo buffer window
290 end last-end))
291 (replace ml-buffer string :start1 start :end1 end :end2 str-len)
292 end))
293 ((= str-len width)
294 (let ((end (min (+ start width) hunk-width-limit)))
295 (replace ml-buffer string :start1 start :end1 end :end2 width)
296 end))
297 ((> str-len width)
298 (let* ((end (min (+ start width) hunk-width-limit))
299 (end-1 (1- end)))
300 (replace ml-buffer string :start1 start :end1 end-1 :end2 width)
301 (setf (schar ml-buffer end-1) *truncated-field-char*)
302 end))
303 (t
304 (let ((buf-replace-end (min (+ start str-len) hunk-width-limit))
305 (buf-field-end (min (+ start width) hunk-width-limit)))
306 (replace ml-buffer string
307 :start1 start :end1 buf-replace-end :end2 str-len)
308 (fill ml-buffer #\space :start buf-replace-end :end buf-field-end)
309 buf-field-end))))))
310
311 ;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction
312 ;;; of last-end to end. finfo is a modeline-field-info structure in buffer's
313 ;;; list of these. If there are none following finfo, then we simply store the
314 ;;; new end of the buffer. After blt'ing the text around, we have to update
315 ;;; all the finfos' starts and ends making sure nobody gets to stick out over
316 ;;; the ml-buffer's end.
317 ;;;
318 (defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end)
319 (declare (simple-string ml-buffer))
320 (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f)))
321 ((null f) (error "This field must be here."))
322 (if (eq (car f) finfo)
323 (return (cdr f))))))
324 (cond
325 ((not finfos)
326 (setf (window-modeline-buffer-len window) (min end hunk-width-limit)))
327 (t
328 (let ((buffer-len (window-modeline-buffer-len window)))
329 (replace ml-buffer ml-buffer
330 :start1 end
331 :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit)
332 :start2 last-end :end2 buffer-len)
333 (let ((diff (- end last-end)))
334 (macrolet ((frob (f)
335 `(setf ,f (min (+ ,f diff) hunk-width-limit))))
336 (dolist (f finfos)
337 (frob (ml-field-info-start f))
338 (frob (ml-field-info-end f)))
339 (frob (window-modeline-buffer-len window)))))))))
340
341
342
343 ;;;; Default modeline and update hooks.
344
345 (make-modeline-field :name :hemlock-literal :width 8
346 :function #'(lambda (buffer window)
347 "Returns \"Hemlock \"."
348 (declare (ignore buffer window))
349 "Hemlock "))
350
351 (make-modeline-field
352 :name :package
353 :function #'(lambda (buffer window)
354 "Returns the value of buffer's \"Current Package\" followed
355 by a colon and two spaces, or a string with one space."
356 (declare (ignore window))
357 (if (hemlock-bound-p 'ed::current-package :buffer buffer)
358 (let ((val (variable-value 'ed::current-package
359 :buffer buffer)))
360 (if val
361 (format nil "~A: " val)
362 " "))
363 " ")))
364
365 (make-modeline-field
366 :name :modes
367 :function #'(lambda (buffer window)
368 "Returns buffer's modes followed by one space."
369 (declare (ignore window))
370 (format nil "~A " (buffer-modes buffer))))
371
372 (make-modeline-field
373 :name :modifiedp
374 :function #'(lambda (buffer window)
375 "Returns \"* \" if buffer is modified, or the empty string."
376 (declare (ignore window))
377 (let ((modifiedp (buffer-modified buffer)))
378 (if modifiedp
379 "* "
380 ""))))
381
382 (make-modeline-field
383 :name :buffer-name
384 :function #'(lambda (buffer window)
385 "Returns buffer's name followed by a colon and a space if the
386 name is not derived from the buffer's pathname, or the empty
387 string."
388 (declare (ignore window))
389 (let ((pn (buffer-pathname buffer))
390 (name (buffer-name buffer)))
391 (cond ((not pn)
392 (format nil "~A: " name))
393 ((string/= (ed::pathname-to-buffer-name pn) name)
394 (format nil "~A: " name))
395 (t "")))))
396
397
398 ;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline
399 ;;; Pathname Length" is set.
400 ;;;
401 (defun maximum-modeline-pathname-length-hook (name kind where new-value)
402 (declare (ignore name new-value))
403 (if (eq kind :buffer)
404 (hi::queue-buffer-change where)
405 (dolist (buffer *buffer-list*)
406 (when (and (buffer-modeline-field-p buffer :buffer-pathname)
407 (buffer-windows buffer))
408 (hi::queue-buffer-change buffer)))))
409
410 (defun buffer-pathname-ml-field-fun (buffer window)
411 "Returns the namestring of buffer's pathname if there is one. When
412 \"Maximum Modeline Pathname Length\" is set, and the namestring is too long,
413 return a truncated namestring chopping off leading directory specifications."
414 (declare (ignore window))
415 (let ((pn (buffer-pathname buffer)))
416 (if pn
417 (let* ((name (namestring pn))
418 (length (length name))
419 ;; Prefer a buffer local value over the global one.
420 ;; Because variables don't work right, blow off looking for
421 ;; a value in the buffer's modes. In the future this will
422 ;; be able to get the "current" value as if buffer were current.
423 (max (if (hemlock-bound-p 'ed::maximum-modeline-pathname-length
424 :buffer buffer)
425 (variable-value 'ed::maximum-modeline-pathname-length
426 :buffer buffer)
427 (variable-value 'ed::maximum-modeline-pathname-length
428 :global))))
429 (declare (simple-string name))
430 (if (or (not max) (<= length max))
431 name
432 (let* ((extra-chars (+ (- length max) 3))
433 (slash (or (position #\/ name :start extra-chars)
434 ;; If no slash, then file-namestring is very
435 ;; long, and we should include all of it:
436 (position #\/ name :from-end t
437 :end extra-chars))))
438 (if slash
439 (concatenate 'simple-string "..." (subseq name slash))
440 name))))
441 "")))
442
443 (make-modeline-field
444 :name :buffer-pathname
445 :function 'buffer-pathname-ml-field-fun)
446
447
448 (defvar *default-modeline-fields*
449 (list (modeline-field :hemlock-literal)
450 (modeline-field :package)
451 (modeline-field :modes)
452 (modeline-field :modifiedp)
453 (modeline-field :buffer-name)
454 (modeline-field :buffer-pathname))
455 "This is the default value for \"Default Modeline Fields\".")
456
457
458
459 ;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes,
460 ;;; name changes, etc.), so it takes some arguments to ignore. These hooks are
461 ;;; invoked at a bad time to update the actual modeline-field, and user's may
462 ;;; have fields that change as a function of the changes this function handles.
463 ;;; This makes his update easier. It doesn't cost much update the entire line
464 ;;; anyway.
465 ;;;
466 (defun queue-buffer-change (buffer &optional something-else another-else)
467 (declare (ignore something-else another-else))
468 (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*))
469
470 (defun update-modelines-for-buffer (buffer)
471 (unless (eq buffer *echo-area-buffer*)
472 (dolist (w (buffer-windows buffer))
473 (update-modeline-fields buffer w))))
474
475
476 ;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook". We ignore the
477 ;;; argument since this hook function is invoked before any changes are made,
478 ;;; and the changes must be made before the fields can be set according to the
479 ;;; window's buffer's properties. Therefore, we must queue the change to
480 ;;; happen sometime before redisplay but after the change takes effect.
481 ;;;
482 (defun queue-window-change (window &optional something-else)
483 (declare (ignore something-else))
484 (push (list #'update-modeline-for-window window) *things-to-do-once*))
485
486 (defun update-modeline-for-window (window)
487 (update-modeline-fields (window-buffer window) window))
488
489
490
491 ;;;; Bitmap setting up new windows and modifying old.
492
493 (defvar dummy-line (make-window-dis-line "")
494 "Dummy dis-line that we put at the head of window's dis-lines")
495 (setf (dis-line-position dummy-line) -1)
496
497
498 ;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks
499 ;;; to display starting at start.
500 ;;;
501 (defun window-for-hunk (hunk start modelinep)
502 (check-type start mark)
503 (setf (bitmap-hunk-changed-handler hunk) #'window-changed)
504 (let ((buffer (line-buffer (mark-line start)))
505 (first (cons dummy-line the-sentinel))
506 (width (bitmap-hunk-char-width hunk))
507 (height (bitmap-hunk-char-height hunk)))
508 (when (or (< height minimum-window-lines)
509 (< width minimum-window-columns))
510 (error "Window too small."))
511 (unless buffer (error "Window start is not in a buffer."))
512 (let ((window
513 (internal-make-window
514 :hunk hunk
515 :display-start (copy-mark start :right-inserting)
516 :old-start (copy-mark start :temporary)
517 :display-end (copy-mark start :right-inserting)
518 :%buffer buffer
519 :point (copy-mark (buffer-point buffer))
520 :height height
521 :width width
522 :first-line first
523 :last-line the-sentinel
524 :first-changed the-sentinel
525 :last-changed first
526 :tick -1)))
527 (push window *window-list*)
528 (push window (buffer-windows buffer))
529 ;;
530 ;; Make the dis-lines.
531 (do ((i (- height) (1+ i))
532 (res ()
533 (cons (make-window-dis-line (make-string width)) res)))
534 ((= i height) (setf (window-spare-lines window) res)))
535 ;;
536 ;; Make the image up to date.
537 (update-window-image window)
538 (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
539 ;;
540 ;; If there is a modeline, set it up.
541 (when modelinep
542 (setup-modeline-image buffer window)
543 (setf (bitmap-hunk-modeline-dis-line hunk)
544 (window-modeline-dis-line window)))
545 window)))
546
547 ;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the
548 ;;; modeline-fields list. This is used by tty redisplay too.
549 ;;;
550 (defun setup-modeline-image (buffer window)
551 (setf (window-modeline-buffer window) (make-string hunk-width-limit))
552 (setf (window-modeline-dis-line window)
553 (make-window-dis-line (make-string (window-width window))))
554 (update-modeline-fields buffer window))
555
556 ;;; Window-Changed -- Internal
557 ;;;
558 ;;; The bitmap-hunk changed handler for windows. This is only called if
559 ;;; the hunk is not locked. We invalidate the window image and change its
560 ;;; size, then do a full redisplay.
561 ;;;
562 (defun window-changed (hunk)
563 (let ((window (bitmap-hunk-window hunk)))
564 ;;
565 ;; Nuke all the lines in the window image.
566 (unless (eq (cdr (window-first-line window)) the-sentinel)
567 (shiftf (cdr (window-last-line window))
568 (window-spare-lines window)
569 (cdr (window-first-line window))
570 the-sentinel))
571 (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
572 ;;
573 ;; Add some new spare lines if needed. If width is greater,
574 ;; reallocate the dis-line-chars.
575 (let* ((res (window-spare-lines window))
576 (new-width (bitmap-hunk-char-width hunk))
577 (new-height (bitmap-hunk-char-height hunk))
578 (width (length (the simple-string (dis-line-chars (car res))))))
579 (declare (list res))
580 (when (> new-width width)
581 (setq width new-width)
582 (dolist (dl res)
583 (setf (dis-line-chars dl) (make-string new-width))))
584 (setf (window-height window) new-height (window-width window) new-width)
585 (do ((i (- (* new-height 2) (length res)) (1- i)))
586 ((minusp i))
587 (push (make-window-dis-line (make-string width)) res))
588 (setf (window-spare-lines window) res)
589 ;;
590 ;; Force modeline update.
591 (let ((ml-buffer (window-modeline-buffer window)))
592 (when ml-buffer
593 (let ((dl (window-modeline-dis-line window))
594 (chars (make-string new-width))
595 (len (min new-width (window-modeline-buffer-len window))))
596 (setf (dis-line-old-chars dl) nil)
597 (setf (dis-line-chars dl) chars)
598 (replace chars ml-buffer :end1 len :end2 len)
599 (setf (dis-line-length dl) len)
600 (setf (dis-line-flags dl) changed-bit)))))
601 ;;
602 ;; Prepare for redisplay.
603 (setf (window-tick window) (tick))
604 (update-window-image window)
605 (when (eq window *current-window*) (maybe-recenter-window window))
606 hunk))
607
608
609
610 ;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the
611 ;;; system.
612 ;;;
613 (defun editor-finish-output (window)
614 (let* ((device (device-hunk-device (window-hunk window)))
615 (finish-output (device-finish-output device)))
616 (when finish-output
617 (funcall finish-output device window))))
618
619
620
621 ;;;; Tty setting up new windows and modifying old.
622
623 ;;; setup-window-image -- Internal
624 ;;;
625 ;;; Set up the dis-lines and marks for Window to display starting
626 ;;; at Start. Height and Width are the number of lines and columns in
627 ;;; the window.
628 ;;;
629 (defun setup-window-image (start window height width)
630 (check-type start mark)
631 (let ((buffer (line-buffer (mark-line start)))
632 (first (cons dummy-line the-sentinel)))
633 (unless buffer (error "Window start is not in a buffer."))
634 (setf (window-display-start window) (copy-mark start :right-inserting)
635 (window-old-start window) (copy-mark start :temporary)
636 (window-display-end window) (copy-mark start :right-inserting)
637 (window-%buffer window) buffer
638 (window-point window) (copy-mark (buffer-point buffer))
639 (window-height window) height
640 (window-width window) width
641 (window-first-line window) first
642 (window-last-line window) the-sentinel
643 (window-first-changed window) the-sentinel
644 (window-last-changed window) first
645 (window-tick window) -1)
646 (push window *window-list*)
647 (push window (buffer-windows buffer))
648 ;;
649 ;; Make the dis-lines.
650 (do ((i (- height) (1+ i))
651 (res ()
652 (cons (make-window-dis-line (make-string width)) res)))
653 ((= i height) (setf (window-spare-lines window) res)))
654 ;;
655 ;; Make the image up to date.
656 (update-window-image window)))
657
658 ;;; change-window-image-height -- Internal
659 ;;;
660 ;;; Milkshake.
661 ;;;
662 (defun change-window-image-height (window new-height)
663 ;; Nuke all the lines in the window image.
664 (unless (eq (cdr (window-first-line window)) the-sentinel)
665 (shiftf (cdr (window-last-line window))
666 (window-spare-lines window)
667 (cdr (window-first-line window))
668 the-sentinel))
669 ;; Add some new spare lines if needed.
670 (let* ((res (window-spare-lines window))
671 (width (length (the simple-string (dis-line-chars (car res))))))
672 (declare (list res))
673 (setf (window-height window) new-height)
674 (do ((i (- (* new-height 2) (length res)) (1- i)))
675 ((minusp i))
676 (push (make-window-dis-line (make-string width)) res))
677 (setf (window-spare-lines window) res)))

  ViewVC Help
Powered by ViewVC 1.1.5