New file, adds the annotations feature to the SBCL pretty printer.

This is needed for sending presentations through pretty-printing
streams.

sbcl-pprint-patch.lisp

@@ -0,0 +1,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)))
+