From 7b2c24f5d2b339ef1318e2886b9729042d39b22f Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 5 Dec 1991 05:09:06 +0000
Subject: [PATCH] New native pretty printer!  Fully impliments the spec as
 outlined in CLtL2. [Except PPRINT-TAB doesn't work yet.]  Should be much
 better than XP because it's fully integrated with the regular printing stuff.

---
 code/pprint.lisp | 1411 +++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 1346 insertions(+), 65 deletions(-)

diff --git a/code/pprint.lisp b/code/pprint.lisp
index 6e79a1f5d..2fb61be16 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -1,4 +1,4 @@
-;;; -*- Log: code.log; Package: Lisp -*-
+;;; -*- Package: PRETTY-PRINT -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,84 +7,1365 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.3 1991/02/08 13:34:45 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.4 1991/12/05 05:09:06 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;; CMU Common Lisp pretty printer.
-;;; Written by Skef Wholey.
-;;; Modified by Todd Kaufmann, Bill Chiles, Rob Maclachlan, William Lott.
+;;; Written by William Lott.  Algorithm stolen from Richard Waters' XP.
 ;;;
+(in-package "PRETTY-PRINT" :nicknames '("PP"))
+(use-package "EXT")
+(use-package "KERNEL")
+
+(export '(pretty-stream pretty-stream-p))
 
 (in-package "LISP")
-(export '(pprint))
+(export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted
+	  pprint-newline pprint-indent pprint-tab
+	  pprint-fill pprint-linear pprint-tabular
+	  copy-pprint-dispatch pprint-dispatch set-pprint-dispatch))
+(in-package "PP")
+
+
+;;;; Pretty streams
+
+;;; There are three different units for measuring character positions:
+;;;  COLUMN - offset (if characters) from the start of the current line.
+;;;  INDEX - index into the output buffer.
+;;;  POSITION - some position in the stream of characters cycling through
+;;;             the output buffer.
+;;; 
+(deftype column ()
+  '(and fixnum unsigned-byte))
+;;; The INDEX type is picked up from the kernel package.
+(deftype position ()
+  'fixnum)
+
+(defconstant initial-buffer-size 128)
+
+(defconstant default-line-length 80)
+
+(defstruct (pretty-stream
+	    (:include stream
+		      (:out #'pretty-out)
+		      (:sout #'pretty-sout)
+		      (:misc #'pretty-misc))
+	    (:constructor make-pretty-stream (target))
+	    (:print-function %print-pretty-stream))
+  ;;
+  ;; Where the output is going to finally go.
+  ;; 
+  (target (required-argument) :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*
+		   (lisp::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-string)
+  ;;
+  ;; 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 position)
+  ;;
+  ;; 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 (lisp::charpos target) 0) :type column)
+  ;;
+  ;; The line number we are currently on.  Used for *print-lines* abrevs and
+  ;; to tell when sections have been split across multiple lines.
+  (line-number 0 :type index)
+  ;;
+  ;; 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-string)
+  ;;
+  ;; 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-string)
+  ;;
+  ;; 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)
+  )
+
+(defun %print-pretty-stream (pstream stream depth)
+  (declare (ignore depth))
+  #+nil
+  (print-unreadable-object (pstream stream :type t :identity t))
+  (format stream "#<pretty stream {~8,'0X}>"
+	  (kernel:get-lisp-obj-address pstream)))
+
+
+(declaim (inline index-position position-index
+		 index-column column-index
+		 position-column))
+(defun index-position (index stream)
+  (declare (type index index) (type pretty-stream stream)
+	   (values position))
+  (+ index (pretty-stream-buffer-offset stream)))
+(defun position-index (position stream)
+  (declare (type position position) (type pretty-stream stream)
+	   (values index))
+  (- position (pretty-stream-buffer-offset stream)))
+(defun index-column (index stream)
+  (declare (type index index) (type pretty-stream stream)
+	   (values column))
+  (+ index (pretty-stream-buffer-start-column stream)))
+(defun column-index (column stream)
+  (declare (type column column) (type pretty-stream stream)
+	   (values index))
+  (- column (pretty-stream-buffer-start-column stream)))
+(defun position-column (position stream)
+  (declare (type position position) (type pretty-stream stream)
+	   (values position))
+  (index-column (position-index position stream) stream))
+
+
+;;;; Stream interface routines.
+
+(defun pretty-out (stream char)
+  (declare (type pretty-stream stream)
+	   (type base-character char))
+  (cond ((char= char #\newline)
+	 (enqueue-newline stream :literal))
+	(t
+	 (assure-space-in-buffer stream 1)
+	 (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
+	   (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
+	   (setf (pretty-stream-buffer-fill-pointer stream)
+		 (1+ fill-pointer))))))
+
+(defun pretty-sout (stream string start end)
+  (declare (type pretty-stream stream)
+	   (type simple-string string)
+	   (type index start)
+	   (type (or index null) end))
+  (let ((end (or end (length string))))
+    (unless (= start end)
+      (let ((newline (position #\newline string :start start :end end)))
+	(cond
+	 (newline
+	  (pretty-sout stream string start newline)
+	  (enqueue-newline stream :literal)
+	  (pretty-sout stream string (1+ newline) end))
+	 (t
+	  (let ((chars (- end start)))
+	    (loop
+	      (let* ((available (assure-space-in-buffer stream chars))
+		     (count (min available chars))
+		     (fill-pointer (pretty-stream-buffer-fill-pointer stream))
+		     (new-fill-ptr (+ fill-pointer count)))
+		(replace (pretty-stream-buffer stream)
+			 string
+			 :start1 fill-pointer :end1 new-fill-ptr
+			 :start2 start)
+		(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+		(decf chars count)
+		(when (zerop count)
+		  (return))
+		(incf start count))))))))))
+
+(defun pretty-misc (stream op &optional arg1 arg2)
+  (declare (ignore stream op arg1 arg2)))
+
+
+
+;;;; Logical blocks.
+
+(defstruct logical-block
+  ;;
+  ;; The column this logical block started in.
+  (start-column 0 :type column)
+  ;;
+  ;; The length of the per-line prefix.  We can't move the indentation
+  ;; left of this.
+  (per-line-prefix-end 0 :type index)
+  ;;
+  ;; The overall length of the prefix, including any indentation.
+  (prefix-length 0 :type index)
+  ;;
+  ;; The overall length of the suffix.
+  (suffix-length 0 :type index)
+  ;; 
+  ;; The line number 
+  (section-start-line 0 :type index))
+
+(defun really-start-logical-block (stream column prefix suffix)
+  (let* ((blocks (pretty-stream-blocks stream))
+	 (prev-block (car blocks))
+	 (per-line-end (logical-block-per-line-prefix-end prev-block))
+	 (prefix-length (logical-block-prefix-length prev-block))
+	 (suffix-length (logical-block-suffix-length prev-block))
+	 (block (make-logical-block
+		 :start-column column
+		 :per-line-prefix-end per-line-end
+		 :prefix-length prefix-length
+		 :suffix-length suffix-length
+		 :section-start-line (pretty-stream-line-number stream))))
+    (setf (pretty-stream-blocks stream) (cons block blocks))
+    (set-indentation stream column)
+    (when prefix
+      (setf (logical-block-per-line-prefix-end block) column)
+      (replace (pretty-stream-prefix stream) prefix
+	       :start1 (- column (length prefix)) :end1 column))
+    (when suffix
+      (let* ((total-suffix (pretty-stream-suffix stream))
+	     (total-suffix-len (length total-suffix))
+	     (additional (length suffix))
+	     (new-suffix-len (+ suffix-length additional)))
+	(when (> new-suffix-len total-suffix-len)
+	  (let ((new-total-suffix-len
+		 (max (* total-suffix-len 2)
+		      (+ suffix-length
+			 (floor (* additional 5) 4)))))
+	    (setf total-suffix
+		  (replace (make-string new-total-suffix-len) total-suffix
+			   :start1 (- new-total-suffix-len suffix-length)
+			   :start2 (- total-suffix-len suffix-length)))
+	    (setf total-suffix-len new-total-suffix-len)
+	    (setf (pretty-stream-suffix stream) total-suffix)))
+	(replace total-suffix suffix
+		 :start1 (- total-suffix-len new-suffix-len)
+		 :end1 (- total-suffix-len suffix-length))
+	(setf suffix-length new-suffix-len))))
+  nil)
+
+(defun set-indentation (stream column)
+  (let* ((prefix (pretty-stream-prefix stream))
+	 (prefix-len (length prefix))
+	 (block (car (pretty-stream-blocks stream)))
+	 (current (logical-block-prefix-length block))
+	 (minimum (logical-block-per-line-prefix-end block))
+	 (column (max minimum column)))
+    (when (> column prefix-len)
+      (setf prefix
+	    (replace (make-string (max (* prefix-len 2)
+				       (+ prefix-len
+					  (floor (* (- column prefix-len) 5)
+						 4))))
+		     prefix
+		     :end1 current))
+      (setf (pretty-stream-prefix stream) prefix))
+    (when (> column current)
+      (fill prefix #\space :start current :end column))
+    (setf (logical-block-prefix-length block) column)))
+
+(defun really-end-logical-block (stream)
+  (let* ((old (pop (pretty-stream-blocks stream)))
+	 (old-indent (logical-block-prefix-length old))
+	 (new (car (pretty-stream-blocks stream)))
+	 (new-indent (logical-block-prefix-length new)))
+    (when (> new-indent old-indent)
+      (fill (pretty-stream-prefix stream) #\space
+	    :start old-indent :end new-indent)))
+  nil)
+
+
+
+;;;; The pending operation queue.
+
+(defstruct queued-op
+  (position 0 :type position))
+
+(defmacro enqueue (stream type &rest args)
+  (let ((constructor (intern (concatenate 'string
+					  "MAKE-"
+					  (symbol-name type)))))
+    (once-only ((stream stream)
+		(entry `(,constructor :position
+				      (index-position
+				       (pretty-stream-buffer-fill-pointer
+					,stream)
+				       ,stream)
+				      ,@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))))
+
+(defstruct (section-start
+	    (:include queued-op))
+  (depth 0 :type index)
+  (section-end nil :type (or null newline block-end)))
+
+(defstruct (newline
+	    (:include section-start))
+  (kind (required-argument)
+	:type (member :linear :fill :miser :literal :mandatory)))
+
+(defun enqueue-newline (stream kind)
+  (let* ((depth (length (pretty-stream-pending-blocks stream)))
+	 (newline (enqueue stream newline :kind kind :depth depth)))
+    (dolist (entry (pretty-stream-queue-tail stream))
+      (when (and (not (eq newline entry))
+		 (section-start-p entry)
+		 (null (section-start-section-end entry))
+		 (<= depth (section-start-depth entry)))
+	(setf (section-start-section-end entry) newline))))
+  (when (or (eq kind :literal) (eq kind :mandatory))
+    (do-some-output stream t)))
+
+(defstruct (indentation
+	    (:include queued-op))
+  (kind (required-argument) :type (member :block :current))
+  (amount 0 :type fixnum))
+
+(defun enqueue-indent (stream kind amount)
+  (enqueue stream indentation :kind kind :amount amount))
+
+(defstruct (block-start
+	    (:include section-start))
+  (block-end nil :type (or null block-end))
+  (prefix nil :type (or null simple-string))
+  (suffix nil :type (or null simple-string)))
+
+(defun start-logical-block (stream prefix per-line-p suffix)
+  (when prefix
+    (pretty-sout stream prefix 0 (length prefix)))
+  (let* ((pending-blocks (pretty-stream-pending-blocks stream))
+	 (start (enqueue stream block-start
+			 :prefix (and per-line-p prefix)
+			 :suffix suffix
+			 :depth (length pending-blocks))))
+    (setf (pretty-stream-pending-blocks stream)
+	  (cons start pending-blocks))))
+
+(defstruct (block-end
+	    (:include queued-op))
+  (suffix nil :type (or null simple-string)))
+
+(defun end-logical-block (stream)
+  (let* ((start (pop (pretty-stream-pending-blocks stream)))
+	 (suffix (block-start-suffix start))
+	 (end (enqueue stream block-end :suffix suffix)))
+    (when suffix
+      (pretty-sout stream suffix 0 (length suffix)))
+    (setf (block-start-block-end start) end)))
+
+(defun enqueue-tab (stream kind colnum colinc)
+  ;; ### Need to figure this out.
+  (declare (ignore stream kind colnum colinc)))
+
+
+
+;;;; Stuff to do the actual outputting.
+
+(defun assure-space-in-buffer (stream want)
+  (declare (type pretty-stream stream)
+	   (type index want))
+  (let* ((buffer (pretty-stream-buffer stream))
+	 (length (length buffer))
+	 (fill-ptr (pretty-stream-buffer-fill-pointer stream))
+	 (available (- length fill-ptr)))
+    (cond ((plusp available)
+	   available)
+	  ((> fill-ptr (pretty-stream-line-length stream))
+	   (do-some-output stream nil)
+	   (assure-space-in-buffer stream want))
+	  (t
+	   (let* ((new-length (max (* length 2)
+				   (+ length
+				      (floor (* want 5) 4))))
+		  (new-buffer (make-string new-length)))
+	     (setf (pretty-stream-buffer stream) new-buffer)
+	     (replace new-buffer buffer :end1 fill-ptr)
+	     (- new-length fill-ptr))))))
+
+(defun do-some-output (stream force-newlines-p)
+  (declare (type pretty-stream stream))
+  (let ((tail (pretty-stream-queue-tail stream)))
+    (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))))))
+	     (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
+				    (position-column
+				     (indentation-position 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.
+	      (setf tail (cdr (member (block-start-block-end next) tail))))
+	     ((nil)
+	      (really-start-logical-block
+	       stream
+	       (position-column (block-start-position next) stream)
+	       (block-start-prefix next)
+	       (block-start-suffix next)))
+	     (:dont-know
+	      (return))))
+	  (block-end
+	   (really-end-logical-block stream))))
+      (setf (pretty-stream-queue-tail stream) tail)))
+  (when (> (pretty-stream-buffer-fill-pointer stream)
+	   (pretty-stream-line-length stream))
+    (output-partial-line stream)))
+
+(defun misering-p (stream)
+  (declare (type pretty-stream stream))
+  (and *print-miser-width*
+       (<= (- (pretty-stream-line-length stream)
+	      (logical-block-start-column (car (pretty-stream-blocks stream))))
+	   *print-miser-width*)))
+
+(defun fits-on-line-p (stream until force-newlines-p)
+  (let ((available (pretty-stream-line-length stream)))
+    (when (and *print-lines*
+	       (= *print-lines* (pretty-stream-line-number stream)))
+      (decf available 3) ; for the `` ..''
+      (decf available (logical-block-suffix-length
+		       (car (pretty-stream-blocks stream)))))
+    (cond (until
+	   (<= (position-column (queued-op-position until) stream) available))
+	  (force-newlines-p nil)
+	  ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
+	      available)
+	   nil)
+	  (t
+	   :dont-know))))
+
+(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 (position-index (newline-position 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)))))
+    (write-string buffer target :end amount-to-print)
+    (let ((line-number (pretty-stream-line-number stream)))
+      (when (and *print-lines* (>= line-number *print-lines*))
+	(write-string " .." target)
+	(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))
+      (incf line-number)
+      (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 (car (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)))
+	(replace buffer buffer
+		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+	(replace buffer (pretty-stream-prefix stream)
+		 :end1 prefix-len)
+	(setf (pretty-stream-buffer-fill-pointer stream) (- fill-ptr shift))
+	(incf (pretty-stream-buffer-offset stream) shift))
+      (unless literal-p
+	(setf (logical-block-section-start-line
+	       (first (pretty-stream-blocks stream)))
+	      line-number)))))
+
+(defun output-partial-line (stream)
+  (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+	 (count (column-index (- (index-column fill-ptr stream)
+				 (pretty-stream-line-length stream))
+			      stream))
+	 (new-fill-ptr (- fill-ptr count))
+	 (buffer (pretty-stream-buffer stream)))
+    (write-string buffer (pretty-stream-target stream)
+		  :start 0 :end 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)
+  (do-some-output stream nil)
+  (write-string (pretty-stream-buffer stream)
+		(pretty-stream-target stream)
+		:end (pretty-stream-buffer-fill-pointer stream)))
+
+
+;;;; Utilities.
+
+(defun maybe-initiate-pretty-printing (stream function)
+  (if (pretty-stream-p stream)
+      (funcall function stream)
+      (catch 'line-limit-abbreviation-happened
+	(let ((stream (make-pretty-stream stream)))
+	  (funcall function stream)
+	  (force-pretty-output stream)))))
+
+(defmacro with-pretty-stream ((stream-var) &body body)
+  `(maybe-initiate-pretty-printing
+    ,stream-var
+    #'(lambda (,stream-var)
+	,@body)))
 
 
-(in-package "EXTENSIONS")
-(export '(grindef))
-(in-package "LISP")
 
-(defvar *pprint-initialized* nil)
+
+;;;; User interface to the pretty printer.
 
+(defmacro pprint-logical-block
+	  ((stream-symbol list &key prefix per-line-prefix suffix)
+	   &body body)
+  "Group some output into a logical block.  STREAM-SYMBOL should be either a
+   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*).  The printer
+   control variables *PRINT-LEVEL* and *PRINT-CIRCLE* are automatically
+   handled.  See the manual for details."
+  (when (and prefix per-line-prefix)
+    (error "Cannot specify both a prefix and a per-line-perfix."))
+  (multiple-value-bind
+      (stream-var stream-expression)
+      (case stream-symbol
+	((nil)
+	 (values '*standard-output* '*standard-output*))
+	((t)
+	 (values '*terminal-io* '*terminal-io*))
+	(t
+	 (values stream-symbol
+		 (once-only ((stream stream-symbol))
+		   `(case ,stream
+		      ((nil) *standard-output*)
+		      ((t) *terminal-io*)
+		      (t ,stream))))))
+    (let* ((list-var (and list (gensym)))
+	   (block-name (gensym))
+	   (count-name (gensym))
+	   (pp-pop-name (gensym))
+	   (guts
+	    `(lisp::decend-into (,list-var ,stream-var)
+	       (with-pretty-stream (,stream-var)
+		 (start-logical-block ,stream-var
+				      ,(or prefix per-line-prefix)
+				      ,(if per-line-prefix t nil)
+				      ,suffix)
+		 (let (,@(when list `((,list-var ,list-var)))
+		       (,count-name (if *print-readably* nil *print-length*)))
+		   (declare (ignorable ,count-name))
+		   (block ,block-name
+		     (flet ((,pp-pop-name ()
+			      ,@(when list-var
+				  `((unless (listp ,list-var)
+				      (write-string ". " ,stream-var)
+				      (output-object ,list-var ,stream-var)
+				      (return-from ,block-name nil))))
+			      (when (and ,count-name
+					 (minusp (decf ,count-name)))
+				(write-string "..." ,stream-var)
+				(return-from ,block-name nil))
+			      ,@(when list-var
+				  `((when (lisp::check-for-circularity
+					   ,list-var)
+				      (write-string ". " ,stream-var)
+				      (output-object ,list-var ,stream-var)
+				      (return-from ,block-name nil))
+				    (pop ,list-var)))))
+		       ;#',pp-pop-name ;; Ignorable
+		       (macrolet
+			   ((pprint-pop ()
+			      `(,',pp-pop-name))
+			    (pprint-exit-if-list-exhausted ()
+			      ,(if list
+				   ``(unless ,',list-var
+				       (return-from ,',block-name nil))
+				   '(error
+			     "Cannot use PPRINT-EXIT-IF-LIST-EXHAUSTED ~
+			      when NIL was supplied as the list ~@
+			      argument to PPRINT-LOGICAL-BLOCK because ~
+			      there is no associated list."))))
+			 ,@body))))
+		 (end-logical-block ,stream-var)))))
+      `(progn
+	 ,(if list
+	      `(let ((,stream-var ,stream-expression)
+		     (,list-var ,list))
+		 (if (listp ,list-var)
+		     ,guts
+		     (output-object ,list-var ,stream-var)))
+	      `(let ((,stream-var ,stream-expression))
+		 ,guts))
+	 nil))))
 
-(defun pprint (object &optional stream)
-  "Prettily outputs the Object preceded by a newline and followed by a space."
-  (let ((*print-pretty* t))
-    (output-pretty-object object stream))
-  (values))
+(defmacro pprint-exit-if-list-exhausted ()
+  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
+   if it's list argument is exhausted.  Can only be used inside
+   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
+   PPRINT-LOGICAL-BLOCK is supplied."
+  (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
+	  PPRINT-LOGICAL-BLOCK."))
 
-;;; OUTPUT-PRETTY-OBJECT is called by WRITE, PRIN1, PRINC, and their associated
-;;; ...-TO-STRING forms when *print-pretty* is non-nil.  Calling this when
-;;; *print-pretty* is nil could cause XP and our system to recursively call
-;;; each other for a very long time.  Stream has already been set correctly
-;;; according the semantics in the manual with respect to t and nil.
+(defmacro pprint-pop ()
+  "Return the next element from LIST argument to the closest enclosing
+   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
+   and *PRINT-CIRCLE*.  Can only be used inside PPRINT-LOGICAL-BLOCK.
+   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
+   is poped, but the *PRINT-LENGTH* testing still happens."
+  (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
+  
+(defun pprint-newline (kind &optional stream)
+  "Output a conditional newline to STREAM (which defaults to
+   *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
+   nothing if not.  KIND can be one of:
+     :LINEAR - A line break is inserted if and only if the immediatly
+        containing section cannot be printed on one line.
+     :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
+        (See *PRINT-MISER-WIDTH*.)
+     :FILL - A line break is inserted if and only if either:
+       (a) the following section cannot be printed on the end of the
+           current line,
+       (b) the preceding section was not printed on a single line, or
+       (c) the immediately containing section cannot be printed on one
+           line and miser-style is in effect.
+     :MANDATORY - A line break is always inserted.
+   When a line break is inserted by any type of conditional newline, any
+   blanks that immediately precede the conditional newline are ommitted
+   from the output and indentation is introduced at the beginning of the
+   next line.  (See PPRINT-INDENT.)"
+  (declare (type (member :linear :miser :fill :mandatory) kind)
+	   (type (or stream (member t nil)) stream)
+	   (values null))
+  (let ((stream (case stream
+		  ((t) *terminal-io*)
+		  ((nil) *standard-output*)
+		  (t stream))))
+    (when (pretty-stream-p stream)
+      (enqueue-newline stream kind)))
+  nil)
+
+(defun pprint-indent (relative-to n &optional stream)
+  "Specify the indentation to use in the current logical block if STREAM
+   (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
+   and do nothing if not.  (See PPRINT-LOGICAL-BLOCK.)  N is the indention
+   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
+     :BLOCK - Indent relative to the column the current logical block
+        started on.
+     :CURRENT - Indent relative to the current column.
+   The new indention value does not take effect until the following line
+   break."
+  (declare (type (member :block :current) relative-to)
+	   (type integer n)
+	   (type (or stream (member t nil)) stream)
+	   (values null))
+  (let ((stream (case stream
+		  ((t) *terminal-io*)
+		  ((nil) *standard-output*)
+		  (t stream))))
+    (when (pretty-stream-p stream)
+      (enqueue-indent stream relative-to n)))
+  nil)
+
+(defun pprint-tab (kind colnum colinc &optional stream)
+  "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
+   stream, perform tabbing based on KIND, otherwise do nothing.  KIND can
+   be one of:
+     :LINE - Tab to column COLNUM.  If already past COLNUM tab to the next
+       multiple of COLINC.
+     :SECTION - Same as :LINE, but count from the start of the current
+       section, not the start of the line.
+     :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
+       COLINC.
+     :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
+       of the current section, not the start of the line."
+  (declare (type (member :line :section :line-relative :section-relative) kind)
+	   (type unsigned-byte colnum colinc)
+	   (type (or stream (member t nil)) stream)
+	   (values null))
+  (let ((stream (case stream
+		  ((t) *terminal-io*)
+		  ((nil) *standard-output*)
+		  (t stream))))
+    (when (pretty-stream-p stream)
+      (enqueue-tab stream kind colnum colinc)))
+  nil)
+
+(defun pprint-fill (stream list &optional (colon? t) atsign?)
+  "Output LIST to STREAM putting :FILL conditional newlines between each
+   element.  If COLON? is NIL (defaults to T), then no parens are printed
+   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-FILL
+   can be used with the ~/.../ format directive."
+  (declare (ignore atsign?))
+  (pprint-logical-block (stream list
+				:prefix (if colon? "(")
+				:suffix (if colon? ")"))
+    (pprint-exit-if-list-exhausted)
+    (loop
+      (output-object (pprint-pop) stream)
+      (pprint-exit-if-list-exhausted)
+      (write-char #\space stream)
+      (pprint-newline :fill stream))))
+
+(defun pprint-linear (stream list &optional (colon? t) atsign?)
+  "Output LIST to STREAM putting :LINEAR conditional newlines between each
+   element.  If COLON? is NIL (defaults to T), then no parens are printed
+   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
+   can be used with the ~/.../ format directive."
+  (declare (ignore atsign?))
+  (pprint-logical-block (stream list
+				:prefix (if colon? "(")
+				:suffix (if colon? ")"))
+    (pprint-exit-if-list-exhausted)
+    (loop
+      (output-object (pprint-pop) stream)
+      (pprint-exit-if-list-exhausted)
+      (write-char #\space stream)
+      (pprint-newline :linear stream))))
+
+(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
+  "Output LIST to STREAM tabbing to the next column that is an even multiple
+   of TABSIZE (which defaults to 16) between each element.  :FILL style
+   conditional newlines are also output between each element.  If COLON? is
+   NIL (defaults to T), then no parens are printed around the output.
+   ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
+   the ~/.../ format directive."
+  (declare (ignore atsign?))
+  (pprint-logical-block (stream list
+				:prefix (if colon? "(")
+				:suffix (if colon? ")"))
+    (pprint-exit-if-list-exhausted)
+    (loop
+      (output-object (pprint-pop) stream)
+      (pprint-exit-if-list-exhausted)
+      (write-char #\space stream)
+      (pprint-tab :section-relative 0 (or tabsize 16) stream)
+      (pprint-newline :fill stream))))
+
+
+;;;; Pprint-dispatch tables.
+
+(defvar *initial-pprint-dispatch*)
+(defvar *building-initial-table* nil)
+
+(defstruct (pprint-dispatch-entry
+	    (:print-function %print-pprint-dispatch-entry))
+  ;;
+  ;; The type specifier for this entry.
+  (type (required-argument) :type t)
+  ;;
+  ;; A function to test to see if an object is of this time.  Pretty must
+  ;; just (lambda (obj) (typep object type)) except that we handle the
+  ;; CONS type specially so that (cons (member foo)) works.  We don't
+  ;; bother computing this for entries in the CONS hash table, because
+  ;; we don't need it.
+  (test-fn nil :type (or function null))
+  ;;
+  ;; The priority for this guy.
+  (priority 0 :type real)
+  ;;
+  ;; T iff one of the original entries.
+  (initial-p *building-initial-table* :type (member t nil))
+  ;;
+  ;; And the associated function.
+  (function (required-argument) :type function))
+
+(defun %print-pprint-dispatch-entry (entry stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (entry stream :type t)
+    (format stream "Type=~S, priority=~S~@[ [Initial]~]"
+	    (pprint-dispatch-entry-type entry)
+	    (pprint-dispatch-entry-priority entry)
+	    (pprint-dispatch-entry-initial-p entry))))
+
+(defstruct (pprint-dispatch-table
+	    (:print-function %print-pprint-dispatch-table))
+  ;;
+  ;; A list of all the entries (except for CONS entries below) in highest
+  ;; to lowest priority.
+  (entries nil :type list)
+  ;;
+  ;; A hash table mapping things to entries for type specifiers of the
+  ;; form (CONS (MEMBER <thing>)).  If the type specifier is of this form,
+  ;; we put it in this hash table instead of the regular entries table.
+  (cons-entries (make-hash-table :test #'eql)))
+
+(defun %print-pprint-dispatch-table (table stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (table stream :type t :identity t)))
+
+(defun cons-type-specifier-p (spec)
+  (and (consp spec)
+       (eq (car spec) 'cons)
+       (cdr spec)
+       (null (cddr spec))
+       (let ((car (cadr spec)))
+	 (and (consp car)
+	      (let ((carcar (car car)))
+		(or (eq carcar 'member)
+		    (eq carcar 'eql)))
+	      (cdr car)
+	      (null (cddr car))))))
+
+(defun entry< (e1 e2)
+  (declare (type pprint-dispatch-entry e1 e2))
+  (if (pprint-dispatch-entry-initial-p e1)
+      (if (pprint-dispatch-entry-initial-p e2)
+	  (< (pprint-dispatch-entry-priority e1)
+	     (pprint-dispatch-entry-priority e2))
+	  t)
+      (if (pprint-dispatch-entry-initial-p e2)
+	  nil
+	  (< (pprint-dispatch-entry-priority e1)
+	     (pprint-dispatch-entry-priority e2)))))
+
+(defun compute-test-fn (type)
+  (labels ((compute-test-expr (type object)
+	     (if (listp type)
+		 (case (car type)
+		   (cons
+		    (destructuring-bind
+			(&optional (car nil car-p) (cdr nil cdr-p))
+			(cdr type)
+		      `(and (consp ,object)
+			    ,@(when car-p
+				`(,(compute-test-expr car `(car ,object))))
+			    ,@(when cdr-p
+				`(,(compute-test-expr cdr `(cdr ,object)))))))
+		   (not
+		    (destructuring-bind (type) (cdr type)
+		      `(not ,(compute-test-expr type object))))
+		   (and
+		    `(and ,@(mapcar #'(lambda (type)
+					(compute-test-expr type object))
+				    (cdr type))))
+		   (or
+		    `(or ,@(mapcar #'(lambda (type)
+				       (compute-test-expr type object))
+				   (cdr type))))
+		   (t
+		    `(typep ,object ',type)))
+		 `(typep ,object ',type))))
+    (compile nil `(lambda (object) ,(compute-test-expr type 'object)))))
+
+(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
+  (declare (type (or pprint-dispatch-table null) table))
+  (let* ((orig (or table *initial-pprint-dispatch*))
+	 (new (make-pprint-dispatch-table
+	       :entries (copy-list (pprint-dispatch-table-entries orig))))
+	 (new-cons-entries (pprint-dispatch-table-cons-entries new)))
+    (maphash #'(lambda (key value)
+		 (setf (gethash key new-cons-entries) value))
+	     (pprint-dispatch-table-cons-entries orig))
+    new))
+
+(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
+  (declare (type (or pprint-dispatch-table null) table))
+  (let* ((table (or table *initial-pprint-dispatch*))
+	 (cons-entry
+	  (and (consp object)
+	       (gethash (car object)
+			(pprint-dispatch-table-cons-entries table))))
+	 (entry
+	  (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
+	    (when (and cons-entry
+		       (entry< entry cons-entry))
+	      (return cons-entry))
+	    (when (funcall (pprint-dispatch-entry-test-fn entry) object)
+	      (return entry)))))
+    (if entry
+	(values (pprint-dispatch-entry-function entry) t)
+	(values #'(lambda (stream object)
+		    (output-ugly-object object stream))
+		nil))))
+
+(defun set-pprint-dispatch (type function &optional
+			    (priority 0) (table *print-pprint-dispatch*))
+  (declare (type (or null function) function)
+	   (type real priority)
+	   (type pprint-dispatch-table table))
+  (if function
+      (if (cons-type-specifier-p type)
+	  (setf (gethash (second (second type))
+			 (pprint-dispatch-table-cons-entries table))
+		(make-pprint-dispatch-entry :type type :priority priority
+					    :function function))
+	  (let ((list (delete type (pprint-dispatch-table-entries table)
+			      :key #'pprint-dispatch-entry-type
+			      :test #'equal))
+		(entry (make-pprint-dispatch-entry
+			:type type :test-fn (compute-test-fn type)
+			:priority priority :function function)))
+	    (do ((prev nil next)
+		 (next list (cdr next)))
+		((null next)
+		 (if prev
+		     (setf (cdr prev) (list entry))
+		     (setf list (list entry))))
+	      (when (entry< (car next) entry)
+		(if prev
+		    (setf (cdr prev) (cons entry next))
+		    (setf list (cons entry next)))
+		(return)))
+	    (setf (pprint-dispatch-table-entries table) list)))
+      (if (cons-type-specifier-p type)
+	  (remhash (second (second type))
+		   (pprint-dispatch-table-cons-entries table))
+	  (setf (pprint-dispatch-table-entries table)
+		(delete type (pprint-dispatch-table-entries table)
+			:key #'pprint-dispatch-entry-type
+			:test #'equal))))
+  nil)
+
+
+;;;; Standard pretty-printing routines.
+
+(defun pprint-array (stream array)
+  (cond ((or (and (null *print-array*) (null *print-readably*))
+	     (stringp array)
+	     (bit-vector-p array))
+	 (output-ugly-object array stream))
+	((and *print-readably* (not (eq (array-element-type array) 't)))
+	 (let ((*print-readably* nil))
+	   (error "~S cannot be printed readably.")))
+	((vectorp array)
+	 (pprint-vector stream array))
+	(t
+	 (pprint-multi-dim-array stream array))))
+
+(defun pprint-vector (stream vector)
+  (decend-into (vector stream)
+    (with-pretty-stream (stream)
+      (start-logical-block stream "#(" nil ")")
+      (dotimes (i (length vector))
+	(punt-if-too-long i stream)
+	(unless (zerop i)
+	  (write-char #\space stream)
+	  (pprint-newline :fill stream))
+	(output-object (aref vector i) stream))
+      (end-logical-block stream))))
+
+(defun pprint-multi-dim-array (stream array)
+  (decend-into (array stream)
+    (funcall (formatter "#~DA") stream (array-rank array))
+    (lisp::with-array-data ((data array) (start) (end))
+      (declare (ignore end))
+      (labels ((output-guts (stream index dimensions)
+		 (if (null dimensions)
+		     (output-object (svref data index) stream)
+		     (pprint-logical-block
+			 (stream nil :prefix "(" :suffix ")")
+		       (let ((dim (car dimensions)))
+			 (unless (zerop dim)
+			   (let* ((dims (cdr dimensions))
+				  (index index)
+				  (step (reduce #'* dims))
+				  (count 0))
+			     (loop				
+			       (pprint-pop)
+			       (output-guts stream index dims)
+			       (when (= (incf count) dim)
+				 (return))
+			       (write-char #\space stream)
+			       (pprint-newline (if dims :linear :fill)
+					       stream)
+			       (incf index step)))))))))
+	(output-guts stream start (array-dimensions array))))))
+
+(defun pprint-lambda-list (stream lambda-list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
+    (let ((state :required)
+	  (first t))
+      (loop
+	(pprint-exit-if-list-exhausted)
+	(let ((arg (pprint-pop)))
+	  (unless first
+	    (write-char #\space stream)
+	    (case arg
+	      (&optional
+	       (setf state :optional)
+	       (pprint-newline :linear stream))
+	      ((&rest &body)
+	       (setf state :required)
+	       (pprint-newline :linear stream))
+	      (&key
+	       (setf state :key)
+	       (pprint-newline :linear stream))
+	      (&aux
+	       (setf state :optional)
+	       (pprint-newline :linear stream))
+	      (t
+	       (pprint-newline :fill stream))))
+	  (ecase state
+	    (:required
+	     (pprint-lambda-list stream arg))
+	    ((:optional :key)
+	     (pprint-logical-block
+		 (stream arg :prefix "(" :suffix ")")
+	       (pprint-exit-if-list-exhausted)
+	       (if (eq state :key)
+		   (pprint-logical-block
+		       (stream (pprint-pop) :prefix "(" :suffix ")")
+		     (pprint-exit-if-list-exhausted)
+		     (output-object (pprint-pop) stream)
+		     (pprint-exit-if-list-exhausted)
+		     (write-char #\space stream)
+		     (pprint-newline :fill stream)
+		     (pprint-lambda-list stream (pprint-pop))
+		     (loop
+		       (pprint-exit-if-list-exhausted)
+		       (write-char #\space stream)
+		       (pprint-newline :fill stream)
+		       (output-object (pprint-pop) stream)))
+		   (pprint-lambda-list stream (pprint-pop)))
+	       (loop
+		 (pprint-exit-if-list-exhausted)
+		 (write-char #\space stream)
+		 (pprint-newline :linear stream)
+		 (output-object (pprint-pop) stream))))))
+	(setf first nil)))))
+
+(defun pprint-lambda (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	    "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+	   stream list))
+
+(defun pprint-block (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
+
+(defun pprint-flet (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	    "~:<~^~W~^ ~@_~:<~@{~:<~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
+	   stream
+	   list))
+
+(defun pprint-let (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
+	   stream
+	   list))
+
+(defun pprint-progn (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
+
+(defun pprint-progv (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
+	   stream list))
+
+(defun pprint-quote (stream list &rest noise)
+  (declare (ignore noise))
+  (if (and (consp list)
+	   (consp (cdr list))
+	   (null (cddr list)))
+      (case (car list)
+	(function
+	 (write-string "#'" stream)
+	 (output-object (cadr list) stream))
+	(quote
+	 (write-char #\' stream)
+	 (output-object (cadr list) stream))
+	(t
+	 (pprint-fill stream list)))
+      (pprint-fill stream list)))
+
+(defun pprint-setq (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    (pprint-exit-if-list-exhausted)
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (pprint-newline :miser stream)
+    (if (> (length list) 3)
+	(loop
+	  (pprint-indent :current 2 stream)
+	  (output-object (pprint-pop) stream)
+	  (pprint-exit-if-list-exhausted)
+	  (write-char #\space stream)
+	  (pprint-newline :linear stream)
+	  (pprint-indent :current -2 stream)
+	  (output-object (pprint-pop) stream)
+	  (pprint-exit-if-list-exhausted)
+	  (write-char #\space stream)
+	  (pprint-newline :linear stream))
+	(progn
+	  (pprint-indent :current 0 stream)
+	  (output-object (pprint-pop) stream)
+	  (pprint-exit-if-list-exhausted)
+	  (write-char #\space stream)
+	  (pprint-newline :linear stream)
+	  (output-object (pprint-pop) stream)))))
+	  
+(defmacro pprint-tagbody-guts (stream)
+  `(loop
+     (pprint-exit-if-list-exhausted)
+     (write-char #\space ,stream)
+     (let ((form-or-tag (pprint-pop)))
+       (pprint-indent :block 
+		      (if (atom form-or-tag) 0 1)
+		      ,stream)
+       (pprint-newline :linear ,stream)
+       (output-object form-or-tag ,stream))))
+
+(defun pprint-tagbody (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    (pprint-exit-if-list-exhausted)
+    (output-object (pprint-pop) stream)
+    (pprint-tagbody-guts stream)))
+
+(defun pprint-case (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	    "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
+	   stream
+	   list))
+
+(defun pprint-defun (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	    "~:<~^~W~^ ~@_~:I~W~^ ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+	   stream
+	   list))
+
+(defun pprint-destructuring-bind (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	"~:<~^~W~^~3I ~_~:/PP:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
+	   stream list))
+
+(defun pprint-do (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list)
+    (pprint-exit-if-list-exhausted)
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (pprint-indent :current 0 stream)
+    (funcall (formatter "~:<~@{~:<~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
+	     stream
+	     (pprint-pop))
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (pprint-newline :linear stream)
+    (pprint-linear stream (pprint-pop))
+    (pprint-tagbody-guts stream)))
+
+(defun pprint-dolist (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list)
+    (pprint-exit-if-list-exhausted)
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (pprint-indent :block 3 stream)
+    (write-char #\space stream)
+    (pprint-newline :fill stream)
+    (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
+	     stream
+	     (pprint-pop))
+    (pprint-tagbody-guts stream)))
+
+(defun pprint-typecase (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter
+	    "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
+	   stream
+	   list))
+
+(defun pprint-prog (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    (pprint-exit-if-list-exhausted)
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (pprint-newline :miser stream)
+    (pprint-fill stream (pprint-pop))
+    (pprint-tagbody-guts stream)))
+
+(defun pprint-function-call (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~^~W~^ ~@_~:I~@{~W~^ ~_~}~:>")
+	   stream
+	   list))
+
+
+;;;; Interface seen by regular (ugly) printer and initialization routines.
+
+;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
+;;; bound to T.
 ;;;
 (defun output-pretty-object (object stream)
-  (assert *print-pretty*)
-  (if (and *pprint-initialized*
-	   (typep object '(or list structure vector array)))
-      (xp::basic-write object stream)
-      (let ((*print-pretty* nil))
-	(output-object object stream))))
-
-
-#|
-
-(defun pretty-lambda-to-defun (name lambda &optional arglist)
-  `(defun ,name ,(or arglist (cadr lambda))
-     ,@(if (and (null (cdddr lambda)) (listp (caddr lambda))
-		(eq (caaddr lambda) 'block))
-	   (cddr (caddr lambda))
-	   (cddr lambda))))
-
-(defmacro grindef (function-name)
- "Prettily prints the definition of the function whose name is Function-Name."
- (if (and (symbolp function-name) (fboundp function-name))
-     (let ((stuff (symbol-function function-name)))
-       (if (and (listp stuff) (listp (cdr stuff)))
-	   (case (car stuff)
-	     (lambda `(pprint ',(pretty-lambda-to-defun function-name stuff)))
-	     (macro `(pprint ',(pretty-lambda-to-defun function-name (cdr stuff)
-						       '(&rest **macroarg**))))
-	     (t `(pprint '(setf (symbol-function ,function-name) ',stuff))))
-	   `(pprint '(setf (symbol-function ,function-name) ',stuff))))
-     nil))
-
-|#
-
-;;; Tab-Over prints the specified number of spaces on *Standard-Output*.
-;;; Taken from the old pretty printer.  Needed by some function in filesys.
-(defconstant maximum-pp-indentation 70)
-(defconstant pp-indentation-string (make-string 70 :initial-element #\space))
-
-(defun tab-over (indent-pos)
-  (write-string pp-indentation-string *standard-output*
-		:start 0
-		:end (min indent-pos maximum-pp-indentation)))
-
-;;; Initialize Water's pretty printer.
+  (with-pretty-stream (stream)
+    (multiple-value-bind
+	(function found)
+	(pprint-dispatch object)
+      (if found
+	  (funcall function stream object)
+	  (output-ugly-object object stream)))))
+
+(defparameter magic-forms
+  '((lambda pprint-lambda)
+    ;; Special forms.
+    (block pprint-block)
+    (catch pprint-block)
+    (compiler-let pprint-let)
+    (eval-when pprint-block)
+    (flet pprint-flet)
+    (function pprint-quote)
+    (generic-flet pprint-flet)
+    (generic-labels pprint-flet)
+    (labels pprint-flet)
+    (let pprint-let)
+    (let* pprint-let)
+    (locally pprint-progn)
+    (macrolet pprint-flet)
+    (multiple-value-call pprint-block)
+    (multiple-value-prog1 pprint-block)
+    (progn pprint-progn)
+    (progv pprint-progv)
+    (quote pprint-quote)
+    (return-from pprint-block)
+    (setq pprint-setq)
+    (symbol-macrolet pprint-let)
+    (tagbody pprint-tagbody)
+    (throw pprint-block)
+    (unwind-protect pprint-block)
+    (with-added-methods pprint-flet)
+    
+    ;; Macros.
+    (case pprint-case)
+    (ccase pprint-case)
+    (ctypecase pprint-typecase)
+    (defconstant pprint-block)
+    (define-modify-macro pprint-defun)
+    (define-setf-method pprint-defun)
+    (defmacro pprint-defun)
+    (defparameter pprint-block)
+    (defsetf pprint-defun)
+    (defstruct pprint-block)
+    (deftype pprint-defun)
+    (defun pprint-defun)
+    (defvar pprint-block)
+    (destructuring-bind pprint-destructuring-bind)
+    (do pprint-do)
+    (do* pprint-do)
+    (do-all-symbols pprint-dolist)
+    (do-external-symbols pprint-dolist)
+    (do-symbols pprint-dolist)
+    (dolist pprint-dolist)
+    (dotimes pprint-dolist)
+    (ecase pprint-case)
+    (etypecase pprint-typecase)
+    #+nil (handler-bind ...)
+    #+nil (handler-case ...)
+    #+nil (loop ...)
+    (multiple-value-bind pprint-progv)
+    (multiple-value-setq pprint-block)
+    (pprint-logical-block pprint-block)
+    (print-unreadable-object pprint-block)
+    (prog pprint-prog)
+    (prog* pprint-prog)
+    (prog1 pprint-block)
+    (prog2 pprint-progv)
+    (psetf pprint-setq)
+    (psetq pprint-setq)
+    #+nil (restart-bind ...)
+    #+nil (restart-case ...)
+    (setf pprint-setq)
+    (step pprint-progn)
+    (time pprint-progn)
+    (typecase pprint-typecase)
+    (unless pprint-block)
+    (when pprint-block)
+    (with-compilation-unit pprint-block)
+    #+nil (with-condition-restarts ...)
+    (with-hash-table-iterator pprint-block)
+    (with-input-from-string pprint-block)
+    (with-open-file pprint-block)
+    (with-open-stream pprint-block)
+    (with-output-to-string pprint-block)
+    (with-package-iterator pprint-block)
+    (with-simple-restart pprint-block)
+    (with-standard-io-syntax pprint-progn)))
+
 (defun pprint-init ()
-  (xp::install :package "XP" :shadow nil)
-  (setf *pprint-initialized* t)
-  (setf *print-pretty* t))
+  (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
+  (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
+	(*building-initial-table* t))
+    ;; Printers for regular types.
+    (set-pprint-dispatch 'array #'pprint-array)
+    (set-pprint-dispatch 'cons #'pprint-function-call -1)
+    ;; Cons cells with interesting things for the car.
+    (dolist (magic-form magic-forms)
+      (set-pprint-dispatch `(cons (eql ,(first magic-form)))
+			   (symbol-function (second magic-form)))))
 
+  (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
+  (setf *pretty-printer* #'output-pretty-object)
+  (setf *print-pretty* t))
-- 
GitLab