\f
;;;; pprint-dispatch tables
-(defvar *initial-pprint-dispatch*)
+(defvar *standard-pprint-dispatch-table*)
+(defvar *initial-pprint-dispatch-table*)
(defvar *building-initial-table* nil)
(defstruct (pprint-dispatch-entry (:copier nil))
,x))))
(defvar *precompiled-pprint-dispatch-funs*
(list (frob array (typep object 'array))
- (frob sharp-function (and (consp object)
+ (frob function-call (and (consp object)
(symbolp (car object))
(fboundp (car object))))
(frob cons (typep object 'cons)))))
(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
(declare (type (or pprint-dispatch-table null) table))
- (let* ((orig (or table *initial-pprint-dispatch*))
+ (let* ((orig (or table *initial-pprint-dispatch-table*))
(new (make-pprint-dispatch-table
:entries (copy-list (pprint-dispatch-table-entries orig))))
(new-cons-entries (pprint-dispatch-table-cons-entries 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*))
+ (let* ((table (or table *initial-pprint-dispatch-table*))
(cons-entry
(and (consp object)
(gethash (car object)
(output-ugly-object object stream))
nil))))
+(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation)
+ (when (eq pprint-dispatch *standard-pprint-dispatch-table*)
+ (cerror "Frob it anyway!" 'standard-pprint-dispatch-table-modified-error
+ :operation operation)))
+
(defun set-pprint-dispatch (type function &optional
(priority 0) (table *print-pprint-dispatch*))
(declare (type (or null callable) function)
(type pprint-dispatch-table table))
(/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
(/hexstr type)
+ (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch)
(if function
(if (cons-type-specifier-p type)
(setf (gethash (second (second type))
;;;; standard pretty-printing routines
(defun pprint-array (stream array)
- (cond ((or (and (null *print-array*) (null *print-readably*))
- (stringp array)
- (bit-vector-p array))
+ (cond ((and (null *print-array*) (null *print-readably*))
(output-ugly-object array stream))
((and *print-readably*
(not (array-readably-printable-p array)))
- (let ((*print-readably* nil))
- (error 'print-not-readable :object array)))
+ (if *read-eval*
+ (if (vectorp array)
+ (sb!impl::output-unreadable-vector-readably array stream)
+ (sb!impl::output-unreadable-array-readably array stream))
+ (print-not-readable-error array stream)))
((vectorp array)
(pprint-vector stream array))
(t
(declare (ignore noise))
(if (and (consp list)
(consp (cdr list))
- (cddr list))
+ (cddr list)
+ ;; Filter out (FLET FOO :IN BAR) names.
+ (and (consp (cddr list))
+ (not (eq :in (third list)))))
(funcall (formatter
"~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
stream
(defun pprint-progn (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
+ (pprint-linear stream list))
(defun pprint-progv (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^~3I ~:_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
stream list))
+(defvar *pprint-quote-with-syntactic-sugar* t)
+
(defun pprint-quote (stream list &rest noise)
(declare (ignore noise))
(if (and (consp list)
(consp (cdr list))
- (null (cddr list)))
+ (null (cddr list))
+ *pprint-quote-with-syntactic-sugar*)
(case (car list)
(function
(write-string "#'" stream)
(pprint-fill stream list)))
(pprint-fill stream list)))
+(defun pprint-declare (stream list &rest noise)
+ (declare (ignore noise))
+ ;; Make sure to print (DECLARE (FUNCTION F)) not (DECLARE #'A).
+ (let ((*pprint-quote-with-syntactic-sugar* nil))
+ (pprint-spread-fun-call stream list)))
+
+;;; Try to print every variable-value pair on one line; if that doesn't
+;;; work print the value indented by 2 spaces:
+;;;
+;;; (setq foo bar
+;;; quux xoo)
+;;; vs.
+;;; (setf foo
+;;; (long form ...)
+;;; quux xoo)
(defun pprint-setq (stream list &rest noise)
(declare (ignore noise))
(pprint-logical-block (stream list :prefix "(" :suffix ")")
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
(pprint-newline :miser stream)
- (if (and (consp (cdr list)) (consp (cddr list)))
- (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)))))
+ (pprint-logical-block (stream (cdr list) :prefix "" :suffix "")
+ (loop
+ (pprint-indent :block 2 stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)
+ (pprint-indent :block 0 stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :mandatory stream)))))
;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
(defmacro pprint-tagbody-guts (stream)
stream
list))
+(defun pprint-defmethod (stream list &rest noise)
+ (declare (ignore noise))
+ (if (and (consp (cdr list))
+ (consp (cddr list))
+ (consp (third list)))
+ (pprint-defun stream list)
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:I~W~^ ~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+ stream
+ list)))
+
(defun pprint-defpackage (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter
;;; Each clause in this list will get its own line.
(defvar *loop-seperating-clauses*
'(:and
- :where :for
+ :with :for
:initially :finally
:do :doing
:collect :collecting
:for :while :until :repeat :always :never :thereis
))
-(defun pprint-extended-loop-clauses (stream clauses)
- (pprint-logical-block (stream clauses :prefix "" :suffix "")
+(defun pprint-extended-loop (stream list)
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-indent :current 0 stream)
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
do (pprint-exit-if-list-exhausted)
do (write-char #\space stream))))
-(defun pprint-simple-loop-clauses (stream clauses)
- (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) do
- (when (consp thing)
- (pprint-newline :mandatory stream))
- (output-object thing stream)
- (pprint-exit-if-list-exhausted)
- (write-char #\space stream))))
-
(defun pprint-loop (stream list &rest noise)
(declare (ignore noise))
(destructuring-bind (loop-symbol . clauses) list
- (write-char #\( stream)
- (output-object loop-symbol stream)
- (cond ((null clauses))
- ((symbolp (car clauses))
- (write-char #\space stream)
- (pprint-extended-loop-clauses stream clauses))
- (t
- (write-char #\space stream)
- (pprint-simple-loop-clauses stream clauses)))
- (write-char #\) stream)))
+ (declare (ignore loop-symbol))
+ (if (or (atom clauses) (consp (car clauses)))
+ (pprint-spread-fun-call stream list)
+ (pprint-extended-loop stream list))))
(defun pprint-if (stream list &rest noise)
(declare (ignore noise))
;; Indent after the ``predicate'' form, and the ``then'' form.
- (funcall (formatter "~:<~^~W~^ ~:_~:I~W~^ ~:@_~:I~@{~W~^ ~:@_~}~:>")
+ (funcall (formatter "~:<~^~W~^ ~:I~W~^ ~:@_~@{~W~^ ~:@_~}~:>")
stream
list))
stream
list))
+(defun pprint-spread-fun-call (stream list &rest noise)
+ (declare (ignore noise))
+ ;; Similiar to PPRINT-FUN-CALL but emit a mandatory newline after
+ ;; each parameter. I.e. spread out each parameter on its own line.
+ (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:@_~}~:>")
+ stream
+ list))
+
(defun pprint-data-list (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") stream list))
+ (pprint-fill stream list))
;;; Returns an Emacs-style indent spec: an integer N, meaning indent
;;; the first N arguments specially then indent any further arguments
(cond
;; Place the very first argument next to the macro name
((zerop indent)
- (output-object (pprint-pop) stream)
- (pprint-exit-if-list-exhausted))
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted))
;; Indent any other non-body argument by the same
;; amount. It's what Emacs seems to do, too.
(t
(defun !pprint-cold-init ()
(/show0 "entering !PPRINT-COLD-INIT")
- (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
- (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
+ ;; Kludge: We set *STANDARD-PP-D-TABLE* to a new table even though
+ ;; it's going to be set to a copy of *INITIAL-PP-D-T* below because
+ ;; it's used in WITH-STANDARD-IO-SYNTAX, and condition reportery
+ ;; possibly performed in the following extent may use W-S-IO-SYNTAX.
+ (setf *standard-pprint-dispatch-table* (make-pprint-dispatch-table))
+ (setf *initial-pprint-dispatch-table* (make-pprint-dispatch-table))
+ (let ((*print-pprint-dispatch* *initial-pprint-dispatch-table*)
(*building-initial-table* t))
- ;; printers for regular types
(/show0 "doing SET-PPRINT-DISPATCH for regular types")
- (set-pprint-dispatch 'array #'pprint-array)
+ (set-pprint-dispatch '(and array (not (or string bit-vector))) #'pprint-array)
(set-pprint-dispatch '(cons (and symbol (satisfies mboundp)))
#'pprint-macro-call -1)
(set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
(/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
(dolist (magic-form '((lambda pprint-lambda)
+ (declare pprint-declare)
;; special forms
(block pprint-block)
(eval-when pprint-block)
(flet pprint-flet)
(function pprint-quote)
+ (if pprint-if)
(labels pprint-flet)
(let pprint-let)
(let* pprint-let)
(tagbody pprint-tagbody)
(throw pprint-block)
(unwind-protect pprint-block)
- (if pprint-if)
;; macros
(case pprint-case)
(ccase pprint-case)
(ctypecase pprint-typecase)
+ (declaim pprint-declare)
(defconstant pprint-block)
(define-modify-macro pprint-defun)
(define-setf-expander pprint-defun)
(defmacro pprint-defun)
+ (defmethod pprint-defmethod)
(defpackage pprint-defpackage)
(defparameter pprint-block)
(defsetf pprint-defun)
(with-output-to-string pprint-block)
(with-package-iterator pprint-block)
(with-simple-restart pprint-block)
- (with-standard-io-syntax pprint-progn)))
+ (with-standard-io-syntax pprint-progn)
+
+ ;; sbcl specific
+ (sb!int:dx-flet pprint-flet)
+ ))
(set-pprint-dispatch `(cons (eql ,(first magic-form)))
(symbol-function (second magic-form))))
(sb!impl::!backq-pp-cold-init)
(/show0 "leaving !PPRINT-COLD-INIT"))
- (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
+ (setf *standard-pprint-dispatch-table*
+ (copy-pprint-dispatch *initial-pprint-dispatch-table*))
+ (setf *print-pprint-dispatch*
+ (copy-pprint-dispatch *initial-pprint-dispatch-table*))
(setf *print-pretty* t))