(defun pprint-indent (relative-to n &optional stream)
#!+sb-doc
- "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 indentation
- to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
+ "Specify the indentation to use in the current logical block if
+STREAM \(which defaults to *STANDARD-OUTPUT*) is a pretty-printing
+stream and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the
+indentation 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 indentation value does not take effect until the following line
- break."
+
+The new indentation value does not take effect until the following
+line break."
(declare (type (member :block :current) relative-to)
(type real n)
(type (or stream (member t nil)) stream)
stream
list))
+(defun pprint-defpackage (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~^~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>")
+ stream
+ list))
+
(defun pprint-destructuring-bind (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter
(pprint-fill stream (pprint-pop))
(pprint-tagbody-guts stream)))
+;;; Each clause in this list will get its own line.
+(defvar *loop-seperating-clauses*
+ '(:and
+ :where :for
+ :initially :finally
+ :do :doing
+ :collect :collecting
+ :append :appending
+ :nconc :nconcing
+ :count :counting
+ :sum :summing
+ :maximize :maximizing
+ :minimize :minimizing
+ :if :when :unless :end
+ :for :while :until :repeat :always :never :thereis
+ ))
+
+(defun pprint-loop (stream list &rest noise)
+ (declare (ignore noise))
+ (destructuring-bind (loop-symbol . clauses) list
+ (write-char #\( stream)
+ (output-object loop-symbol stream)
+ (when clauses
+ (write-char #\space stream)
+ (pprint-logical-block (stream clauses :prefix "" :suffix "")
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (loop for thing = (pprint-pop)
+ when (and (symbolp thing)
+ (member thing *loop-seperating-clauses* :test #'string=))
+ do (pprint-newline :mandatory stream)
+ do (output-object thing stream)
+ do (pprint-exit-if-list-exhausted)
+ do (write-char #\space stream))))
+ (write-char #\) stream)))
+
(defun pprint-fun-call (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>")
;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when
;;; *PRINT-PRETTY* is true.
(defun output-pretty-object (object stream)
- (with-pretty-stream (stream)
- (funcall (pprint-dispatch object) stream object)))
+ (multiple-value-bind (fun pretty) (pprint-dispatch object)
+ (if pretty
+ (with-pretty-stream (stream)
+ (funcall fun stream object))
+ ;; No point in consing up a pretty stream if we are not using pretty
+ ;; printing the object after all.
+ (output-ugly-object object stream))))
(defun !pprint-cold-init ()
(/show0 "entering !PPRINT-COLD-INIT")
(define-modify-macro pprint-defun)
(define-setf-expander pprint-defun)
(defmacro pprint-defun)
+ (defpackage pprint-defpackage)
(defparameter pprint-block)
(defsetf pprint-defun)
(defstruct pprint-block)
(etypecase pprint-typecase)
#+nil (handler-bind ...)
#+nil (handler-case ...)
- #+nil (loop ...)
+ (loop pprint-loop)
(multiple-value-bind pprint-progv)
(multiple-value-setq pprint-block)
(pprint-logical-block pprint-block)