;; 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)
+ (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Buffer holding the total remaining suffix active at the buffer start.
;; The characters are right-justified in the buffer to make it easier
;; to output the buffer. The length is stored in the logical block
;; stack.
- (suffix (make-string initial-buffer-size) :type simple-string)
+ (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
;; cons. Adding things to the queue is basically (setf (cdr head) (list
"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
+ :LINEAR - A line break is inserted if and only if the immediately
containing section cannot be printed on one line.
:MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
(See *PRINT-MISER-WIDTH*.)
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
+ blanks that immediately precede the conditional newline are omitted
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)
\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
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
+ (unless (listp (cdr list))
+ (write-string ". " stream))
(pprint-newline :miser stream)
(pprint-logical-block (stream (cdr list) :prefix "" :suffix "")
(loop
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
(declare (ignore noise))
(destructuring-bind (loop-symbol . clauses) list
(declare (ignore loop-symbol))
- (if (or (null clauses) (consp (car clauses)))
+ (if (or (atom clauses) (consp (car clauses)))
(pprint-spread-fun-call stream list)
(pprint-extended-loop stream list))))
(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)))
(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)
(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))
projects / sbcl.git / blobdiff