[slime-devel] Re: [Sbcl-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?

Matthias Koeppe mkoeppe+slime at mail.math.uni-magdeburg.de
Fri Jul 29 10:12:06 UTC 2005

Raymond Toy <raymond.toy at ericsson.com> writes:

>>>>>> "Matthias" == Matthias Koeppe <mkoeppe at 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

The only thing that is not covered by my patch is the hooks into
changes are independent of my patch.  

(I am including below a new version of the patch for CMUCL that includes

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 @@
 	      ;; 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)))))
@@ -556,7 +650,9 @@
 	   (really-end-logical-block stream))
-	   (expand-tabs stream next))))
+	   (expand-tabs stream next))
+	  (annotation
+	   (re-enqueue-annotation stream next))))
       (setf (pretty-stream-queue-tail stream) tail))

@@ -600,12 +696,16 @@
 		(if last-non-blank
 		    (1+ last-non-blank)
-    (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.

More information about the slime-devel mailing list