From 43025687fa51bf0b0da948da306515c1ec1d9166 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 17 Aug 2005 17:59:59 +0000
Subject: [PATCH] Apply patch from Matthias Koeppe adding annotation support to
 pretty streams.  (See mail to cmucl-imp on 2005-07-25 through 2005-08-03.)
 This basically allows arbitrary annotations to be added to pretty streams so
 that the annotations are "printed" at the appropriate times when the pretty
 stream is printed.

This allows better presentation-like features in Slime and McCLIM, and
is modeled on Allegro's schedule-annotation.

No bootstrap file, but when load-world is run, answer 0 (use-current)
to keep these changes to the pretty-stream structure.
---
 code/pprint.lisp | 141 +++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 131 insertions(+), 10 deletions(-)

diff --git a/code/pprint.lisp b/code/pprint.lisp
index e26a2b189..5a03bb47f 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.55 2005/05/19 14:21:26 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.56 2005/08/17 17:59:59 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -109,7 +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)
   (declare (ignore depth))
@@ -488,6 +491,118 @@
 	(unless (eq new-buffer buffer)
 	  (replace new-buffer buffer :end1 end :end2 end))))))
 
+
+;;;; Annotations support.
+
+(defstruct (annotation (:include queued-op))
+  (handler (constantly nil) :type function)
+  (record))
+
+(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)))
+  #+nil
+  (do ((tail (pretty-stream-queue-tail stream) (cdr tail)))
+      ((not (and tail (not (eql (car tail) end)))))
+    (when (annotation-p (car tail))
+      (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))
+    ;;#+nil
+    (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)))
+    #+nil
+    (do ((annotation (dequeue-annotation stream :end-posn end-posn)
+		     (dequeue-annotation stream :end-posn end-posn)))
+	((not annotation))
+      (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)))
+    ;;#+nil
+    (loop
+       for annotation = (dequeue-annotation stream :end-posn end-posn)
+       while annotation
+       do (invoke-annotation stream annotation truncatep))
+    #+nil
+    (do ((annotation (dequeue-annotation stream :end-posn end-posn)
+		     (dequeue-annotation stream :end-posn end-posn)))
+	((not annotation))
+      (invoke-annotation stream annotation truncatep))
+    ))
+
 
 ;;;; Stuff to do the actual outputting.
 
@@ -558,9 +673,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
@@ -573,7 +689,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))
 
@@ -617,12 +735,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)
@@ -674,8 +796,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)
@@ -684,9 +805,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.
-- 
GitLab