X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=9dd92d99fbf6afaceddcfc78be29022d516e7c47;hb=f33fdd489e9012e5064d35ca7edc7d4bc3c4a0c2;hp=5f9e6a4e8d06ca17fbeca3e2da17040b76af862a;hpb=b841c32badc4627f390cc8ab71b17bc158e7c6b1;p=sbcl.git

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 5f9e6a4..9dd92d9 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1241,7 +1241,7 @@ line break."
 (defun pprint-defpackage (stream list &rest noise)
   (declare (ignore noise))
   (funcall  (formatter
-             "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>")
+             "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~^~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>")
             stream
             list))
 
@@ -1300,6 +1300,43 @@ line break."
     (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-loop (stream list &rest noise)
+  (declare (ignore noise))
+  (destructuring-bind (loop-symbol . clauses) list
+    (write-char #\( stream)
+    (output-object loop-symbol stream)
+    (when clauses
+      (write-char #\space stream)
+      (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))))
+    (write-char #\) stream)))
+
 (defun pprint-fun-call (stream list &rest noise)
   (declare (ignore noise))
   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>")
@@ -1315,8 +1352,13 @@ line break."
 ;;; 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 !pprint-cold-init ()
   (/show0 "entering !PPRINT-COLD-INIT")
@@ -1386,7 +1428,7 @@ line break."
                           (etypecase pprint-typecase)
                           #+nil (handler-bind ...)
                           #+nil (handler-case ...)
-                          #+nil (loop ...)
+                          (loop pprint-loop)
                           (multiple-value-bind pprint-progv)
                           (multiple-value-setq pprint-block)
                           (pprint-logical-block pprint-block)