(type simple-string string)
(type index start)
(type (or index null) end))
- (let* ((string (if (typep string '(simple-array character (*)))
- string
- (coerce string '(simple-array character (*)))))
- (end (or end (length string))))
+ (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 (ensure-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))))))))))
+ (sb!impl::string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character (*)))
+ string
+ ;; For POSITION transform
+ (declare (optimize (speed 2)))
+ (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 (ensure-space-in-buffer stream chars))
+ (count (min available chars))
+ (fill-pointer (pretty-stream-buffer-fill-pointer
+ stream))
+ (new-fill-ptr (+ fill-pointer count)))
+ (if (typep string 'simple-base-string)
+ ;; FIXME: Reimplementing REPLACE, since it
+ ;; can't be inlined and we don't have a
+ ;; generic "simple-array -> simple-array"
+ ;; transform for it.
+ (loop for i from fill-pointer below new-fill-ptr
+ for j from start
+ with target = (pretty-stream-buffer stream)
+ do (setf (aref target i)
+ (aref string j)))
+ (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)))
(defstruct (block-start (:include section-start)
(:copier nil))
(block-end nil :type (or null block-end))
- (prefix nil :type (or null (simple-array character (*))))
- (suffix nil :type (or null (simple-array character (*)))))
+ (prefix nil :type (or null simple-string))
+ (suffix nil :type (or null simple-string)))
(defun start-logical-block (stream prefix per-line-p suffix)
;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
;; trivial, so it should always be a string.)
(declare (type string suffix))
(when prefix
- (setq prefix (coerce prefix '(simple-array character (*))))
+ (unless (typep prefix 'simple-string)
+ (setq prefix (coerce prefix '(simple-array character (*)))))
(pretty-sout stream prefix 0 (length prefix)))
+ (unless (typep suffix 'simple-string)
+ (setq suffix (coerce suffix '(simple-array character (*)))))
(let* ((pending-blocks (pretty-stream-pending-blocks stream))
(start (enqueue stream block-start
:prefix (and per-line-p prefix)
- :suffix (coerce suffix '(simple-array character (*)))
+ :suffix suffix
:depth (length pending-blocks))))
(setf (pretty-stream-pending-blocks stream)
(cons start pending-blocks))))
(defstruct (block-end (:include queued-op)
(:copier nil))
- (suffix nil :type (or null (simple-array character (*)))))
+ (suffix nil :type (or null simple-string)))
(defun end-logical-block (stream)
(let* ((start (pop (pretty-stream-pending-blocks 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
+ :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)
(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)
\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))
(< (pprint-dispatch-entry-priority e1)
(pprint-dispatch-entry-priority e2)))))
-(macrolet ((frob (x)
- `(cons ',x (lambda (object) ,x))))
+(macrolet ((frob (name x)
+ `(cons ',x (named-lambda ,(symbolicate "PPRINT-DISPATCH-" name) (object)
+ ,x))))
(defvar *precompiled-pprint-dispatch-funs*
- (list (frob (typep object 'array))
- (frob (and (consp object)
- (symbolp (car object))
- (fboundp (car object))))
- (frob (typep object 'cons)))))
+ (list (frob array (typep object 'array))
+ (frob function-call (and (consp object)
+ (symbolp (car object))
+ (fboundp (car object))))
+ (frob cons (typep object 'cons)))))
(defun compute-test-fn (type)
(let ((was-cons nil))
(cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
:test #'equal)))
(t
- (compile nil `(lambda (object) ,expr))))))))
+ (let ((name (symbolicate "PPRINT-DISPATCH-"
+ (if (symbolp type)
+ type
+ (write-to-string type
+ :escape t
+ :pretty nil
+ :readably nil)))))
+ (compile nil `(named-lambda ,name (object)
+ ,expr)))))))))
(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))
+(defun pprint-prog2 (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 ")")
(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)
- (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
+ "~:<~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
+ :with :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-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)
+ (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))))
+
+(defun pprint-loop (stream list &rest noise)
+ (declare (ignore noise))
+ (destructuring-bind (loop-symbol . clauses) list
+ (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~^ ~:@_~@{~W~^ ~:@_~}~:>")
+ stream
+ list))
+
(defun pprint-fun-call (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
+ (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>")
+ 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))
+ (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
+;;; like a body.
+(defun macro-indentation (name)
+ (labels ((proper-list-p (list)
+ (not (nth-value 1 (ignore-errors (list-length list)))))
+ (macro-arglist (name)
+ (%simple-fun-arglist (macro-function name)))
+ (clean-arglist (arglist)
+ "Remove &whole, &enviroment, and &aux elements from ARGLIST."
+ (cond ((null arglist) '())
+ ((member (car arglist) '(&whole &environment))
+ (clean-arglist (cddr arglist)))
+ ((eq (car arglist) '&aux)
+ '())
+ (t (cons (car arglist) (clean-arglist (cdr arglist)))))))
+ (let ((arglist (macro-arglist name)))
+ (if (proper-list-p arglist) ; guard against dotted arglists
+ (position '&body (remove '&optional (clean-arglist arglist)))
+ nil))))
+
+;;; Pretty-Print macros by looking where &BODY appears in a macro's
+;;; lambda-list.
+(defun pprint-macro-call (stream list &rest noise)
+ (declare (ignore noise))
+ (let ((indentation (and (car list) (macro-indentation (car list)))))
+ (unless indentation
+ (return-from pprint-macro-call
+ (pprint-fun-call stream list)))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (loop for indent from 0 below indentation do
+ (cond
+ ;; Place the very first argument next to the macro name
+ ((zerop indent)
+ (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
+ (pprint-indent :block 3 stream)
+ (pprint-newline :mandatory stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted))))
+ ;; Indent back for the body.
+ (pprint-indent :block 1 stream)
+ (pprint-newline :mandatory stream)
+ (loop
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (pprint-newline :mandatory stream)))))
\f
;;;; the interface seen by regular (ugly) printer and initialization routines
;;; 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 mboundp (name)
+ (and (fboundp name) (macro-function name) 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 '(cons symbol)
+ (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)))
#'pprint-fun-call -1)
+ (set-pprint-dispatch '(cons symbol)
+ #'pprint-data-list -2)
(set-pprint-dispatch 'cons #'pprint-fill -2)
;; cons cells with interesting things for the car
(/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)
(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)
(defstruct pprint-block)
(etypecase pprint-typecase)
#+nil (handler-bind ...)
#+nil (handler-case ...)
- #+nil (loop ...)
- (multiple-value-bind pprint-progv)
+ (loop pprint-loop)
+ (multiple-value-bind pprint-prog2)
(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)
+ (prog2 pprint-prog2)
(psetf pprint-setq)
(psetq pprint-setq)
#+nil (restart-bind ...)
(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))
projects / sbcl.git / blobdiff