X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=787cd5300147f03da798edc8e1e15034865e12ae;hb=d442c23da9851beac541b8bddfc2c0837cb87309;hp=8d2de3bef95708fc6be5f8e2c67c1aea1bb1a8a2;hpb=e60c0fcde88bf21c3b9faffe8718d07c888b934a;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 8d2de3b..787cd53 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -707,15 +707,19 @@ (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) @@ -1157,6 +1161,11 @@ (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)) + (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) @@ -1234,6 +1243,13 @@ 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 @@ -1289,6 +1305,69 @@ (pprint-fill stream (pprint-pop)) (pprint-tagbody-guts stream))) +;;; Each clause in this list will get its own line. +(defvar *loop-seperating-clauses* + '(:and + :where :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-clauses (stream clauses) + (pprint-logical-block (stream clauses :prefix "" :suffix "") + (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-simple-loop-clauses (stream clauses) + (pprint-logical-block (stream clauses :prefix "" :suffix "") + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (loop for thing = (pprint-pop) do + (when (consp thing) + (pprint-newline :mandatory stream)) + (output-object thing stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream)))) + +(defun pprint-loop (stream list &rest noise) + (declare (ignore noise)) + (destructuring-bind (loop-symbol . clauses) list + (write-char #\( stream) + (output-object loop-symbol stream) + (cond ((null clauses)) + ((symbolp (car clauses)) + (write-char #\space stream) + (pprint-extended-loop-clauses stream clauses)) + (t + (write-char #\space stream) + (pprint-simple-loop-clauses stream clauses))) + (write-char #\) stream))) + +(defun pprint-if (stream list &rest noise) + (declare (ignore noise)) + ;; Indent after the ``predicate'' form, and the ``then'' form. + (funcall (formatter "~:<~^~W~^ ~:_~:I~W~^ ~:@_~:I~@{~W~^ ~:@_~}~:>") + stream + list)) + (defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>") @@ -1298,14 +1377,76 @@ (defun pprint-data-list (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") 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))))) ;;;; 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") @@ -1315,6 +1456,8 @@ ;; 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) @@ -1347,6 +1490,7 @@ (tagbody pprint-tagbody) (throw pprint-block) (unwind-protect pprint-block) + (if pprint-if) ;; macros (case pprint-case) @@ -1356,6 +1500,7 @@ (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) @@ -1374,15 +1519,15 @@ (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 ...)