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