1.0.29.6: work around stack-allocated value cell badness in HANDLER-CASE

[sbcl.git] / src / code / pprint.lisp

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 8798367..9dd92d9 100644 (file)
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1238,6 +1238,13 @@ line break."
            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
@@ -1293,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~^ ~:_~}~:>")
@@ -1308,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")
@@ -1360,6 +1409,7 @@ line break."
                           (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)
@@ -1378,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)