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

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 74c368c..9dd92d9 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -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~^ ~:_~}~:>")
@@ -1391,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)