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

Contents of /src/hemlock/window.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Tue Mar 13 15:50:01 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +5 -5 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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 pw 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/window.lisp,v 1.5 2001/03/13 15:50:01 pw Rel $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
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 pw 1.5 (declaim (inline current-window))
34 ram 1.1
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 pw 1.5 (declaim (inline modeline-field-name modeline-field-width
155     modeline-field-function))
156 ram 1.1
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 pw 1.5 (declaim (special *buffer-list*))
175 ram 1.1
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 chiles 1.3 (check-type function (or symbol function))
195 ram 1.1 (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