File: sbcl-pprint-patch.lisp

package info (click to toggle)
slime 1:20060925-1
  • links: PTS
  • area: non-free
  • in suites: etch, etch-m68k
  • size: 1,860 kB
  • ctags: 2,923
  • sloc: lisp: 25,436; makefile: 119; sh: 117; awk: 10
file content (332 lines) | stat: -rw-r--r-- 12,204 bytes parent folder | download | duplicates (8)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
;; Pretty printer patch for SBCL, which adds the "annotations" feature
;; required for sending presentations through pretty-printing streams.
;;
;; The section marked "Changed functions" and the DEFSTRUCT
;; PRETTY-STREAM are based on SBCL's pprint.lisp.
;; 
;; Public domain.

(in-package "SB!PRETTY")

(defstruct (annotation (:include queued-op))
  (handler (constantly nil) :type function)
  (record))


(defstruct (pretty-stream (:include sb!kernel:ansi-stream
				    (out #'pretty-out)
				    (sout #'pretty-sout)
				    (misc #'pretty-misc))
			  (:constructor make-pretty-stream (target))
			  (:copier nil))
  ;; Where the output is going to finally go.
  (target (missing-arg) :type stream)
  ;; Line length we should format to. Cached here so we don't have to keep
  ;; extracting it from the target stream.
  (line-length (or *print-right-margin*
		   (sb!impl::line-length target)
		   default-line-length)
	       :type column)
  ;; A simple string holding all the text that has been output but not yet
  ;; printed.
  (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
  ;; The index into BUFFER where more text should be put.
  (buffer-fill-pointer 0 :type index)
  ;; Whenever we output stuff from the buffer, we shift the remaining noise
  ;; over. This makes it difficult to keep references to locations in
  ;; the buffer. Therefore, we have to keep track of the total amount of
  ;; stuff that has been shifted out of the buffer.
  (buffer-offset 0 :type posn)
  ;; The column the first character in the buffer will appear in. Normally
  ;; zero, but if we end up with a very long line with no breaks in it we
  ;; might have to output part of it. Then this will no longer be zero.
  (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
  ;; The line number we are currently on. Used for *PRINT-LINES*
  ;; abbreviations and to tell when sections have been split across
  ;; multiple lines.
  (line-number 0 :type index)
  ;; the value of *PRINT-LINES* captured at object creation time. We
  ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
  ;; weirdness like
  ;;   (let ((*print-lines* 50))
  ;;     (pprint-logical-block ..
  ;;       (dotimes (i 10)
  ;;         (let ((*print-lines* 8))
  ;;           (print (aref possiblybigthings i) prettystream)))))
  ;; terminating the output of the entire logical blockafter 8 lines.
  (print-lines *print-lines* :type (or index null) :read-only t)
  ;; Stack of logical blocks in effect at the buffer start.
  (blocks (list (make-logical-block)) :type list)
  ;; Buffer holding the per-line prefix active at the buffer start.
  ;; Indentation is included in this. The length of this is stored
  ;; in the logical block stack.
  (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
  ;; Buffer holding the total remaining suffix active at the buffer start.
  ;; The characters are right-justified in the buffer to make it easier
  ;; to output the buffer. The length is stored in the logical block
  ;; stack.
  (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
  ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
  ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
  ;; cons. Adding things to the queue is basically (setf (cdr head) (list
  ;; new)) and removing them is basically (pop tail) [except that care must
  ;; be taken to handle the empty queue case correctly.]
  (queue-tail nil :type list)
  (queue-head nil :type list)
  ;; Block-start queue entries in effect at the queue head.
  (pending-blocks nil :type list)
  ;; Queue of annotations to the buffer
  (annotations-tail nil :type list)
  (annotations-head nil :type list))


(defmacro enqueue (stream type &rest args)
  (let ((constructor (intern (concatenate 'string
					  "MAKE-"
					  (symbol-name type))
			     "SB-PRETTY")))
    (once-only ((stream stream)
		(entry `(,constructor :posn
				      (index-posn
				       (pretty-stream-buffer-fill-pointer
					,stream)
				       ,stream)
				      ,@args))
		(op `(list ,entry))
		(head `(pretty-stream-queue-head ,stream)))
      `(progn
	 (if ,head
	     (setf (cdr ,head) ,op)
	     (setf (pretty-stream-queue-tail ,stream) ,op))
	 (setf (pretty-stream-queue-head ,stream) ,op)
	 ,entry))))

;;;
;;; New helper functions
;;;

(defun enqueue-annotation (stream handler record)
  (enqueue stream annotation :handler handler
	   :record record))

(defun re-enqueue-annotation (stream annotation)
  (let* ((annotation-cons (list annotation))
	 (head (pretty-stream-annotations-head stream)))
    (if head
	(setf (cdr head) annotation-cons)
	(setf (pretty-stream-annotations-tail stream) annotation-cons))
    (setf (pretty-stream-annotations-head stream) annotation-cons)
    nil))

(defun re-enqueue-annotations (stream end)
  (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
     while (and tail (not (eql (car tail) end)))
     when (annotation-p (car tail)) 
     do (re-enqueue-annotation stream (car tail))))

(defun dequeue-annotation (stream &key end-posn)
  (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
    (when next-annotation
      (when (or (not end-posn)
		(<= (annotation-posn next-annotation) end-posn))
	(pop (pretty-stream-annotations-tail stream))
	(unless (pretty-stream-annotations-tail stream)
	  (setf (pretty-stream-annotations-head stream) nil))
	next-annotation))))

(defun invoke-annotation (stream annotation truncatep)
  (let ((target (pretty-stream-target stream)))
    (funcall (annotation-handler annotation)
	     (annotation-record annotation)
	     target
	     truncatep)))

(defun output-buffer-with-annotations (stream end)
  (let ((target (pretty-stream-target stream))
	(buffer (pretty-stream-buffer stream))
	(end-posn (index-posn end stream))
	(start 0))
    (loop
       for annotation = (dequeue-annotation stream :end-posn end-posn)
       while annotation
       do
	 (let ((annotation-index (posn-index (annotation-posn annotation)
					     stream)))
	   (when (> annotation-index start)
	     (write-string buffer target :start start 
			   :end annotation-index)
	     (setf start annotation-index))
	   (invoke-annotation stream annotation nil)))
    (when (> end start)
      (write-string buffer target :start start :end end))))

(defun flush-annotations (stream end truncatep)
  (let ((end-posn (index-posn end stream)))
    (loop
       for annotation = (dequeue-annotation stream :end-posn end-posn)
       while annotation
       do (invoke-annotation stream annotation truncatep))))

;;;
;;; Changed functions
;;;

(defun maybe-output (stream force-newlines-p)
  (declare (type pretty-stream stream))
  (let ((tail (pretty-stream-queue-tail stream))
	(output-anything nil))
    (loop
      (unless tail
	(setf (pretty-stream-queue-head stream) nil)
	(return))
      (let ((next (pop tail)))
	(etypecase next
	  (newline
	   (when (ecase (newline-kind next)
		   ((:literal :mandatory :linear) t)
		   (:miser (misering-p stream))
		   (:fill
		    (or (misering-p stream)
			(> (pretty-stream-line-number stream)
			   (logical-block-section-start-line
			    (first (pretty-stream-blocks stream))))
			(ecase (fits-on-line-p stream
					       (newline-section-end next)
					       force-newlines-p)
			  ((t) nil)
			  ((nil) t)
			  (:dont-know
			   (return))))))
	     (setf output-anything t)
	     (output-line stream next)))
	  (indentation
	   (unless (misering-p stream)
	     (set-indentation stream
			      (+ (ecase (indentation-kind next)
				   (:block
				    (logical-block-start-column
				     (car (pretty-stream-blocks stream))))
				   (:current
				    (posn-column
				     (indentation-posn next)
				     stream)))
				 (indentation-amount next)))))
	  (block-start
	   (ecase (fits-on-line-p stream (block-start-section-end next)
				  force-newlines-p)
	     ((t)
	      ;; Just nuke the whole logical block and make it look like one
	      ;; nice long literal.  (But don't nuke annotations.)
	      (let ((end (block-start-block-end next)))
		(expand-tabs stream end)
		(re-enqueue-annotations stream end)
		(setf tail (cdr (member end tail)))))
	     ((nil)
	      (really-start-logical-block
	       stream
	       (posn-column (block-start-posn next) stream)
	       (block-start-prefix next)
	       (block-start-suffix next)))
	     (:dont-know
	      (return))))
	  (block-end
	   (really-end-logical-block stream))
	  (tab
	   (expand-tabs stream next))
	  (annotation
	   (re-enqueue-annotation stream next))))
      (setf (pretty-stream-queue-tail stream) tail))
    output-anything))

(defun output-line (stream until)
  (declare (type pretty-stream stream)
	   (type newline until))
  (let* ((target (pretty-stream-target stream))
	 (buffer (pretty-stream-buffer stream))
	 (kind (newline-kind until))
	 (literal-p (eq kind :literal))
	 (amount-to-consume (posn-index (newline-posn until) stream))
	 (amount-to-print
	  (if literal-p
	      amount-to-consume
	      (let ((last-non-blank
		     (position #\space buffer :end amount-to-consume
			       :from-end t :test #'char/=)))
		(if last-non-blank
		    (1+ last-non-blank)
		    0)))))
    (output-buffer-with-annotations stream amount-to-print)
    (flush-annotations stream amount-to-consume nil)
    (let ((line-number (pretty-stream-line-number stream)))
      (incf line-number)
      (when (and (not *print-readably*)
		 (pretty-stream-print-lines stream)
		 (>= line-number (pretty-stream-print-lines stream)))
	(write-string " .." target)
	(flush-annotations stream 
			   (pretty-stream-buffer-fill-pointer stream)
			   t)
	(let ((suffix-length (logical-block-suffix-length
			      (car (pretty-stream-blocks stream)))))
	  (unless (zerop suffix-length)
	    (let* ((suffix (pretty-stream-suffix stream))
		   (len (length suffix)))
	      (write-string suffix target
			    :start (- len suffix-length)
			    :end len))))
	(throw 'line-limit-abbreviation-happened t))
      (setf (pretty-stream-line-number stream) line-number)
      (write-char #\newline target)
      (setf (pretty-stream-buffer-start-column stream) 0)
      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
	     (block (first (pretty-stream-blocks stream)))
	     (prefix-len
	      (if literal-p
		  (logical-block-per-line-prefix-end block)
		  (logical-block-prefix-length block)))
	     (shift (- amount-to-consume prefix-len))
	     (new-fill-ptr (- fill-ptr shift))
	     (new-buffer buffer)
	     (buffer-length (length buffer)))
	(when (> new-fill-ptr buffer-length)
	  (setf new-buffer
		(make-string (max (* buffer-length 2)
				  (+ buffer-length
				     (floor (* (- new-fill-ptr buffer-length)
					       5)
					    4)))))
	  (setf (pretty-stream-buffer stream) new-buffer))
	(replace new-buffer buffer
		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
	(replace new-buffer (pretty-stream-prefix stream)
		 :end1 prefix-len)
	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
	(incf (pretty-stream-buffer-offset stream) shift)
	(unless literal-p
	  (setf (logical-block-section-column block) prefix-len)
	  (setf (logical-block-section-start-line block) line-number))))))

(defun output-partial-line (stream)
  (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
	 (tail (pretty-stream-queue-tail stream))
	 (count
	  (if tail
	      (posn-index (queued-op-posn (car tail)) stream)
	      fill-ptr))
	 (new-fill-ptr (- fill-ptr count))
	 (buffer (pretty-stream-buffer stream)))
    (when (zerop count)
      (error "Output-partial-line called when nothing can be output."))
    (output-buffer-with-annotations stream count)
    (incf (pretty-stream-buffer-start-column stream) count)
    (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
    (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
    (incf (pretty-stream-buffer-offset stream) count)))

(defun force-pretty-output (stream)
  (maybe-output stream nil)
  (expand-tabs stream nil)
  (re-enqueue-annotations stream nil)
  (output-buffer-with-annotations stream 
				  (pretty-stream-buffer-fill-pointer stream)))