;;; COLUMN - offset (if characters) from the start of the current line
;;; INDEX - index into the output buffer
;;; POSN - some position in the stream of characters cycling through
-;;; the output buffer
+;;; the output buffer
(deftype column ()
'(and fixnum unsigned-byte))
;;; The INDEX type is picked up from the kernel package.
(defconstant default-line-length 80)
(defstruct (pretty-stream (:include sb!kernel:ansi-stream
- (out #'pretty-out)
- (sout #'pretty-sout)
- (misc #'pretty-misc))
- (:constructor make-pretty-stream (target))
- (:copier nil))
+ (out #'pretty-out)
+ (sout #'pretty-sout)
+ (misc #'pretty-misc))
+ (:constructor make-pretty-stream (target))
+ (:copier nil))
;; Where the output is going to finally go.
(target (missing-arg) :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*
- (sb!impl::line-length target)
- default-line-length)
- :type column)
+ (sb!impl::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)
+ (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
;; 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
#!-sb-fluid (declaim (inline index-posn posn-index posn-column))
(defun index-posn (index stream)
(declare (type index index) (type pretty-stream stream)
- (values posn))
+ (values posn))
(+ index (pretty-stream-buffer-offset stream)))
(defun posn-index (posn stream)
(declare (type posn posn) (type pretty-stream stream)
- (values index))
+ (values index))
(- posn (pretty-stream-buffer-offset stream)))
(defun posn-column (posn stream)
(declare (type posn posn) (type pretty-stream stream)
- (values posn))
+ (values posn))
(index-column (posn-index posn stream) stream))
;;; Is it OK to do pretty printing on this stream at this time?
(defun pretty-out (stream char)
(declare (type pretty-stream stream)
- (type base-char char))
+ (type character char))
(cond ((char= char #\newline)
- (enqueue-newline stream :literal))
- (t
- (ensure-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))))))
+ (enqueue-newline stream :literal))
+ (t
+ (ensure-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))))
+ (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 (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)))
(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
- :section-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))))
+ (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
+ :section-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))
+ :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 (logical-block-suffix-length block) new-suffix-len))))
+ (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 (logical-block-suffix-length block) 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)))
+ (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))
+ (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))
(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)))
+ (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)))
+ :start old-indent :end new-indent)))
nil)
\f
;;;; the pending operation queue
(defstruct (queued-op (:constructor nil)
- (:copier nil))
+ (:copier nil))
(posn 0 :type posn))
(defmacro enqueue (stream type &rest args)
(let ((constructor (symbolicate "MAKE-" type)))
(once-only ((stream stream)
- (entry `(,constructor :posn
- (index-posn
- (pretty-stream-buffer-fill-pointer
- ,stream)
- ,stream)
- ,@args))
- (op `(list ,entry))
- (head `(pretty-stream-queue-head ,stream)))
+ (entry `(,constructor :posn
+ (index-posn
+ (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))))
+ (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)
- (:constructor nil)
- (:copier nil))
+ (:constructor nil)
+ (:copier nil))
(depth 0 :type index)
(section-end nil :type (or null newline block-end)))
(defstruct (newline (:include section-start)
- (:copier nil))
+ (:copier nil))
(kind (missing-arg)
- :type (member :linear :fill :miser :literal :mandatory)))
+ :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)))
+ (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))))
+ (section-start-p entry)
+ (null (section-start-section-end entry))
+ (<= depth (section-start-depth entry)))
+ (setf (section-start-section-end entry) newline))))
(maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
(defstruct (indentation (:include queued-op)
- (:copier nil))
+ (:copier nil))
(kind (missing-arg) :type (member :block :current))
(amount 0 :type fixnum))
(enqueue stream indentation :kind kind :amount amount))
(defstruct (block-start (:include section-start)
- (:copier nil))
+ (:copier nil))
(block-end nil :type (or null block-end))
(prefix nil :type (or null simple-string))
(suffix nil :type (or null simple-string)))
;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
;; and might end up being NIL.)
- (declare (type (or null string prefix)))
+ (declare (type (or null string) prefix))
;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
;; trivial, so it should always be a string.)
(declare (type string suffix))
(when prefix
+ (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 suffix
- :depth (length pending-blocks))))
+ (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))))
+ (cons start pending-blocks))))
(defstruct (block-end (:include queued-op)
- (:copier nil))
+ (:copier nil))
(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)))
+ (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)))
(defstruct (tab (:include queued-op)
- (:copier nil))
+ (:copier nil))
(sectionp nil :type (member t nil))
(relativep nil :type (member t nil))
(colnum 0 :type column)
(defun enqueue-tab (stream kind colnum colinc)
(multiple-value-bind (sectionp relativep)
(ecase kind
- (:line (values nil nil))
- (:line-relative (values nil t))
- (:section (values t nil))
- (:section-relative (values t t)))
+ (:line (values nil nil))
+ (:line-relative (values nil t))
+ (:section (values t nil))
+ (:section-relative (values t t)))
(enqueue stream tab :sectionp sectionp :relativep relativep
- :colnum colnum :colinc colinc)))
+ :colnum colnum :colinc colinc)))
\f
;;;; tab support
(defun compute-tab-size (tab section-start column)
- (let ((origin (if (tab-sectionp tab) section-start 0))
- (colnum (tab-colnum tab))
- (colinc (tab-colinc tab)))
+ (let* ((origin (if (tab-sectionp tab) section-start 0))
+ (colnum (tab-colnum tab))
+ (colinc (tab-colinc tab))
+ (position (- column origin)))
(cond ((tab-relativep tab)
- (unless (<= colinc 1)
- (let ((newposn (+ column colnum)))
- (let ((rem (rem newposn colinc)))
- (unless (zerop rem)
- (incf colnum (- colinc rem))))))
- colnum)
- ((<= column (+ colnum origin))
- (- (+ colnum origin) column))
- (t
- (- colinc
- (rem (- column origin) colinc))))))
+ (unless (<= colinc 1)
+ (let ((newposn (+ position colnum)))
+ (let ((rem (rem newposn colinc)))
+ (unless (zerop rem)
+ (incf colnum (- colinc rem))))))
+ colnum)
+ ((< position colnum)
+ (- colnum position))
+ ((zerop colinc) 0)
+ (t
+ (- colinc
+ (rem (- position colnum) colinc))))))
(defun index-column (index stream)
(let ((column (pretty-stream-buffer-start-column stream))
- (section-start (logical-block-section-column
- (first (pretty-stream-blocks stream))))
- (end-posn (index-posn index stream)))
+ (section-start (logical-block-section-column
+ (first (pretty-stream-blocks stream))))
+ (end-posn (index-posn index stream)))
(dolist (op (pretty-stream-queue-tail stream))
(when (>= (queued-op-posn op) end-posn)
- (return))
+ (return))
(typecase op
- (tab
- (incf column
- (compute-tab-size op
- section-start
- (+ column
- (posn-index (tab-posn op)
- stream)))))
- ((or newline block-start)
- (setf section-start
- (+ column (posn-index (queued-op-posn op)
- stream))))))
+ (tab
+ (incf column
+ (compute-tab-size op
+ section-start
+ (+ column
+ (posn-index (tab-posn op)
+ stream)))))
+ ((or newline block-start)
+ (setf section-start
+ (+ column (posn-index (queued-op-posn op)
+ stream))))))
(+ column index)))
(defun expand-tabs (stream through)
(let ((insertions nil)
- (additional 0)
- (column (pretty-stream-buffer-start-column stream))
- (section-start (logical-block-section-column
- (first (pretty-stream-blocks stream)))))
+ (additional 0)
+ (column (pretty-stream-buffer-start-column stream))
+ (section-start (logical-block-section-column
+ (first (pretty-stream-blocks stream)))))
(dolist (op (pretty-stream-queue-tail stream))
(typecase op
- (tab
- (let* ((index (posn-index (tab-posn op) stream))
- (tabsize (compute-tab-size op
- section-start
- (+ column index))))
- (unless (zerop tabsize)
- (push (cons index tabsize) insertions)
- (incf additional tabsize)
- (incf column tabsize))))
- ((or newline block-start)
- (setf section-start
- (+ column (posn-index (queued-op-posn op) stream)))))
+ (tab
+ (let* ((index (posn-index (tab-posn op) stream))
+ (tabsize (compute-tab-size op
+ section-start
+ (+ column index))))
+ (unless (zerop tabsize)
+ (push (cons index tabsize) insertions)
+ (incf additional tabsize)
+ (incf column tabsize))))
+ ((or newline block-start)
+ (setf section-start
+ (+ column (posn-index (queued-op-posn op) stream)))))
(when (eq op through)
- (return)))
+ (return)))
(when insertions
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
- (new-fill-ptr (+ fill-ptr additional))
- (buffer (pretty-stream-buffer stream))
- (new-buffer buffer)
- (length (length buffer))
- (end fill-ptr))
- (when (> new-fill-ptr length)
- (let ((new-length (max (* length 2)
- (+ fill-ptr
- (floor (* additional 5) 4)))))
- (setf new-buffer (make-string new-length))
- (setf (pretty-stream-buffer stream) new-buffer)))
- (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
- (decf (pretty-stream-buffer-offset stream) additional)
- (dolist (insertion insertions)
- (let* ((srcpos (car insertion))
- (amount (cdr insertion))
- (dstpos (+ srcpos additional)))
- (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
- (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
- (decf additional amount)
- (setf end srcpos)))
- (unless (eq new-buffer buffer)
- (replace new-buffer buffer :end1 end :end2 end))))))
+ (new-fill-ptr (+ fill-ptr additional))
+ (buffer (pretty-stream-buffer stream))
+ (new-buffer buffer)
+ (length (length buffer))
+ (end fill-ptr))
+ (when (> new-fill-ptr length)
+ (let ((new-length (max (* length 2)
+ (+ fill-ptr
+ (floor (* additional 5) 4)))))
+ (setf new-buffer (make-string new-length))
+ (setf (pretty-stream-buffer stream) new-buffer)))
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (decf (pretty-stream-buffer-offset stream) additional)
+ (dolist (insertion insertions)
+ (let* ((srcpos (car insertion))
+ (amount (cdr insertion))
+ (dstpos (+ srcpos additional)))
+ (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
+ (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
+ (decf additional amount)
+ (setf end srcpos)))
+ (unless (eq new-buffer buffer)
+ (replace new-buffer buffer :end1 end :end2 end))))))
\f
;;;; stuff to do the actual outputting
(defun ensure-space-in-buffer (stream want)
(declare (type pretty-stream stream)
- (type index want))
+ (type index want))
(let* ((buffer (pretty-stream-buffer stream))
- (length (length buffer))
- (fill-ptr (pretty-stream-buffer-fill-pointer stream))
- (available (- length fill-ptr)))
+ (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))
- (unless (maybe-output stream nil)
- (output-partial-line stream))
- (ensure-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))))))
+ available)
+ ((> fill-ptr (pretty-stream-line-length stream))
+ (unless (maybe-output stream nil)
+ (output-partial-line stream))
+ (ensure-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 maybe-output (stream force-newlines-p)
(declare (type pretty-stream stream))
(let ((tail (pretty-stream-queue-tail stream))
- (output-anything nil))
+ (output-anything nil))
(loop
(unless tail
- (setf (pretty-stream-queue-head stream) nil)
- (return))
+ (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))))))
- (setf output-anything t)
- (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
- (posn-column
- (indentation-posn 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.
- (let ((end (block-start-block-end next)))
- (expand-tabs stream end)
- (setf tail (cdr (member end tail)))))
- ((nil)
- (really-start-logical-block
- stream
- (posn-column (block-start-posn next) stream)
- (block-start-prefix next)
- (block-start-suffix next)))
- (:dont-know
- (return))))
- (block-end
- (really-end-logical-block stream))
- (tab
- (expand-tabs stream next))))
+ (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))))))
+ (setf output-anything t)
+ (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
+ (posn-column
+ (indentation-posn 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.
+ (let ((end (block-start-block-end next)))
+ (expand-tabs stream end)
+ (setf tail (cdr (member end tail)))))
+ ((nil)
+ (really-start-logical-block
+ stream
+ (posn-column (block-start-posn next) stream)
+ (block-start-prefix next)
+ (block-start-suffix next)))
+ (:dont-know
+ (return))))
+ (block-end
+ (really-end-logical-block stream))
+ (tab
+ (expand-tabs stream next))))
(setf (pretty-stream-queue-tail stream) tail))
output-anything))
(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*)))
+ (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 (not *print-readably*)
- (pretty-stream-print-lines stream)
- (= (pretty-stream-print-lines stream)
- (pretty-stream-line-number stream)))
+ (pretty-stream-print-lines stream)
+ (= (pretty-stream-print-lines stream)
+ (pretty-stream-line-number stream)))
(decf available 3) ; for the `` ..''
(decf available (logical-block-suffix-length
- (car (pretty-stream-blocks stream)))))
+ (car (pretty-stream-blocks stream)))))
(cond (until
- (<= (posn-column (queued-op-posn until) stream) available))
- (force-newlines-p nil)
- ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
- available)
- nil)
- (t
- :dont-know))))
+ (<= (posn-column (queued-op-posn 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))
+ (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 (posn-index (newline-posn 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)))))
+ (buffer (pretty-stream-buffer stream))
+ (kind (newline-kind until))
+ (literal-p (eq kind :literal))
+ (amount-to-consume (posn-index (newline-posn 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)))
(incf line-number)
(when (and (not *print-readably*)
- (pretty-stream-print-lines stream)
- (>= line-number (pretty-stream-print-lines stream)))
- (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))
+ (pretty-stream-print-lines stream)
+ (>= line-number (pretty-stream-print-lines stream)))
+ (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))
(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 (first (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))
- (new-fill-ptr (- fill-ptr shift))
- (new-buffer buffer)
- (buffer-length (length buffer)))
- (when (> new-fill-ptr buffer-length)
- (setf new-buffer
- (make-string (max (* buffer-length 2)
- (+ buffer-length
- (floor (* (- new-fill-ptr buffer-length)
- 5)
- 4)))))
- (setf (pretty-stream-buffer stream) new-buffer))
- (replace new-buffer buffer
- :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
- (replace new-buffer (pretty-stream-prefix stream)
- :end1 prefix-len)
- (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
- (incf (pretty-stream-buffer-offset stream) shift)
- (unless literal-p
- (setf (logical-block-section-column block) prefix-len)
- (setf (logical-block-section-start-line block) line-number))))))
+ (block (first (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))
+ (new-fill-ptr (- fill-ptr shift))
+ (new-buffer buffer)
+ (buffer-length (length buffer)))
+ (when (> new-fill-ptr buffer-length)
+ (setf new-buffer
+ (make-string (max (* buffer-length 2)
+ (+ buffer-length
+ (floor (* (- new-fill-ptr buffer-length)
+ 5)
+ 4)))))
+ (setf (pretty-stream-buffer stream) new-buffer))
+ (replace new-buffer buffer
+ :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ (replace new-buffer (pretty-stream-prefix stream)
+ :end1 prefix-len)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) shift)
+ (unless literal-p
+ (setf (logical-block-section-column block) prefix-len)
+ (setf (logical-block-section-start-line block) line-number))))))
(defun output-partial-line (stream)
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
- (tail (pretty-stream-queue-tail stream))
- (count
- (if tail
- (posn-index (queued-op-posn (car tail)) stream)
- fill-ptr))
- (new-fill-ptr (- fill-ptr count))
- (buffer (pretty-stream-buffer stream)))
+ (tail (pretty-stream-queue-tail stream))
+ (count
+ (if tail
+ (posn-index (queued-op-posn (car tail)) stream)
+ fill-ptr))
+ (new-fill-ptr (- fill-ptr count))
+ (buffer (pretty-stream-buffer stream)))
(when (zerop count)
(error "Output-partial-line called when nothing can be output."))
(write-string buffer (pretty-stream-target stream)
- :start 0 :end count)
+ :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)
(maybe-output stream nil)
(expand-tabs stream nil)
(write-string (pretty-stream-buffer stream)
- (pretty-stream-target stream)
- :end (pretty-stream-buffer-fill-pointer stream)))
+ (pretty-stream-target stream)
+ :end (pretty-stream-buffer-fill-pointer stream)))
\f
;;;; user interface to the pretty printer
*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.
+ containing section cannot be printed on one line.
:MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
- (See *PRINT-MISER-WIDTH*.)
+ (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,
+ 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.
+ 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))
+ (type (or stream (member t nil)) stream)
+ (values null))
(let ((stream (case stream
- ((t) *terminal-io*)
- ((nil) *standard-output*)
- (t stream))))
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
(when (print-pretty-on-stream-p stream)
(enqueue-newline stream kind)))
nil)
#!+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 indention
+ 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.
+ started on.
:CURRENT - Indent relative to the current column.
- The new indention value does not take effect until the following line
+ The new indentation 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))
+ (type real n)
+ (type (or stream (member t nil)) stream)
+ (values null))
(let ((stream (case stream
- ((t) *terminal-io*)
- ((nil) *standard-output*)
- (t stream))))
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
(when (print-pretty-on-stream-p stream)
- (enqueue-indent stream relative-to n)))
+ (enqueue-indent stream relative-to (truncate n))))
nil)
(defun pprint-tab (kind colnum colinc &optional stream)
: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))
+ (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))))
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
(when (print-pretty-on-stream-p stream)
(enqueue-tab stream kind colnum colinc)))
nil)
can be used with the ~/.../ format directive."
(declare (ignore atsign?))
(pprint-logical-block (stream list
- :prefix (if colon? "(" "")
- :suffix (if colon? ")" ""))
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(output-object (pprint-pop) stream)
can be used with the ~/.../ format directive."
(declare (ignore atsign?))
(pprint-logical-block (stream list
- :prefix (if colon? "(" "")
- :suffix (if colon? ")" ""))
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(output-object (pprint-pop) stream)
the ~/.../ format directive."
(declare (ignore atsign?))
(pprint-logical-block (stream list
- :prefix (if colon? "(" "")
- :suffix (if colon? ")" ""))
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
(pprint-exit-if-list-exhausted)
(loop
(output-object (pprint-pop) stream)
;; T iff one of the original entries.
(initial-p *building-initial-table* :type (member t nil))
;; and the associated function
- (fun (missing-arg) :type function))
+ (fun (missing-arg) :type callable))
(def!method print-object ((entry pprint-dispatch-entry) stream)
(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 (:copier nil))
- ;; 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)))
-(def!method print-object ((table pprint-dispatch-table) stream)
- (print-unreadable-object (table stream :type t :identity t)))
+ (pprint-dispatch-entry-type entry)
+ (pprint-dispatch-entry-priority entry)
+ (pprint-dispatch-entry-initial-p entry))))
(defun cons-type-specifier-p (spec)
(and (consp spec)
(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))))))
+ (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)
+ (< (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)))))
+ nil
+ (< (pprint-dispatch-entry-priority e1)
+ (pprint-dispatch-entry-priority e2)))))
(macrolet ((frob (x)
- `(cons ',x (lambda (object) ,x))))
+ `(cons ',x (lambda (object) ,x))))
(defvar *precompiled-pprint-dispatch-funs*
(list (frob (typep object 'array))
- (frob (and (consp object)
- (and (typep (car object) 'symbol)
- (typep (car object) '(satisfies fboundp)))))
- (frob (typep object 'cons)))))
+ (frob (and (consp object)
+ (symbolp (car object))
+ (fboundp (car object))))
+ (frob (typep object 'cons)))))
(defun compute-test-fn (type)
(let ((was-cons nil))
(labels ((compute-test-expr (type object)
- (if (listp type)
- (case (car type)
- (cons
- (setq was-cons t)
- (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))))
+ (if (listp type)
+ (case (car type)
+ (cons
+ (setq was-cons t)
+ (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))))
(let ((expr (compute-test-expr type 'object)))
- (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
- :test #'equal)))
- (t
- (compile nil `(lambda (object) ,expr))))))))
+ (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
+ :test #'equal)))
+ (t
+ (compile nil `(lambda (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*))
- (new (make-pprint-dispatch-table
- :entries (copy-list (pprint-dispatch-table-entries orig))))
- (new-cons-entries (pprint-dispatch-table-cons-entries new)))
+ (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))
+ (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)))))
+ (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-fun entry) t)
- (values (lambda (stream object)
- (output-ugly-object object stream))
- nil))))
+ (values (pprint-dispatch-entry-fun 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))
+ (priority 0) (table *print-pprint-dispatch*))
+ (declare (type (or null callable) function)
+ (type real priority)
+ (type pprint-dispatch-table table))
+ (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
+ (/hexstr type)
(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
- :fun 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
- :fun 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)))
+ (setf (gethash (second (second type))
+ (pprint-dispatch-table-cons-entries table))
+ (make-pprint-dispatch-entry :type type
+ :priority priority
+ :fun 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
+ :fun 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))))
+ (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))))
+ (/show0 "about to return NIL from SET-PPRINT-DISPATCH")
nil)
\f
;;;; 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 'print-not-readable :object array)))
- ((vectorp array)
- (pprint-vector stream array))
- (t
- (pprint-multi-dim-array stream array))))
+ (stringp array)
+ (bit-vector-p array))
+ (output-ugly-object array stream))
+ ((and *print-readably*
+ (not (array-readably-printable-p array)))
+ (let ((*print-readably* nil))
+ (error 'print-not-readable :object array)))
+ ((vectorp array)
+ (pprint-vector stream array))
+ (t
+ (pprint-multi-dim-array stream array))))
(defun pprint-vector (stream vector)
(pprint-logical-block (stream nil :prefix "#(" :suffix ")")
(dotimes (i (length vector))
(unless (zerop i)
- (format stream " ~:_"))
+ (format stream " ~:_"))
(pprint-pop)
(output-object (aref vector i) stream))))
(with-array-data ((data array) (start) (end))
(declare (ignore end))
(labels ((output-guts (stream index dimensions)
- (if (null dimensions)
- (output-object (aref 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)))))))))
+ (if (null dimensions)
+ (output-object (aref 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))
+ (when (and (consp lambda-list)
+ (member (car lambda-list) *backq-tokens*))
+ ;; if this thing looks like a backquoty thing, then we don't want
+ ;; to destructure it, we want to output it straight away. [ this
+ ;; is the exception to the normal processing: if we did this
+ ;; generally we would find lambda lists such as (FUNCTION FOO)
+ ;; being printed as #'FOO ] -- CSR, 2003-12-07
+ (output-object lambda-list stream)
+ (return-from pprint-lambda-list nil))
(pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
(let ((state :required)
- (first t))
+ (first t))
(loop
- (pprint-exit-if-list-exhausted)
- (unless first
- (write-char #\space stream))
- (let ((arg (pprint-pop)))
- (unless first
- (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)))))
+ (pprint-exit-if-list-exhausted)
+ (unless first
+ (write-char #\space stream))
+ (let ((arg (pprint-pop)))
+ (unless first
+ (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
- ;; KLUDGE: This format string, and other format strings which also
- ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
- ;; behavior of FORMATTER in order to make code which survives the
- ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
- ;; init. (ANSI says that the FORMATTER functions should be
- ;; equivalent to the format string, but the SBCL FORMATTER
- ;; functions contain references to package objects, not package
- ;; names, so they keep right on going if the packages are renamed.)
- ;; If our FORMATTER behavior is ever made more compliant, the code
- ;; here will have to change. -- WHN 19991207
- "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
- stream
- list))
+ ;; KLUDGE: This format string, and other format strings which also
+ ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
+ ;; behavior of FORMATTER in order to make code which survives the
+ ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
+ ;; init. (ANSI says that the FORMATTER functions should be
+ ;; equivalent to the format string, but the SBCL FORMATTER
+ ;; functions contain references to package objects, not package
+ ;; names, so they keep right on going if the packages are renamed.)
+ ;; If our FORMATTER behavior is ever made more compliant, the code
+ ;; here will have to change. -- WHN 19991207
+ "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+ stream
+ list))
(defun pprint-block (stream list &rest noise)
(declare (ignore noise))
(defun pprint-flet (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter
- "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
- stream
- list))
+ (if (and (consp list)
+ (consp (cdr list))
+ (cddr list))
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
+ stream
+ list)
+ ;; for printing function names like (flet foo)
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (write (pprint-pop) :stream stream)
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (write (pprint-pop) :stream stream)))))
(defun pprint-let (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
- stream
- list))
+ stream
+ list))
(defun pprint-progn (stream list &rest noise)
(declare (ignore noise))
(defun pprint-progv (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
- stream list))
+ stream list))
(defun pprint-quote (stream list &rest noise)
(declare (ignore noise))
(if (and (consp list)
- (consp (cdr list))
- (null (cddr 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)))
+ (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)
(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)))))
+ (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)))))
;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
(defmacro pprint-tagbody-guts (stream)
(write-char #\space ,stream)
(let ((form-or-tag (pprint-pop)))
(pprint-indent :block
- (if (atom form-or-tag) 0 1)
- ,stream)
+ (if (atom form-or-tag) 0 1)
+ ,stream)
(pprint-newline :linear ,stream)
(output-object form-or-tag ,stream))))
(defun pprint-case (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter
- "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
- stream
- list))
+ "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
+ stream
+ list))
(defun pprint-defun (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter
- "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
- stream
- list))
+ "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+ stream
+ list))
(defun pprint-destructuring-bind (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter
- "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
- stream list))
+ "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
+ stream list))
(defun pprint-do (stream list &rest noise)
(declare (ignore noise))
(write-char #\space stream)
(pprint-indent :current 0 stream)
(funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
- stream
- (pprint-pop))
+ stream
+ (pprint-pop))
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
(pprint-newline :linear stream)
(write-char #\space stream)
(pprint-newline :fill stream)
(funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
- stream
- (pprint-pop))
+ 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))
+ "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
+ stream
+ list))
(defun pprint-prog (stream list &rest noise)
(declare (ignore noise))
(defun pprint-fun-call (stream list &rest noise)
(declare (ignore noise))
(funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
- stream
- list))
+ stream
+ list))
\f
;;;; the interface seen by regular (ugly) printer and initialization routines
(/show0 "entering !PPRINT-COLD-INIT")
(setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
(let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
- (*building-initial-table* t))
+ (*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 (and symbol (satisfies fboundp)))
- #'pprint-fun-call -1)
+ (set-pprint-dispatch '(cons symbol)
+ #'pprint-fun-call -1)
(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)
- ;; special forms
- (block pprint-block)
- (catch pprint-block)
- (eval-when pprint-block)
- (flet pprint-flet)
- (function pprint-quote)
- (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)
-
- ;; macros
- (case pprint-case)
- (ccase pprint-case)
- (ctypecase pprint-typecase)
- (defconstant pprint-block)
- (define-modify-macro pprint-defun)
- (define-setf-expander 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)))
+ ;; special forms
+ (block pprint-block)
+ (catch pprint-block)
+ (eval-when pprint-block)
+ (flet pprint-flet)
+ (function pprint-quote)
+ (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)
+
+ ;; macros
+ (case pprint-case)
+ (ccase pprint-case)
+ (ctypecase pprint-typecase)
+ (defconstant pprint-block)
+ (define-modify-macro pprint-defun)
+ (define-setf-expander 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)))
(set-pprint-dispatch `(cons (eql ,(first magic-form)))
- (symbol-function (second magic-form))))
+ (symbol-function (second magic-form))))
;; other pretty-print init forms
(/show0 "about to call !BACKQ-PP-COLD-INIT")
(/show0 "leaving !PPRINT-COLD-INIT"))
(setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
- (setf *pretty-printer* #'output-pretty-object)
(setf *print-pretty* t))
projects / sbcl.git / blobdiff