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

Contents of /src/hemlock/linimage.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Jun 19 13:27:30 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.4: +10 -4 lines
Change all references to char-code-limit to 256 when compiling on a
Unicode build.  This allows Hemlock to load and run but does not work
correctly with a Unicode build.  The display is wrong, among other
things.
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/linimage.lisp,v 1.5 2009/06/19 13:27:30 rtoy Rel $")
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 #-unicode char-code-limit #+unicode 256
65 :element-type '(mod 256)
66 :initial-element winning-char)
67 "This is a character set used by redisplay to find funny chars.")
68 (defvar *print-representation-vector* nil
69 "Redisplay's handle on the :print-representation attribute")
70
71 ;;; Do a find-character-with-attribute on the *losing-character-mask*.
72 (defmacro %fcwa (str start end mask)
73 `(%sp-find-character-with-attribute
74 ,str ,start ,end *losing-character-mask* ,mask))
75
76 ;;; Get the print-representation of a character.
77 (defmacro get-rep (ch)
78 `(svref *print-representation-vector* (char-code ,ch)))
79
80
81
82 (declaim (special *character-attributes*))
83
84 ;;; %init-line-image -- Internal
85 ;;;
86 ;;; Set up the print-representations for funny chars. We make the
87 ;;; attribute vector by hand and do funny stuff so that chars > 127
88 ;;; will have a losing print-representation, so redisplay will not
89 ;;; die if you visit a binary file or do something stupid like that.
90 ;;;
91 (defun %init-line-image ()
92 (defattribute "Print Representation"
93 "The value of this attribute determines how a character is displayed
94 on the screen. If the value is a string this string is literally
95 displayed. If it is a function, then that function is called with
96 the current X position to get the string to display.")
97
98 ;; @@FIXME: Hack to let hemlock work on a unicode build. We don't
99 ;; try to make a print-presentation-vector handle the entire unicode
100 ;; space, just the basic 256 characters. I (rtoy) suspect hemlock
101 ;; wouldn't work very well with unicode strings anyway
102 (setq *print-representation-vector*
103 (make-array #-unicode char-code-limit #+unicode 256 :initial-element nil))
104 (setf (attribute-descriptor-vector
105 (gethash :print-representation *character-attributes*))
106 *print-representation-vector*)
107 (do ((code 128 (1+ code))
108 (str (make-string 4) (make-string 4)))
109 ((= code #-unicode char-code-limit #+unicode 256))
110 (setf (aref *losing-character-mask* code) losing-char)
111 (setf (aref *print-representation-vector* code) str)
112 (setf (schar str 0) #\<)
113 (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
114 (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
115 (setf (schar str 3) #\>))
116
117 (add-hook ed::character-attribute-hook
118 #'redis-set-char-attribute-hook-fun)
119 (do ((i (1- (char-code #\space)) (1- i)) str)
120 ((minusp i))
121 (setq str (make-string 2))
122 (setf (elt (the simple-string str) 0) #\^)
123 (setf (elt (the simple-string str) 1)
124 (code-char (+ i (char-code #\@))))
125 (setf (character-attribute :print-representation (code-char i)) str))
126 (setf (character-attribute :print-representation (code-char #o177)) "^?")
127 (setf (character-attribute :print-representation #\tab)
128 #'redis-tab-display-fun))
129
130 ;;; redis-set-char-attribute-hook-fun
131 ;;;
132 ;;; Keep track of which characters have funny representations.
133 ;;;
134 (defun redis-set-char-attribute-hook-fun (attribute char new-value)
135 (when (eq attribute :print-representation)
136 (cond
137 ((simple-string-p new-value)
138 (if (and (= (length (the simple-string new-value)) 1)
139 (char= char (elt (the simple-string new-value) 0)))
140 (setf (aref *losing-character-mask* (char-code char)) winning-char)
141 (setf (aref *losing-character-mask* (char-code char))
142 losing-char)))
143 ((functionp new-value)
144 (setf (aref *losing-character-mask* (char-code char)) losing-char))
145 (t (error "Bad print representation: ~S" new-value)))))
146
147 ;;; redis-tab-display-fun
148 ;;;
149 ;;; This function is initially the :print-representation for tab.
150 ;;;
151 (defun redis-tab-display-fun (xpos)
152 (svref '#(" "
153 " "
154 " "
155 " "
156 " "
157 " "
158 " "
159 " ")
160 (logand xpos 7)))
161
162
163 ;;;; The actual line image computing functions.
164 ;;;;
165
166 (eval-when (compile eval)
167 ;;; display-some-chars -- internal
168 ;;;
169 ;;; Put some characters into a window. Characters from src-start
170 ;;; to src-end in src are are put in the window's dis-line's. Lines
171 ;;; are wrapped as necessary. dst is the dis-line-chars of the dis-line
172 ;;; currently being written. Dis-lines is the window's vector of dis-lines.
173 ;;; dis-line is the dis-line currently being written. Line is the index
174 ;;; into dis-lines of the current dis-line. dst-start is the index to
175 ;;; start writing chars at. Height and width are the height and width of the
176 ;;; window. src-start, dst, dst-start, line and dis-line are updated.
177 ;;; Done-P indicates whether there are more characters after this sequence.
178 ;;;
179 (defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
180 `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
181 (declare (fixnum dst-end))
182 (cond
183 ((>= dst-end ,width)
184 (cond
185 ((and ,done-p (= dst-end ,width))
186 (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
187 (setq ,dst-start dst-end ,src-start ,src-end))
188 (t
189 (let ((1-width (1- ,width)))
190 (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
191 (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
192 (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
193 (setq ,dst-start nil)))))
194 (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
195 (setq ,dst-start dst-end ,src-start ,src-end)))))
196
197 ;;; These macros are given as args to display-losing-chars to get the
198 ;;; print representation of whatever is in the data vector.
199 (defmacro string-get-rep (string index)
200 `(get-rep (schar ,string ,index)))
201
202 (defmacro u-vec-get-rep (u-vec index)
203 `(svref *print-representation-vector*
204 (system:sap-ref-8 ,u-vec ,index)))
205
206 ;;; display-losing-chars -- Internal
207 ;;;
208 ;;; This macro is called by the compute-line-image functions to
209 ;;; display a group of losing characters.
210 ;;;
211 (defmacro display-losing-chars (line-chars index end dest xpos width
212 string underhang access-fun
213 &optional (done-p `(= ,index ,end)))
214 `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
215 (len 0)
216 (zero 0)
217 str)
218 (())
219 (declare (fixnum last len zero))
220 (setq str (,access-fun ,line-chars ,index))
221 (unless (simple-string-p str) (setq str (funcall str ,xpos)))
222 (setq len (strlen str) zero 0)
223 (incf ,index)
224 (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
225 (cond ((not ,xpos)
226 ;; We wrapped in the middle of a losing char.
227 (setq ,underhang zero ,string str)
228 (return nil))
229 ((= ,index last)
230 ;; No more losing chars in this bunch.
231 (return nil)))))
232
233 (defmacro update-and-punt (dis-line length string underhang end)
234 `(progn (setf (dis-line-length ,dis-line) ,length)
235 (return (values ,string ,underhang
236 (setf (dis-line-end ,dis-line) ,end)))))
237
238 ); eval-when (compile eval)
239
240 ;;; compute-normal-line-image -- Internal
241 ;;;
242 ;;; Compute the screen representation of Line starting at Start
243 ;;; putting it in Dis-Line beginning at Xpos. Width is the width of the
244 ;;; window we are displaying in. If the line will wrap then we display
245 ;;; as many chars as we can then put in *line-wrap-char*. The values
246 ;;; returned are described in Compute-Line-Image, which tail-recursively
247 ;;; returns them. The length slot in Dis-Line is updated.
248 ;;;
249 ;;; We use the *losing-character-mask* to break the line to be displayed
250 ;;; up into chunks of characters with normal print representation and
251 ;;; those with funny representations.
252 ;;;
253 (defun compute-normal-line-image (line start dis-line xpos width)
254 (declare (fixnum start width) (type (or fixnum null) xpos))
255 (do* ((index start)
256 (line-chars (line-%chars line))
257 (end (strlen line-chars))
258 (dest (dis-line-chars dis-line))
259 (losing 0)
260 underhang string)
261 (())
262 (declare (fixnum index end)
263 (type (or fixnum null) losing)
264 (simple-string line-chars dest))
265 (cond
266 (underhang
267 (update-and-punt dis-line width string underhang index))
268 ((null xpos)
269 (update-and-punt dis-line width nil 0 index))
270 ((= index end)
271 (update-and-punt dis-line xpos nil nil index)))
272 (setq losing (%fcwa line-chars index end losing-char))
273 (when (null losing)
274 (display-some-chars line-chars index end dest xpos width t)
275 (if (or xpos (= index end))
276 (update-and-punt dis-line xpos nil nil index)
277 (update-and-punt dis-line width nil 0 index)))
278 (display-some-chars line-chars index losing dest xpos width nil)
279 (cond
280 ;; Did we wrap?
281 ((null xpos)
282 (update-and-punt dis-line width nil 0 index))
283 ;; Are we about to cause the line to wrap? If so, wrap before
284 ;; it's too late.
285 ((= xpos width)
286 (setf (char dest (1- width)) *line-wrap-char*)
287 (update-and-punt dis-line width nil 0 index))
288 (t
289 (display-losing-chars line-chars index end dest xpos width string
290 underhang string-get-rep)))))
291
292 ;;; compute-buffered-line-image -- Internal
293 ;;;
294 ;;; Compute the line image for a "Buffered" line, that is, one whose
295 ;;; chars have not been consed yet.
296
297 (defun compute-buffered-line-image (line start dis-line xpos width)
298 (declare (fixnum start width) (type (or fixnum null) xpos))
299 (do* ((index start)
300 (line-chars (line-%chars line))
301 (end (line-buffered-p line))
302 (dest (dis-line-chars dis-line))
303 (losing 0)
304 underhang string)
305 (())
306 (declare (fixnum index end)
307 (type (or fixnum null) losing)
308 (simple-string dest))
309 (cond
310 (underhang
311 (update-and-punt dis-line width string underhang index))
312 ((null xpos)
313 (update-and-punt dis-line width nil 0 index))
314 ((= index end)
315 (update-and-punt dis-line xpos nil nil index)))
316 (setq losing (%fcwa line-chars index end losing-char))
317 (when (null losing)
318 (display-some-chars line-chars index end dest xpos width t)
319 (if (or xpos (= index end))
320 (update-and-punt dis-line xpos nil nil index)
321 (update-and-punt dis-line width nil 0 index)))
322 (display-some-chars line-chars index losing dest xpos width nil)
323 (cond
324 ;; Did we wrap?
325 ((null xpos)
326 (update-and-punt dis-line width nil 0 index))
327 ;; Are we about to cause the line to wrap? If so, wrap before
328 ;; it's too late.
329 ((= xpos width)
330 (setf (char dest (1- width)) *line-wrap-char*)
331 (update-and-punt dis-line width nil 0 index))
332 (t
333 (display-losing-chars line-chars index end dest xpos width string
334 underhang u-vec-get-rep)))))
335
336 ;;; compute-cached-line-image -- Internal
337 ;;;
338 ;;; Like compute-normal-line-image, only works on the cached line.
339 ;;;
340 (defun compute-cached-line-image (index dis-line xpos width)
341 (declare (fixnum index width) (type (or fixnum null) xpos))
342 (prog ((gap (- right-open-pos left-open-pos))
343 (dest (dis-line-chars dis-line))
344 (done-p (= right-open-pos line-cache-length))
345 (losing 0)
346 string underhang)
347 (declare (fixnum gap) (simple-string dest)
348 (type (or fixnum null) losing))
349 LEFT-LOOP
350 (cond
351 (underhang
352 (update-and-punt dis-line width string underhang index))
353 ((null xpos)
354 (update-and-punt dis-line width nil 0 index))
355 ((>= index left-open-pos)
356 (go RIGHT-START)))
357 (setq losing (%fcwa open-chars index left-open-pos losing-char))
358 (cond
359 (losing
360 (display-some-chars open-chars index losing dest xpos width nil)
361 ;; If we we didn't wrap then display some losers...
362 (if xpos
363 (display-losing-chars open-chars index left-open-pos dest xpos
364 width string underhang string-get-rep
365 (and done-p (= index left-open-pos)))
366 (update-and-punt dis-line width nil 0 index)))
367 (t
368 (display-some-chars open-chars index left-open-pos dest xpos width done-p)))
369 (go LEFT-LOOP)
370
371 RIGHT-START
372 (setq index (+ index gap))
373 RIGHT-LOOP
374 (cond
375 (underhang
376 (update-and-punt dis-line width string underhang (- index gap)))
377 ((null xpos)
378 (update-and-punt dis-line width nil 0 (- index gap)))
379 ((= index line-cache-length)
380 (update-and-punt dis-line xpos nil nil (- index gap))))
381 (setq losing (%fcwa open-chars index line-cache-length losing-char))
382 (cond
383 (losing
384 (display-some-chars open-chars index losing dest xpos width nil)
385 (cond
386 ;; Did we wrap?
387 ((null xpos)
388 (update-and-punt dis-line width nil 0 (- index gap)))
389 (t
390 (display-losing-chars open-chars index line-cache-length dest xpos
391 width string underhang string-get-rep))))
392 (t
393 (display-some-chars open-chars index line-cache-length dest xpos width t)))
394 (go RIGHT-LOOP)))
395
396 (defun make-some-font-changes ()
397 (do ((res nil (make-font-change res))
398 (i 42 (1- i)))
399 ((zerop i) res)))
400
401 (defvar *free-font-changes* (make-some-font-changes)
402 "Font-Change structures that nobody's using at the moment.")
403
404 (defmacro alloc-font-change (x font mark)
405 `(progn
406 (unless *free-font-changes*
407 (setq *free-font-changes* (make-some-font-changes)))
408 (let ((new-fc *free-font-changes*))
409 (setq *free-font-changes* (font-change-next new-fc))
410 (setf (font-change-x new-fc) ,x
411 (font-change-font new-fc) ,font
412 (font-change-next new-fc) nil
413 (font-change-mark new-fc) ,mark)
414 new-fc)))
415
416 ;;;
417 ;;; compute-line-image -- Internal
418 ;;;
419 ;;; This function builds a full line image from some characters in
420 ;;; a line and from some characters which may be left over from the previous
421 ;;; line.
422 ;;;
423 ;;; Parameters:
424 ;;; String - This is the string which contains the characters left over
425 ;;; from the previous line. This is NIL if there are none.
426 ;;; Underhang - Characters from here to the end of String are put at the
427 ;;; beginning of the line image.
428 ;;; Line - This is the line to display characters from.
429 ;;; Offset - This is the index of the first character to display in Line.
430 ;;; Dis-Line - This is the dis-line to put the line-image in. The only
431 ;;; slots affected are the chars and the length.
432 ;;; Width - This is the width of the field to display in.
433 ;;;
434 ;;; Three values are returned:
435 ;;; 1) The new overhang string, if none this is NIL.
436 ;;; 2) The new underhang, if this is NIL then the entire line was
437 ;;; displayed. If the entire line was not displayed, but there was no
438 ;;; underhang, then this is 0.
439 ;;; 3) The index in line after the last character displayed.
440 ;;;
441 (defun compute-line-image (string underhang line offset dis-line width)
442 ;;
443 ;; Release any old font-changes.
444 (let ((changes (dis-line-font-changes dis-line)))
445 (when changes
446 (do ((prev changes current)
447 (current (font-change-next changes)
448 (font-change-next current)))
449 ((null current)
450 (setf (dis-line-font-changes dis-line) nil)
451 (shiftf (font-change-next prev) *free-font-changes* changes))
452 (setf (font-change-mark current) nil))))
453 ;;
454 ;; If the line has any Font-Marks, add Font-Changes for them.
455 (let ((marks (line-marks line)))
456 (when (dolist (m marks nil)
457 (when (fast-font-mark-p m) (return t)))
458 (let ((prev nil))
459 ;;
460 ;; Find the last Font-Mark with charpos less than Offset. If there is
461 ;; such a Font-Mark, then there is a font-change to this font at X = 0.
462 (let ((max -1)
463 (max-mark nil))
464 (dolist (m marks)
465 (when (fast-font-mark-p m)
466 (let ((charpos (mark-charpos m)))
467 (when (and (< charpos offset) (> charpos max))
468 (setq max charpos max-mark m)))))
469 (when max-mark
470 (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
471 (setf (dis-line-font-changes dis-line) prev)))
472 ;;
473 ;; Repeatedly scan through marks, adding a font-change for the
474 ;; smallest Font-Mark with a charpos greater than Bound, until
475 ;; we find no such mark.
476 (do ((bound (1- offset) min)
477 (min most-positive-fixnum most-positive-fixnum)
478 (min-mark nil nil))
479 (())
480 (dolist (m marks)
481 (when (fast-font-mark-p m)
482 (let ((charpos (mark-charpos m)))
483 (when (and (> charpos bound) (< charpos min))
484 (setq min charpos min-mark m)))))
485 (unless min-mark (return nil))
486 (let ((len (if (eq line open-line)
487 (cached-real-line-length line 10000 offset min)
488 (real-line-length line 10000 offset min))))
489 (when (< len width)
490 (let ((new (alloc-font-change
491 (+ len
492 (if string
493 (- (length (the simple-string string)) underhang)
494 0))
495 (font-mark-font min-mark)
496 min-mark)))
497 (if prev
498 (setf (font-change-next prev) new)
499 (setf (dis-line-font-changes dis-line) new))
500 (setq prev new))))))))
501 ;;
502 ;; Recompute the line image.
503 (cond
504 (string
505 (let ((len (strlen string))
506 (chars (dis-line-chars dis-line))
507 (xpos 0))
508 (declare (type (or fixnum null) xpos) (simple-string chars))
509 (display-some-chars string underhang len chars xpos width nil)
510 (cond
511 ((null xpos)
512 (values string underhang offset))
513 ((eq line open-line)
514 (compute-cached-line-image offset dis-line xpos width))
515 #+Buffered-Lines
516 ((line-buffered-p line)
517 (compute-buffered-line-image line offset dis-line xpos width))
518 (t
519 (compute-normal-line-image line offset dis-line xpos width)))))
520 ((eq line open-line)
521 (compute-cached-line-image offset dis-line 0 width))
522 #+Buffered-Lines
523 ((line-buffered-p line)
524 (compute-buffered-line-image line offset dis-line 0 width))
525 (t
526 (compute-normal-line-image line offset dis-line 0 width))))

  ViewVC Help
Powered by ViewVC 1.1.5