source: trunk/ccl/hemlock/src/linimage.lisp @ 60

Last change on this file since 60 was 60, checked in by gb, 16 years ago

More changes/fixes: line-buffered-p stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.5 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;;;    Written by Rob MacLachlan
13;;;
14;;; This file contains functions related to building line images.
15;;;
16(in-package :hemlock-internals)
17
18;;;    The code in here is factored out in this way because it is more
19;;; or less implementation dependant.  The reason this code is
20;;; implementation dependant is not because it is not written in
21;;; Common Lisp per se, but because it uses this thing called
22;;; %SP-Find-Character-With-Attribute to find any characters that
23;;; are to be displayed on the line which do not print as themselves.
24;;; This permits us to have an arbitrary string or even string-valued
25;;; function to as the representation for such a "Funny" character
26;;; with minimal penalty for the normal case.  This function can be written
27;;; in lisp, and is included commented-out below, but if this function
28;;; is not real fast then redisplay performance will suffer.
29;;;
30;;;    Theres also code in here that special-cases "Buffered" lines,
31;;; which is not exactly Common Lisp, but if you aren't on a perq,
32;;; you won't have to worry about it.
33;;;
34;(defun %sp-find-character-with-attribute (string start end table mask)
35;  (declare (type (simple-array (mod 256) char-code-max) table))
36;  (declare (simple-string string))
37;  (declare (fixnum start end))
38;  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
39;  The codes of the characters of String from Start to End are used as indices
40;  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
41;  up from the table bitwise ANDed with Mask is non-zero, the current
42;  index into the String is returned. The corresponds to SCANC on the Vax."
43;  (do ((index start (1+ index)))
44;      ((= index end) nil)
45;    (declare (fixnum index))
46;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
47;       (return index))))
48;
49;(defun %sp-reverse-find-character-with-attribute (string start end table
50;                                                         mask)
51;  (declare (type (simple-array (mod 256) char-code-max) table))
52;  (declare (simple-string string))
53;  (declare (fixnum start end))
54;  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
55;  (do ((index (1- end) (1- index)))
56;      ((< index start) nil)
57;    (declare (fixnum index))
58;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
59;       (return index))))
60
61(defconstant winning-char #b01 "Bit for a char that prints normally")
62(defconstant losing-char #b10 "Bit for char with funny representation.")
63(defvar *losing-character-mask*
64  (make-array char-code-limit :element-type '(mod 256)
65              :initial-element winning-char)
66  "This is a character set used by redisplay to find funny chars.")
67(defvar *print-representation-vector* nil
68  "Redisplay's handle on the :print-representation attribute")
69
70;;;  Do a find-character-with-attribute on the *losing-character-mask*.
71(defmacro %fcwa (str start end mask)
72  `(%sp-find-character-with-attribute
73    ,str ,start ,end *losing-character-mask* ,mask))
74
75;;; Get the print-representation of a character.
76(defmacro get-rep (ch)
77  `(svref *print-representation-vector* (char-code ,ch)))
78
79
80
81(declaim (special *character-attributes*))
82
83;;; %init-line-image  --  Internal
84;;;
85;;;    Set up the print-representations for funny chars.  We make the
86;;; attribute vector by hand and do funny stuff so that chars > 127
87;;; will have a losing print-representation, so redisplay will not
88;;; die if you visit a binary file or do something stupid like that.
89;;;
90(defun %init-line-image ()
91  (defattribute "Print Representation"
92    "The value of this attribute determines how a character is displayed
93    on the screen.  If the value is a string this string is literally
94    displayed.  If it is a function, then that function is called with
95    the current X position to get the string to display.")
96  (setq *print-representation-vector*
97        (make-array char-code-limit :initial-element nil))
98  (setf (attribute-descriptor-vector
99         (gethash :print-representation *character-attributes*))
100        *print-representation-vector*)
101  (do ((code 128 (1+ code))
102       (str (make-string 4) (make-string 4)))
103      ((= code char-code-limit))
104    (setf (aref *losing-character-mask* code) losing-char)
105    (setf (aref *print-representation-vector* code) str)
106    (setf (schar str 0) #\<)
107    (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
108    (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
109    (setf (schar str 3) #\>))
110
111  (add-hook hemlock::character-attribute-hook
112            #'redis-set-char-attribute-hook-fun)
113  (do ((i (1- (char-code #\space)) (1- i)) str)
114      ((minusp i))
115    (setq str (make-string 2))
116    (setf (elt (the simple-string str) 0) #\^)
117    (setf (elt (the simple-string str) 1)
118          (code-char (+ i (char-code #\@))))
119    (setf (character-attribute :print-representation (code-char i)) str))
120  (setf (character-attribute :print-representation (code-char #o177)) "^?")
121  (setf (character-attribute :print-representation #\tab)
122        #'redis-tab-display-fun))
123
124;;; redis-set-char-attribute-hook-fun
125;;;
126;;;    Keep track of which characters have funny representations.
127;;;
128(defun redis-set-char-attribute-hook-fun (attribute char new-value)
129  (when (eq attribute :print-representation)
130    (cond
131     ((simple-string-p new-value)
132      (if (and (= (length (the simple-string new-value)) 1)
133               (char= char (elt (the simple-string new-value) 0)))
134          (setf (aref *losing-character-mask* (char-code char)) winning-char)
135          (setf (aref *losing-character-mask* (char-code char))
136                losing-char)))
137     ((functionp new-value)
138      (setf (aref *losing-character-mask* (char-code char)) losing-char))
139     (t (error "Bad print representation: ~S" new-value)))))
140
141;;; redis-tab-display-fun
142;;;
143;;;    This function is initially the :print-representation for tab.
144;;;
145(defun redis-tab-display-fun (xpos)
146  (svref '#("        "
147            "       "
148            "      "
149            "     "
150            "    "
151            "   "
152            "  "
153            " ")
154         (logand xpos 7)))
155
156
157;;;; The actual line image computing functions.
158;;;;
159
160(eval-when (:compile-toplevel :execute)
161;;; display-some-chars  --  internal
162;;;
163;;;    Put some characters into a window.  Characters from src-start
164;;; to src-end in src are are put in the window's dis-line's.  Lines
165;;; are wrapped as necessary.  dst is the dis-line-chars of the dis-line
166;;; currently being written.  Dis-lines is the window's vector of dis-lines.
167;;; dis-line is the dis-line currently being written.  Line is the index
168;;; into dis-lines of the current dis-line.  dst-start is the index to
169;;; start writing chars at.  Height and width are the height and width of the
170;;; window.  src-start, dst, dst-start, line and dis-line are updated.
171;;; Done-P indicates whether there are more characters after this sequence.
172;;;
173(defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
174  `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
175     (declare (fixnum dst-end))
176     (cond
177      ((>= dst-end ,width)
178       (cond 
179        ((and ,done-p (= dst-end ,width))
180         (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
181         (setq ,dst-start dst-end  ,src-start ,src-end))
182        (t
183         (let ((1-width (1- ,width)))
184           (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
185           (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
186           (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
187           (setq ,dst-start nil)))))
188      (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
189         (setq ,dst-start dst-end  ,src-start ,src-end)))))
190
191;;; These macros are given as args to display-losing-chars to get the
192;;; print representation of whatever is in the data vector.
193(defmacro string-get-rep (string index)
194  `(get-rep (schar ,string ,index)))
195
196(defmacro u-vec-get-rep (u-vec index)
197  `(svref *print-representation-vector*
198          (hemlock-ext:sap-ref-8 ,u-vec ,index)))
199
200;;; display-losing-chars  --  Internal
201;;;
202;;;    This macro is called by the compute-line-image functions to
203;;; display a group of losing characters.
204;;;
205(defmacro display-losing-chars (line-chars index end dest xpos width
206                                           string underhang access-fun
207                                           &optional (done-p `(= ,index ,end)))
208  `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
209        (len 0)
210        (zero 0)
211        str)
212       (())
213     (declare (fixnum last len zero))
214     (setq str (,access-fun ,line-chars ,index))
215     (unless (simple-string-p str) (setq str (funcall str ,xpos)))
216     (setq len (strlen str)  zero 0)
217     (incf ,index)
218     (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
219     (cond ((not ,xpos)
220            ;; We wrapped in the middle of a losing char.             
221            (setq ,underhang zero  ,string str)
222            (return nil))
223           ((= ,index last)
224            ;; No more losing chars in this bunch.
225            (return nil)))))
226
227(defmacro update-and-punt (dis-line length string underhang end)
228  `(progn (setf (dis-line-length ,dis-line) ,length)
229          (return (values ,string ,underhang
230                          (setf (dis-line-end ,dis-line) ,end)))))
231
232); eval-when
233
234;;; compute-normal-line-image  --  Internal
235;;;
236;;;    Compute the screen representation of Line starting at Start
237;;; putting it in Dis-Line beginning at Xpos.  Width is the width of the
238;;; window we are displaying in.  If the line will wrap then we display
239;;; as many chars as we can then put in *line-wrap-char*.  The values
240;;; returned are described in Compute-Line-Image, which tail-recursively
241;;; returns them.  The length slot in Dis-Line is updated.
242;;;
243;;; We use the *losing-character-mask* to break the line to be displayed
244;;; up into chunks of characters with normal print representation and
245;;; those with funny representations.
246;;;
247(defun compute-normal-line-image (line start dis-line xpos width)
248  (declare (fixnum start width) (type (or fixnum null) xpos))
249  (do* ((index start)
250        (line-chars (line-%chars line))
251        (end (strlen line-chars))
252        (dest (dis-line-chars dis-line))
253        (losing 0)
254        underhang string)
255       (())
256    (declare (fixnum index end)
257             (type (or fixnum null) losing)
258             (simple-string line-chars dest))
259    (cond
260     (underhang
261      (update-and-punt dis-line width string underhang index))
262     ((null xpos)
263      (update-and-punt dis-line width nil 0 index))
264     ((= index end)
265      (update-and-punt dis-line xpos nil nil index)))
266    (setq losing (%fcwa line-chars index end losing-char))
267    (when (null losing)
268      (display-some-chars line-chars index end dest xpos width t)
269      (if (or xpos (= index end))
270          (update-and-punt dis-line xpos nil nil index)
271          (update-and-punt dis-line width nil 0 index)))
272    (display-some-chars line-chars index losing dest xpos width nil)
273    (cond
274     ;; Did we wrap?
275     ((null xpos)
276      (update-and-punt dis-line width nil 0 index))
277     ;; Are we about to cause the line to wrap? If so, wrap before
278     ;; it's too late.
279     ((= xpos width)
280      (setf (char dest (1- width)) *line-wrap-char*)
281      (update-and-punt dis-line width nil 0 index))
282     (t
283      (display-losing-chars line-chars index end dest xpos width string
284                            underhang string-get-rep)))))
285
286;;; compute-buffered-line-image  --  Internal
287;;;
288;;;    Compute the line image for a "Buffered" line, that is, one whose
289;;; chars have not been consed yet.
290
291(defun compute-buffered-line-image (line start dis-line xpos width)
292  (declare (fixnum start width) (type (or fixnum null) xpos))
293  (do* ((index start)
294        (line-chars (line-%chars line))
295        (end (line-buffered-p line))
296        (dest (dis-line-chars dis-line))
297        (losing 0)
298        underhang string)
299       (())
300    (declare (fixnum index end)
301             (type (or fixnum null) losing)
302             (simple-string dest))
303    (cond
304     (underhang
305      (update-and-punt dis-line width string underhang index))
306     ((null xpos)
307      (update-and-punt dis-line width nil 0 index))
308     ((= index end)
309      (update-and-punt dis-line xpos nil nil index)))
310    (setq losing (%fcwa line-chars index end losing-char))
311    (when (null losing)
312      (display-some-chars line-chars index end dest xpos width t)
313      (if (or xpos (= index end))
314          (update-and-punt dis-line xpos nil nil index)
315          (update-and-punt dis-line width nil 0 index)))
316    (display-some-chars line-chars index losing dest xpos width nil)
317    (cond
318     ;; Did we wrap?
319     ((null xpos)
320      (update-and-punt dis-line width nil 0 index))
321     ;; Are we about to cause the line to wrap? If so, wrap before
322     ;; it's too late.
323     ((= xpos width)
324      (setf (char dest (1- width)) *line-wrap-char*)
325      (update-and-punt dis-line width nil 0 index))
326     (t
327      (display-losing-chars line-chars index end dest xpos width string
328                            underhang u-vec-get-rep)))))
329
330;;; compute-cached-line-image  --  Internal
331;;;
332;;;    Like compute-normal-line-image, only works on the cached line.
333;;;
334(defun compute-cached-line-image (index dis-line xpos width)
335  (declare (fixnum index width) (type (or fixnum null) xpos))
336  (prog ((gap (- *right-open-pos* *left-open-pos*))
337         (dest (dis-line-chars dis-line))
338         (done-p (= *right-open-pos* *line-cache-length*))
339         (losing 0)
340         string underhang)
341    (declare (fixnum gap) (simple-string dest)
342             (type (or fixnum null) losing))
343   LEFT-LOOP
344    (cond
345     (underhang
346      (update-and-punt dis-line width string underhang index))
347     ((null xpos)
348      (update-and-punt dis-line width nil 0 index))
349     ((>= index *left-open-pos*)
350      (go RIGHT-START)))
351    (setq losing (%fcwa *open-chars* index *left-open-pos* losing-char))
352    (cond
353     (losing
354      (display-some-chars *open-chars* index losing dest xpos width nil)
355      ;; If we we didn't wrap then display some losers...
356      (if xpos
357          (display-losing-chars *open-chars* index *left-open-pos* dest xpos
358                                width string underhang string-get-rep
359                                (and done-p (= index *left-open-pos*)))
360          (update-and-punt dis-line width nil 0 index)))
361     (t
362      (display-some-chars *open-chars* index *left-open-pos* dest xpos width done-p)))
363    (go LEFT-LOOP)
364
365   RIGHT-START
366    (setq index (+ index gap))
367   RIGHT-LOOP
368    (cond
369     (underhang
370      (update-and-punt dis-line width string underhang (- index gap)))
371     ((null xpos)
372      (update-and-punt dis-line width nil 0 (- index gap)))
373     ((= index *line-cache-length*)
374      (update-and-punt dis-line xpos nil nil (- index gap))))
375    (setq losing (%fcwa *open-chars* index *line-cache-length* losing-char))
376    (cond
377     (losing
378      (display-some-chars *open-chars* index losing dest xpos width nil)
379      (cond
380       ;; Did we wrap?
381       ((null xpos)
382        (update-and-punt dis-line width nil 0 (- index gap)))
383       (t
384        (display-losing-chars *open-chars* index *line-cache-length* dest xpos
385                              width string underhang string-get-rep))))
386     (t
387      (display-some-chars *open-chars* index *line-cache-length* dest xpos width t)))
388    (go RIGHT-LOOP))) 
389
390(defun make-some-font-changes ()
391  (do ((res nil (make-font-change res))
392       (i 42 (1- i)))
393      ((zerop i) res)))
394
395(defvar *free-font-changes* (make-some-font-changes)
396  "Font-Change structures that nobody's using at the moment.")
397
398(defmacro alloc-font-change (x font mark)
399  `(progn
400    (unless *free-font-changes*
401      (setq *free-font-changes* (make-some-font-changes)))
402    (let ((new-fc *free-font-changes*))
403      (setq *free-font-changes* (font-change-next new-fc))
404      (setf (font-change-x new-fc) ,x
405            (font-change-font new-fc) ,font
406            (font-change-next new-fc) nil
407            (font-change-mark new-fc) ,mark)
408      new-fc)))
409                     
410;;;
411;;; compute-line-image  --  Internal
412;;;
413;;;    This function builds a full line image from some characters in
414;;; a line and from some characters which may be left over from the previous
415;;; line.
416;;;
417;;; Parameters:
418;;;    String - This is the string which contains the characters left over
419;;; from the previous line.  This is NIL if there are none.
420;;;    Underhang - Characters from here to the end of String are put at the
421;;; beginning of the line image.
422;;;    Line - This is the line to display characters from.
423;;;    Offset - This is the index of the first character to display in Line.
424;;;    Dis-Line - This is the dis-line to put the line-image in.  The only
425;;; slots affected are the chars and the length.
426;;;    Width - This is the width of the field to display in.
427;;;
428;;; Three values are returned:
429;;;    1) The new overhang string, if none this is NIL.
430;;;    2) The new underhang, if this is NIL then the entire line was
431;;; displayed.  If the entire line was not displayed, but there was no
432;;; underhang, then this is 0.
433;;;    3) The index in line after the last character displayed.
434;;;
435(defun compute-line-image (string underhang line offset dis-line width)
436  ;;
437  ;; Release any old font-changes.
438  (let ((changes (dis-line-font-changes dis-line)))
439    (when changes
440      (do ((prev changes current)
441           (current (font-change-next changes)
442                    (font-change-next current)))
443          ((null current)
444           (setf (dis-line-font-changes dis-line) nil)
445           (shiftf (font-change-next prev) *free-font-changes* changes))
446        (setf (font-change-mark current) nil))))
447  ;;
448  ;; If the line has any Font-Marks, add Font-Changes for them.
449  (let ((marks (line-marks line)))
450    (when (dolist (m marks nil)
451            (when (fast-font-mark-p m) (return t)))
452      (let ((prev nil))
453        ;;
454        ;; Find the last Font-Mark with charpos less than Offset.  If there is
455        ;; such a Font-Mark, then there is a font-change to this font at X = 0.
456        (let ((max -1)
457              (max-mark nil))
458          (dolist (m marks)
459            (when (fast-font-mark-p m)
460              (let ((charpos (mark-charpos m)))
461                (when (and (< charpos offset) (> charpos max))
462                  (setq max charpos  max-mark m)))))
463          (when max-mark
464            (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
465            (setf (dis-line-font-changes dis-line) prev)))
466        ;;
467        ;; Repeatedly scan through marks, adding a font-change for the
468        ;; smallest Font-Mark with a charpos greater than Bound, until
469        ;; we find no such mark.
470        (do ((bound (1- offset) min)
471             (min most-positive-fixnum most-positive-fixnum)
472             (min-mark nil nil))
473            (())
474          (dolist (m marks)
475            (when (fast-font-mark-p m)
476              (let ((charpos (mark-charpos m)))
477                (when (and (> charpos bound) (< charpos min))
478                  (setq min charpos  min-mark m)))))
479          (unless min-mark (return nil))
480          (let ((len (if (eq line *open-line*)
481                         (cached-real-line-length line 10000 offset min)
482                         (real-line-length line 10000 offset min))))
483            (when (< len width)
484              (let ((new (alloc-font-change
485                          (+ len
486                             (if string
487                                 (- (length (the simple-string string)) underhang)
488                                 0))
489                          (font-mark-font min-mark)
490                          min-mark)))
491                (if prev
492                    (setf (font-change-next prev) new)
493                    (setf (dis-line-font-changes dis-line) new))
494                (setq prev new))))))))
495  ;;
496  ;; Recompute the line image.
497  (cond
498   (string
499    (let ((len (strlen string))
500          (chars (dis-line-chars dis-line))
501          (xpos 0))
502      (declare (type (or fixnum null) xpos) (simple-string chars))
503      (display-some-chars string underhang len chars xpos width nil)
504      (cond
505       ((null xpos)
506        (values string underhang offset))         
507       ((eq line *open-line*)
508        (compute-cached-line-image offset dis-line xpos width))
509       ((line-buffered-p line)
510        (compute-buffered-line-image line offset dis-line xpos width))
511       (t
512        (compute-normal-line-image line offset dis-line xpos width)))))
513   ((eq line *open-line*)
514    (compute-cached-line-image offset dis-line 0 width))
515   ((line-buffered-p line)
516    (compute-buffered-line-image line offset dis-line 0 width))
517   (t
518    (compute-normal-line-image line offset dis-line 0 width))))
Note: See TracBrowser for help on using the repository browser.