Permalink
Browse files

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

This is needed for sending presentations through pretty-printing
streams.
  • Loading branch information...
1 parent e36f43c commit 068b22d8f50641e1778a4b534d5bfbf0c204bc12 mkoeppe committed Feb 17, 2006
Showing with 332 additions and 0 deletions.
  1. +332 −0 sbcl-pprint-patch.lisp
View
@@ -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)))
+

0 comments on commit 068b22d

Please sign in to comment.