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

25 Jul 2005

Dear McCLIM list,
I have worked on a patch for the pretty printer of CMUCL and SBCL that
helps support the new presentation-like features of SLIME in
conjunction with the pretty printer.
I'd like to ask if someone of you could comment on whether this patch
would be useful for McCLIM as well.  If so, this would be another
reason for including it at as a core extension into SBCL and CMUCL.
The patch implements a feature of the Allegro CL pretty printer, which
is called SCHEDULE-ANNOTATION there.  This function queues arbitrary
functions ("annotations") in the pretty-printing stream 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, the annotations are invoked at the right position.
In my changes to SLIME, I use the function as follows.  I believe
(without knowing much about CLIM) that it should be possible to use
similar code to send CLIM presentation data (output records?), font
changes, etc. cleanly through pretty-printing streams.
;; If we are printing to an XP (pretty printing) stream, printing the
        ;; escape sequences directly would mess up the layout because column
        ;; counting is disturbed.  Use "annotations" instead.
        #+allegro
        (defun write-annotation (stream function arg)
          (if (typep stream 'excl:xp-simple-stream)
              (excl::schedule-annotation stream function arg)
              (funcall function arg stream nil)))
        #+cmu
        (defun write-annotation (stream function arg)
          (if (typep stream 'pp:pretty-stream)
              (pp::enqueue-annotation stream function arg)
              (funcall function arg stream nil)))
        #+sbcl
        (defun write-annotation (stream function arg)
          (if (typep stream 'sb-pretty::pretty-stream)
              (sb-pretty::enqueue-annotation stream function arg)
              (funcall function arg stream nil)))
        #-(or allegro cmu sbcl)
        (defun write-annotation (stream function arg)
          (funcall function arg stream nil))
(defstruct presentation-record 
          (id)
          (printed-p))
(defun presentation-start (record stream truncatep) 
          (unless truncatep
            ;; Don't start new presentations when nothing is going to be
            ;; printed due to *print-lines*.
            (let ((pid (presentation-record-id record)))
              (cond (*use-dedicated-output-stream* 
                     (write-string "<" stream)
                     (prin1 pid stream)
                     (write-string "" stream))
                    (t
                     (force-output stream)
                     (send-to-emacs `(:presentation-start ,pid)))))
            (setf (presentation-record-printed-p record) t)))
(defun presentation-end (record stream truncatep)
          (declare (ignore truncatep))
          ;; Always end old presentations that were started.
          (when (presentation-record-printed-p record)
            (let ((pid (presentation-record-id record)))
              (cond (*use-dedicated-output-stream* 
                     (write-string ">" stream)
                     (prin1 pid stream)
                     (write-string "" stream))
                    (t
                     (force-output stream)
                     (send-to-emacs `(:presentation-end ,pid)))))))
(defun presenting-object-1 (object stream continue)
          "Uses the bridge mechanism with two messages >id and <id. The first one
        says that I am starting to print an object with this id. The second says I am finished"
          (if (and *record-repl-results* *can-print-presentation*
                   (slime-stream-p stream))
              (let* ((pid (swank::save-presented-object object))
                     (record (make-presentation-record :id pid :printed-p nil)))
                (write-annotation stream #'presentation-start record)
                (multiple-value-prog1
                    (funcall continue)
                  (write-annotation stream #'presentation-end record)))
              (funcall continue)))
I am including the pretty-printer patch (for SBCL) at the end of this
message.
Cheers,
-- 
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe

diff -u /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig /home/mkoeppe/s/slime/sbcl/pprint.lisp

--- /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig	2005-07-19 22:56:54.000000000 +0200
+++ /home/mkoeppe/s/slime/sbcl/pprint.lisp	2005-07-24 19:27:29.000000000 +0200
@@ -89,7 +89,12 @@
   (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 are first put into the queue of pending operations.
+  ;; Just before output they are put into the queue of annotations.
+  (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 +365,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

@@ -452,6 +462,101 @@
    (unless (eq new-buffer buffer)
      (replace new-buffer buffer :end1 end :end2 end))))))
 
+;;;; Annotation support
+
+(defun enqueue-annotation (stream handler record)
+  #!+sb-doc
+  "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."
+  (if (pretty-stream-p stream)
+      (enqueue stream annotation :handler handler
+	       :record record)
+      (funcall handler record stream nil)))
+
+(defun re-enqueue-annotation (stream annotation)
+  #!+sb-doc
+  "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)
+  #!+sb-doc
+  "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 tail end)))
+     when (annotation-p (car tail)) 
+     do (re-enqueue-annotation stream (car tail))))
+
+(defun dequeue-annotation (stream &key end-posn)
+  #!+sb-doc
+  "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)
+  #!+sb-doc
+  "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)))
+	   (when (> annotation-index start)
+	     (write-string buffer target :start start 
+			   :end annotation-index)
+	     (setf start annotation-index))
+	   (invoke-annotation stream annotation nil)))
+    (when (> end start)
+      (write-string buffer target :start start :end end))))
+
+(defun flush-annotations (stream end truncatep)
+  #+sb-doc
+  "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 ensure-space-in-buffer (stream want)
@@ -520,10 +625,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 +642,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))

@@ -582,13 +690,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)
    	 (>= line-number (pretty-stream-print-lines stream)))
    (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)
@@ -640,8 +752,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 +761,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 
+				  (pretty-stream-buffer-fill-pointer stream)))
+
 
 ;;;; user interface to the pretty printer



    

[mcclim-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?