-- Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe diff -u /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig /home/mkoeppe/s/slime/cmucl/pprint.lisp --- /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig 2005-07-21 22:30:50.000000000 +0200 +++ /home/mkoeppe/s/slime/cmucl/pprint.lisp 2005-07-29 00:11:19.000000000 +0200 @@ -109,6 +109,10 @@ ;; ;; 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) ) (defun %print-pretty-stream (pstream stream depth) @@ -381,6 +385,10 @@ (enqueue stream tab :sectionp sectionp :relativep relativep :colnum colnum :colinc colinc))) +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) +  ;;;; Tab support. @@ -472,6 +480,91 @@ (replace new-buffer buffer :end1 end :end2 end))))))  +;;;; Annotations support. + +(defun enqueue-annotation (stream handler record) + "Insert an annotation into the pretty-printing stream STREAM. +HANDLER is a function, and RECORD is an arbitrary datum. The +pretty-printing stream conceptionally queues annotations in sequence +with the characters that are printed to the stream, until the stream +has decided on the concrete layout. When the characters are forwarded +to the target stream, annotations are invoked at the right position. +An annotation is invoked by calling the function HANDLER with the +three arguments RECORD, TARGET-STREAM, and TRUNCATEP. The argument +TRUNCATEP is true if the text surrounding the annotation is suppressed +due to line abbreviation (see *PRINT-LINES*). +If STREAM is not a pretty-printing stream, simply call HANDLER +with the arguments RECORD, STREAM and nil." + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + "Insert ANNOTATION into the queue of annotations in STREAM." + (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))) + +(defun re-enqueue-annotations (stream end) + "Insert all annotations in STREAM from the queue of pending +operations into the queue of annotations. When END is non-nil, +stop before reaching the queued-op 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) + "Dequeue the next annotation from the queue of annotations of STREAM +and return it. Return nil if there are no more annotations. When +:END-POSN is given and the next annotation has a posn greater than +this, also return nil." + (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) + "Output the buffer of STREAM up to (excluding) the buffer index END. +When annotations are present, invoke them at the right positions." + (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))) + (write-string buffer target :start start + :end annotation-index) + (invoke-annotation stream annotation nil) + (setf start annotation-index))) + (write-string buffer target :start start :end end))) + +(defun flush-annotations (stream end truncatep) + "Invoke all annotations in STREAM up to (including) the buffer index END." + (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)))) + + ;;;; Stuff to do the actual outputting. (defun assure-space-in-buffer (stream want) @@ -541,9 +634,10 @@ force-newlines-p) ((t) ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. + ;; 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 @@ -556,7 +650,9 @@ (block-end (really-end-logical-block stream)) (tab - (expand-tabs stream next)))) + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) @@ -600,12 +696,16 @@ (if last-non-blank (1+ last-non-blank) 0))))) - (write-string buffer target :end amount-to-print) + (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*) *print-lines* (>= line-number *print-lines*)) (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) @@ -657,8 +757,7 @@ (buffer (pretty-stream-buffer stream))) (when (zerop count) (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) + (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) @@ -667,9 +766,9 @@ (defun force-pretty-output (stream) (maybe-output stream nil) (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream)))  ;;;; Utilities.