+
+(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)))))