29 Jul
2005
29 Jul
'05
10:12 a.m.
Raymond Toy raymond.toy@ericsson.com writes:
"Matthias" == Matthias Koeppe mkoeppe@merkur.math.uni-magdeburg.de writes:
Matthias> Dear McCLIM list, Matthias> I have worked on a patch for the pretty printer of CMUCL and SBCL that Matthias> helps support the new presentation-like features of SLIME in Matthias> conjunction with the pretty printer.I'm not familiar with slime's presentations, but I was going to look into incorporating your patch.
However, in light of Paolo's comments, I'm holding off until this is resolved.
I have now taken a look at Gilbert Baumann's pretty printer patch (http://bauhh.dyndns.org:8000/mcclim/pprint/) that Paolo pointed out. As far as I can see, the changes there could be easily re-implemented in terms of the more general "annotations" feature implemented in my patch.
The only thing that is not covered by my patch is the hooks into START-LOGICAL-BLOCK, END-LOGICAL-BLOCK, PPRINT-LOGICAL-BLOCK. These changes are independent of my patch.
(I am including below a new version of the patch for CMUCL that includes docstrings.)
Cheers,
--
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.