[Sbcl-devel] Patch for "annotations" support in the pretty printer

[Matthias K. <mk...@ma...>]

Hi,

I am sending below a patch for the SBCL pretty printer.  The patch
implements a counterpart to the function SCHEDULE-ANNOTATION of
Allegro CL; it is called ENQUEUE-ANNOTATION here.  I have used the
function to make SLIME's "Emacs presentations" work nicely with the
pretty printer.  I believe it could also be useful for CLIM
presentations, as this is what SCHEDULE-ANNOTATION seems to be used
for in Allegro CL.

Is there any chance that this patch gets merged into SBCL?

Cheers,
--=20
Matthias K=F6ppe -- http://www.math.uni-magdeburg.de/~mkoeppe

cd /home/mkoeppe/s/slime/sbcl/
diff -u /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig /home/mkoeppe/s/slime/s=
bcl/pprint.lisp
--- /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig	2005-07-19 22:56:54.0000000=
00 +0200
+++ /home/mkoeppe/s/slime/sbcl/pprint.lisp	2005-07-19 22:59:35.000000000 +0=
200
@@ -89,7 +89,10 @@
   (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))
+  (pending-blocks nil :type list)
+  ;; Queue of annotations to the buffer
+  (annotations-tail nil :type list)
+  (annotations-head nil :type list))
 (def!method print-object ((pstream pretty-stream) stream)
   ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
   ;; FORMAT hack instead. Make sure that this code actually works instead
@@ -360,6 +363,11 @@
 	(:section-relative (values t t)))
     (enqueue stream tab :sectionp sectionp :relativep relativep
 	     :colnum colnum :colinc colinc)))
+
+(defstruct (annotation (:include queued-op))
+  (handler (constantly nil) :type function)
+  (record))
+
 
 ;;;; tab support
=20
@@ -452,6 +460,71 @@
 	(unless (eq new-buffer buffer)
 	  (replace new-buffer buffer :end1 end :end2 end))))))
 
+;;;; Annotation support
+
+(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)))
+
+(defun re-enqueue-annotations (stream end)
+  (loop for tail =3D (pretty-stream-queue-tail stream) then (cdr tail)
+     while (and tail (not (eql tail end)))
+     when (annotation-p (car tail))=20
+     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)
+		(<=3D (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)
+  (declare (optimize (speed 0) (debug 3)))
+  (let ((target (pretty-stream-target stream))
+	(buffer (pretty-stream-buffer stream))
+	(end-posn (index-posn end stream))
+	(start 0))
+    (loop
+       for annotation =3D (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=20
+			   :end annotation-index))
+	   (invoke-annotation stream annotation nil)
+	   (setf start annotation-index)))
+    (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 =3D (dequeue-annotation stream :end-posn end-posn)
+       while annotation
+       do (invoke-annotation stream annotation truncatep))))
+
+
 ;;;; stuff to do the actual outputting
=20
 (defun ensure-space-in-buffer (stream want)
@@ -520,10 +593,11 @@
 	   (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.
+	      ;; 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
@@ -536,7 +610,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))
=20
@@ -582,13 +658,17 @@
 		(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*)
 		 (pretty-stream-print-lines stream)
 		 (>=3D line-number (pretty-stream-print-lines stream)))
 	(write-string " .." target)
+	(flush-annotations stream=20
+			   (pretty-stream-buffer-fill-pointer stream)
+			   t)
 	(let ((suffix-length (logical-block-suffix-length
 			      (car (pretty-stream-blocks stream)))))
 	  (unless (zerop suffix-length)
@@ -640,8 +720,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)
@@ -650,9 +729,10 @@
 (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=20
+				  (pretty-stream-buffer-fill-pointer stream)))
+
 
 ;;;; user interface to the pretty printer
=20