(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 ")")
(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-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 (null 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~^ ~:_~}~:>")
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
+;;; 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")
;; 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 mboundp)))
+ #'pprint-macro-call -1)
(set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
#'pprint-fun-call -1)
(set-pprint-dispatch '(cons symbol)
(/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)
+ (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))))
projects / sbcl.git / blobdiff