/[slime]/slime/sbcl-pprint-patch.lisp
ViewVC logotype

Contents of /slime/sbcl-pprint-patch.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Fri Feb 17 01:30:21 2006 UTC (8 years, 1 month ago) by mkoeppe
Branch: MAIN
CVS Tags: SLIME-2-3, SLIME-2-2, SLIME-2-1, SLIME-2-0, SLIME-1-3, FAIRLY-STABLE, byte-stream, HEAD
Branch point for: fsm, contrib
New file, adds the annotations feature to the SBCL pretty printer.
This is needed for sending presentations through pretty-printing
streams.
1 ;; Pretty printer patch for SBCL, which adds the "annotations" feature
2 ;; required for sending presentations through pretty-printing streams.
3 ;;
4 ;; The section marked "Changed functions" and the DEFSTRUCT
5 ;; PRETTY-STREAM are based on SBCL's pprint.lisp.
6 ;;
7 ;; Public domain.
8
9 (in-package "SB!PRETTY")
10
11 (defstruct (annotation (:include queued-op))
12 (handler (constantly nil) :type function)
13 (record))
14
15
16 (defstruct (pretty-stream (:include sb!kernel:ansi-stream
17 (out #'pretty-out)
18 (sout #'pretty-sout)
19 (misc #'pretty-misc))
20 (:constructor make-pretty-stream (target))
21 (:copier nil))
22 ;; Where the output is going to finally go.
23 (target (missing-arg) :type stream)
24 ;; Line length we should format to. Cached here so we don't have to keep
25 ;; extracting it from the target stream.
26 (line-length (or *print-right-margin*
27 (sb!impl::line-length target)
28 default-line-length)
29 :type column)
30 ;; A simple string holding all the text that has been output but not yet
31 ;; printed.
32 (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
33 ;; The index into BUFFER where more text should be put.
34 (buffer-fill-pointer 0 :type index)
35 ;; Whenever we output stuff from the buffer, we shift the remaining noise
36 ;; over. This makes it difficult to keep references to locations in
37 ;; the buffer. Therefore, we have to keep track of the total amount of
38 ;; stuff that has been shifted out of the buffer.
39 (buffer-offset 0 :type posn)
40 ;; The column the first character in the buffer will appear in. Normally
41 ;; zero, but if we end up with a very long line with no breaks in it we
42 ;; might have to output part of it. Then this will no longer be zero.
43 (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
44 ;; The line number we are currently on. Used for *PRINT-LINES*
45 ;; abbreviations and to tell when sections have been split across
46 ;; multiple lines.
47 (line-number 0 :type index)
48 ;; the value of *PRINT-LINES* captured at object creation time. We
49 ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
50 ;; weirdness like
51 ;; (let ((*print-lines* 50))
52 ;; (pprint-logical-block ..
53 ;; (dotimes (i 10)
54 ;; (let ((*print-lines* 8))
55 ;; (print (aref possiblybigthings i) prettystream)))))
56 ;; terminating the output of the entire logical blockafter 8 lines.
57 (print-lines *print-lines* :type (or index null) :read-only t)
58 ;; Stack of logical blocks in effect at the buffer start.
59 (blocks (list (make-logical-block)) :type list)
60 ;; Buffer holding the per-line prefix active at the buffer start.
61 ;; Indentation is included in this. The length of this is stored
62 ;; in the logical block stack.
63 (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
64 ;; Buffer holding the total remaining suffix active at the buffer start.
65 ;; The characters are right-justified in the buffer to make it easier
66 ;; to output the buffer. The length is stored in the logical block
67 ;; stack.
68 (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
69 ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
70 ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
71 ;; cons. Adding things to the queue is basically (setf (cdr head) (list
72 ;; new)) and removing them is basically (pop tail) [except that care must
73 ;; be taken to handle the empty queue case correctly.]
74 (queue-tail nil :type list)
75 (queue-head nil :type list)
76 ;; Block-start queue entries in effect at the queue head.
77 (pending-blocks nil :type list)
78 ;; Queue of annotations to the buffer
79 (annotations-tail nil :type list)
80 (annotations-head nil :type list))
81
82
83 (defmacro enqueue (stream type &rest args)
84 (let ((constructor (intern (concatenate 'string
85 "MAKE-"
86 (symbol-name type))
87 "SB-PRETTY")))
88 (once-only ((stream stream)
89 (entry `(,constructor :posn
90 (index-posn
91 (pretty-stream-buffer-fill-pointer
92 ,stream)
93 ,stream)
94 ,@args))
95 (op `(list ,entry))
96 (head `(pretty-stream-queue-head ,stream)))
97 `(progn
98 (if ,head
99 (setf (cdr ,head) ,op)
100 (setf (pretty-stream-queue-tail ,stream) ,op))
101 (setf (pretty-stream-queue-head ,stream) ,op)
102 ,entry))))
103
104 ;;;
105 ;;; New helper functions
106 ;;;
107
108 (defun enqueue-annotation (stream handler record)
109 (enqueue stream annotation :handler handler
110 :record record))
111
112 (defun re-enqueue-annotation (stream annotation)
113 (let* ((annotation-cons (list annotation))
114 (head (pretty-stream-annotations-head stream)))
115 (if head
116 (setf (cdr head) annotation-cons)
117 (setf (pretty-stream-annotations-tail stream) annotation-cons))
118 (setf (pretty-stream-annotations-head stream) annotation-cons)
119 nil))
120
121 (defun re-enqueue-annotations (stream end)
122 (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
123 while (and tail (not (eql (car tail) end)))
124 when (annotation-p (car tail))
125 do (re-enqueue-annotation stream (car tail))))
126
127 (defun dequeue-annotation (stream &key end-posn)
128 (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
129 (when next-annotation
130 (when (or (not end-posn)
131 (<= (annotation-posn next-annotation) end-posn))
132 (pop (pretty-stream-annotations-tail stream))
133 (unless (pretty-stream-annotations-tail stream)
134 (setf (pretty-stream-annotations-head stream) nil))
135 next-annotation))))
136
137 (defun invoke-annotation (stream annotation truncatep)
138 (let ((target (pretty-stream-target stream)))
139 (funcall (annotation-handler annotation)
140 (annotation-record annotation)
141 target
142 truncatep)))
143
144 (defun output-buffer-with-annotations (stream end)
145 (let ((target (pretty-stream-target stream))
146 (buffer (pretty-stream-buffer stream))
147 (end-posn (index-posn end stream))
148 (start 0))
149 (loop
150 for annotation = (dequeue-annotation stream :end-posn end-posn)
151 while annotation
152 do
153 (let ((annotation-index (posn-index (annotation-posn annotation)
154 stream)))
155 (when (> annotation-index start)
156 (write-string buffer target :start start
157 :end annotation-index)
158 (setf start annotation-index))
159 (invoke-annotation stream annotation nil)))
160 (when (> end start)
161 (write-string buffer target :start start :end end))))
162
163 (defun flush-annotations (stream end truncatep)
164 (let ((end-posn (index-posn end stream)))
165 (loop
166 for annotation = (dequeue-annotation stream :end-posn end-posn)
167 while annotation
168 do (invoke-annotation stream annotation truncatep))))
169
170 ;;;
171 ;;; Changed functions
172 ;;;
173
174 (defun maybe-output (stream force-newlines-p)
175 (declare (type pretty-stream stream))
176 (let ((tail (pretty-stream-queue-tail stream))
177 (output-anything nil))
178 (loop
179 (unless tail
180 (setf (pretty-stream-queue-head stream) nil)
181 (return))
182 (let ((next (pop tail)))
183 (etypecase next
184 (newline
185 (when (ecase (newline-kind next)
186 ((:literal :mandatory :linear) t)
187 (:miser (misering-p stream))
188 (:fill
189 (or (misering-p stream)
190 (> (pretty-stream-line-number stream)
191 (logical-block-section-start-line
192 (first (pretty-stream-blocks stream))))
193 (ecase (fits-on-line-p stream
194 (newline-section-end next)
195 force-newlines-p)
196 ((t) nil)
197 ((nil) t)
198 (:dont-know
199 (return))))))
200 (setf output-anything t)
201 (output-line stream next)))
202 (indentation
203 (unless (misering-p stream)
204 (set-indentation stream
205 (+ (ecase (indentation-kind next)
206 (:block
207 (logical-block-start-column
208 (car (pretty-stream-blocks stream))))
209 (:current
210 (posn-column
211 (indentation-posn next)
212 stream)))
213 (indentation-amount next)))))
214 (block-start
215 (ecase (fits-on-line-p stream (block-start-section-end next)
216 force-newlines-p)
217 ((t)
218 ;; Just nuke the whole logical block and make it look like one
219 ;; nice long literal. (But don't nuke annotations.)
220 (let ((end (block-start-block-end next)))
221 (expand-tabs stream end)
222 (re-enqueue-annotations stream end)
223 (setf tail (cdr (member end tail)))))
224 ((nil)
225 (really-start-logical-block
226 stream
227 (posn-column (block-start-posn next) stream)
228 (block-start-prefix next)
229 (block-start-suffix next)))
230 (:dont-know
231 (return))))
232 (block-end
233 (really-end-logical-block stream))
234 (tab
235 (expand-tabs stream next))
236 (annotation
237 (re-enqueue-annotation stream next))))
238 (setf (pretty-stream-queue-tail stream) tail))
239 output-anything))
240
241 (defun output-line (stream until)
242 (declare (type pretty-stream stream)
243 (type newline until))
244 (let* ((target (pretty-stream-target stream))
245 (buffer (pretty-stream-buffer stream))
246 (kind (newline-kind until))
247 (literal-p (eq kind :literal))
248 (amount-to-consume (posn-index (newline-posn until) stream))
249 (amount-to-print
250 (if literal-p
251 amount-to-consume
252 (let ((last-non-blank
253 (position #\space buffer :end amount-to-consume
254 :from-end t :test #'char/=)))
255 (if last-non-blank
256 (1+ last-non-blank)
257 0)))))
258 (output-buffer-with-annotations stream amount-to-print)
259 (flush-annotations stream amount-to-consume nil)
260 (let ((line-number (pretty-stream-line-number stream)))
261 (incf line-number)
262 (when (and (not *print-readably*)
263 (pretty-stream-print-lines stream)
264 (>= line-number (pretty-stream-print-lines stream)))
265 (write-string " .." target)
266 (flush-annotations stream
267 (pretty-stream-buffer-fill-pointer stream)
268 t)
269 (let ((suffix-length (logical-block-suffix-length
270 (car (pretty-stream-blocks stream)))))
271 (unless (zerop suffix-length)
272 (let* ((suffix (pretty-stream-suffix stream))
273 (len (length suffix)))
274 (write-string suffix target
275 :start (- len suffix-length)
276 :end len))))
277 (throw 'line-limit-abbreviation-happened t))
278 (setf (pretty-stream-line-number stream) line-number)
279 (write-char #\newline target)
280 (setf (pretty-stream-buffer-start-column stream) 0)
281 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
282 (block (first (pretty-stream-blocks stream)))
283 (prefix-len
284 (if literal-p
285 (logical-block-per-line-prefix-end block)
286 (logical-block-prefix-length block)))
287 (shift (- amount-to-consume prefix-len))
288 (new-fill-ptr (- fill-ptr shift))
289 (new-buffer buffer)
290 (buffer-length (length buffer)))
291 (when (> new-fill-ptr buffer-length)
292 (setf new-buffer
293 (make-string (max (* buffer-length 2)
294 (+ buffer-length
295 (floor (* (- new-fill-ptr buffer-length)
296 5)
297 4)))))
298 (setf (pretty-stream-buffer stream) new-buffer))
299 (replace new-buffer buffer
300 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
301 (replace new-buffer (pretty-stream-prefix stream)
302 :end1 prefix-len)
303 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
304 (incf (pretty-stream-buffer-offset stream) shift)
305 (unless literal-p
306 (setf (logical-block-section-column block) prefix-len)
307 (setf (logical-block-section-start-line block) line-number))))))
308
309 (defun output-partial-line (stream)
310 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
311 (tail (pretty-stream-queue-tail stream))
312 (count
313 (if tail
314 (posn-index (queued-op-posn (car tail)) stream)
315 fill-ptr))
316 (new-fill-ptr (- fill-ptr count))
317 (buffer (pretty-stream-buffer stream)))
318 (when (zerop count)
319 (error "Output-partial-line called when nothing can be output."))
320 (output-buffer-with-annotations stream count)
321 (incf (pretty-stream-buffer-start-column stream) count)
322 (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
323 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
324 (incf (pretty-stream-buffer-offset stream) count)))
325
326 (defun force-pretty-output (stream)
327 (maybe-output stream nil)
328 (expand-tabs stream nil)
329 (re-enqueue-annotations stream nil)
330 (output-buffer-with-annotations stream
331 (pretty-stream-buffer-fill-pointer stream)))
332

  ViewVC Help
Powered by ViewVC 1.1.5