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