[slime-devel] OK to install this SBCL pretty printer patch into SLIME CVS?

Matthias Koeppe mkoeppe+slime at mail.math.uni-magdeburg.de
Mon Feb 6 19:45:39 UTC 2006


Hi,

I would like to install a new file, "sbcl-pprint-patch.lisp", into
SLIME CVS.  It patches the SBCL pretty printer, so as to support
printing SLIME presentations through a pretty printing stream.  The
file will only be loaded when a user loads the SLIME file
"present.lisp".

A set of equivalent changes to the pretty printer have been included
in CMUCL 19c.  I have also tried to get the patch into SBCL, but it
seems the maintainers are not interested in merging it.

Any objections to installing it into SLIME CVS?

Matthias

Index: present.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/present.lisp,v
retrieving revision 1.17
diff -u -p -u -r1.17 present.lisp
--- present.lisp	21 Sep 2005 20:33:46 -0000	1.17
+++ present.lisp	6 Feb 2006 19:25:17 -0000
@@ -68,8 +68,12 @@ don't want to present anything"
 			     ;; layout.
 			     (slime-stream-p (pretty-print::pretty-stream-target  stream))))
 		    #+sbcl
-		    (and (typep stream 'sb-impl::indenting-stream)
-			 (slime-stream-p (sb-impl::indenting-stream-stream stream)))
+		    (or (and (typep stream 'sb-impl::indenting-stream)
+			     (slime-stream-p (sb-impl::indenting-stream-stream stream)))
+			(and (typep stream 'sb-pretty::pretty-stream)
+			     (fboundp 'sb-pretty::enqueue-annotation)
+			     (not *use-dedicated-output-stream*)
+			     (slime-stream-p (sb-pretty::pretty-stream-target  stream))))
 		    #+allegro
 		    (and (typep stream 'excl:xp-simple-stream)
 			 (slime-stream-p (excl::stream-output-handle stream)))
@@ -83,6 +87,17 @@ don't want to present anything"
   (declare (ignore stream))
   *enable-presenting-readable-objects*)
 
+;;; Get pretty printer patches for SBCL
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (handler-bind ((simple-error 
+		  (lambda (c) 
+		    (declare (ignore c))
+		    (let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
+		      (when clobber-it (invoke-restart clobber-it))))))
+    (sb-ext:without-package-locks
+      (swank-backend::with-debootstrapping (load "sbcl-pprint-patch.lisp")))))
+
 ;; 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.
@@ -97,7 +112,12 @@ don't want to present anything"
 	   (fboundp 'pp::enqueue-annotation))
       (pp::enqueue-annotation stream function arg)
       (funcall function arg stream nil)))
-#-(or allegro cmu)
+#+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))
 

*** /dev/null	Sun Jan  1 08:47:07 2006
--- sbcl-pprint-patch.lisp	Sun Jul 24 04:19:06 2005
***************
*** 0 ****
--- 1,324 ----
+ (in-package "SB!PRETTY")
+
+ (defstruct (annotation (:include queued-op))
+   (handler (constantly nil) :type function)
+   (record))
+
+
+ (defstruct (pretty-stream (:include sb!kernel:ansi-stream
+ 				    (out #'pretty-out)
+ 				    (sout #'pretty-sout)
+ 				    (misc #'pretty-misc))
+ 			  (:constructor make-pretty-stream (target))
+ 			  (:copier nil))
+   ;; Where the output is going to finally go.
+   (target (missing-arg) :type stream)
+   ;; Line length we should format to. Cached here so we don't have to keep
+   ;; extracting it from the target stream.
+   (line-length (or *print-right-margin*
+ 		   (sb!impl::line-length target)
+ 		   default-line-length)
+ 	       :type column)
+   ;; A simple string holding all the text that has been output but not yet
+   ;; printed.
+   (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
+   ;; The index into BUFFER where more text should be put.
+   (buffer-fill-pointer 0 :type index)
+   ;; Whenever we output stuff from the buffer, we shift the remaining noise
+   ;; over. This makes it difficult to keep references to locations in
+   ;; the buffer. Therefore, we have to keep track of the total amount of
+   ;; stuff that has been shifted out of the buffer.
+   (buffer-offset 0 :type posn)
+   ;; The column the first character in the buffer will appear in. Normally
+   ;; zero, but if we end up with a very long line with no breaks in it we
+   ;; might have to output part of it. Then this will no longer be zero.
+   (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+   ;; The line number we are currently on. Used for *PRINT-LINES*
+   ;; abbreviations and to tell when sections have been split across
+   ;; multiple lines.
+   (line-number 0 :type index)
+   ;; the value of *PRINT-LINES* captured at object creation time. We
+   ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
+   ;; weirdness like
+   ;;   (let ((*print-lines* 50))
+   ;;     (pprint-logical-block ..
+   ;;       (dotimes (i 10)
+   ;;         (let ((*print-lines* 8))
+   ;;           (print (aref possiblybigthings i) prettystream)))))
+   ;; terminating the output of the entire logical blockafter 8 lines.
+   (print-lines *print-lines* :type (or index null) :read-only t)
+   ;; Stack of logical blocks in effect at the buffer start.
+   (blocks (list (make-logical-block)) :type list)
+   ;; Buffer holding the per-line prefix active at the buffer start.
+   ;; Indentation is included in this. The length of this is stored
+   ;; in the logical block stack.
+   (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
+   ;; Buffer holding the total remaining suffix active at the buffer start.
+   ;; The characters are right-justified in the buffer to make it easier
+   ;; to output the buffer. The length is stored in the logical block
+   ;; stack.
+   (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
+   ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+   ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+   ;; new)) and removing them is basically (pop tail) [except that care must
+   ;; be taken to handle the empty queue case correctly.]
+   (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)
+   ;; Queue of annotations to the buffer
+   (annotations-tail nil :type list)
+   (annotations-head nil :type list))
+
+
+ (defmacro enqueue (stream type &rest args)
+   (let ((constructor (intern (concatenate 'string
+ 					  "MAKE-"
+ 					  (symbol-name type))
+ 			     "SB-PRETTY")))
+     (once-only ((stream stream)
+ 		(entry `(,constructor :posn
+ 				      (index-posn
+ 				       (pretty-stream-buffer-fill-pointer
+ 					,stream)
+ 				       ,stream)
+ 				      , at args))
+ 		(op `(list ,entry))
+ 		(head `(pretty-stream-queue-head ,stream)))
+       `(progn
+ 	 (if ,head
+ 	     (setf (cdr ,head) ,op)
+ 	     (setf (pretty-stream-queue-tail ,stream) ,op))
+ 	 (setf (pretty-stream-queue-head ,stream) ,op)
+ 	 ,entry))))
+
+ ;;;
+ ;;; New helper functions
+ ;;;
+
+ (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)
+     nil))
+
+ (defun re-enqueue-annotations (stream 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)
+   (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)
+   (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)
+   (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))))
+
+ ;;;
+ ;;; Changed functions
+ ;;;
+
+ (defun maybe-output (stream force-newlines-p)
+   (declare (type pretty-stream stream))
+   (let ((tail (pretty-stream-queue-tail stream))
+ 	(output-anything nil))
+     (loop
+       (unless tail
+ 	(setf (pretty-stream-queue-head stream) nil)
+ 	(return))
+       (let ((next (pop tail)))
+ 	(etypecase next
+ 	  (newline
+ 	   (when (ecase (newline-kind next)
+ 		   ((:literal :mandatory :linear) t)
+ 		   (:miser (misering-p stream))
+ 		   (:fill
+ 		    (or (misering-p stream)
+ 			(> (pretty-stream-line-number stream)
+ 			   (logical-block-section-start-line
+ 			    (first (pretty-stream-blocks stream))))
+ 			(ecase (fits-on-line-p stream
+ 					       (newline-section-end next)
+ 					       force-newlines-p)
+ 			  ((t) nil)
+ 			  ((nil) t)
+ 			  (:dont-know
+ 			   (return))))))
+ 	     (setf output-anything t)
+ 	     (output-line stream next)))
+ 	  (indentation
+ 	   (unless (misering-p stream)
+ 	     (set-indentation stream
+ 			      (+ (ecase (indentation-kind next)
+ 				   (:block
+ 				    (logical-block-start-column
+ 				     (car (pretty-stream-blocks stream))))
+ 				   (:current
+ 				    (posn-column
+ 				     (indentation-posn next)
+ 				     stream)))
+ 				 (indentation-amount next)))))
+ 	  (block-start
+ 	   (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.  (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
+ 	       stream
+ 	       (posn-column (block-start-posn next) stream)
+ 	       (block-start-prefix next)
+ 	       (block-start-suffix next)))
+ 	     (:dont-know
+ 	      (return))))
+ 	  (block-end
+ 	   (really-end-logical-block stream))
+ 	  (tab
+ 	   (expand-tabs stream next))
+ 	  (annotation
+ 	   (re-enqueue-annotation stream next))))
+       (setf (pretty-stream-queue-tail stream) tail))
+     output-anything))
+ 
+ (defun output-line (stream until)
+   (declare (type pretty-stream stream)
+ 	   (type newline until))
+   (let* ((target (pretty-stream-target stream))
+ 	 (buffer (pretty-stream-buffer stream))
+ 	 (kind (newline-kind until))
+ 	 (literal-p (eq kind :literal))
+ 	 (amount-to-consume (posn-index (newline-posn until) stream))
+ 	 (amount-to-print
+ 	  (if literal-p
+ 	      amount-to-consume
+ 	      (let ((last-non-blank
+ 		     (position #\space buffer :end amount-to-consume
+ 			       :from-end t :test #'char/=)))
+ 		(if last-non-blank
+ 		    (1+ last-non-blank)
+ 		    0)))))
+     (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)
+ 	    (let* ((suffix (pretty-stream-suffix stream))
+ 		   (len (length suffix)))
+ 	      (write-string suffix target
+ 			    :start (- len suffix-length)
+ 			    :end len))))
+ 	(throw 'line-limit-abbreviation-happened t))
+       (setf (pretty-stream-line-number stream) line-number)
+       (write-char #\newline target)
+       (setf (pretty-stream-buffer-start-column stream) 0)
+       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ 	     (block (first (pretty-stream-blocks stream)))
+ 	     (prefix-len
+ 	      (if literal-p
+ 		  (logical-block-per-line-prefix-end block)
+ 		  (logical-block-prefix-length block)))
+ 	     (shift (- amount-to-consume prefix-len))
+ 	     (new-fill-ptr (- fill-ptr shift))
+ 	     (new-buffer buffer)
+ 	     (buffer-length (length buffer)))
+ 	(when (> new-fill-ptr buffer-length)
+ 	  (setf new-buffer
+ 		(make-string (max (* buffer-length 2)
+ 				  (+ buffer-length
+ 				     (floor (* (- new-fill-ptr buffer-length)
+ 					       5)
+ 					    4)))))
+ 	  (setf (pretty-stream-buffer stream) new-buffer))
+ 	(replace new-buffer buffer
+ 		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ 	(replace new-buffer (pretty-stream-prefix stream)
+ 		 :end1 prefix-len)
+ 	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ 	(incf (pretty-stream-buffer-offset stream) shift)
+ 	(unless literal-p
+ 	  (setf (logical-block-section-column block) prefix-len)
+ 	  (setf (logical-block-section-start-line block) line-number))))))
+ 
+ (defun output-partial-line (stream)
+   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ 	 (tail (pretty-stream-queue-tail stream))
+ 	 (count
+ 	  (if tail
+ 	      (posn-index (queued-op-posn (car tail)) stream)
+ 	      fill-ptr))
+ 	 (new-fill-ptr (- fill-ptr count))
+ 	 (buffer (pretty-stream-buffer stream)))
+     (when (zerop count)
+       (error "Output-partial-line called when nothing can be output."))
+     (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)
+     (incf (pretty-stream-buffer-offset stream) count)))
+ 
+ (defun force-pretty-output (stream)
+   (maybe-output stream nil)
+   (expand-tabs stream nil)
+   (re-enqueue-annotations stream nil)
+   (output-buffer-with-annotations stream 
+ 				  (pretty-stream-buffer-fill-pointer stream)))
+ 	      
\ No newline at end of file

-- 
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe



More information about the slime-devel mailing list