X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=828227a2b42d9eed47f4fc7af9dbdd666bc3f328;hb=65aa68a4f6a671db80596f136dec549322b28ddd;hp=4f36a91e73856927a579c15d7022bd45acde9f60;hpb=d5ec4e5681e0dbe44b3fbd5f35df9f9bde5ee337;p=sbcl.git

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 4f36a91..828227a 100644
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -49,7 +49,12 @@
   #+sb-doc
   "Print a description of OBJECT to STREAM-DESIGNATOR."
   (let ((stream (out-synonym-of stream-designator))
-        (*print-right-margin* (or *print-right-margin* 72)))
+        (*print-right-margin* (or *print-right-margin* 72))
+        (*print-circle* t)
+        (*suppress-print-errors*
+          (if (subtypep 'serious-condition *suppress-print-errors*)
+              *suppress-print-errors*
+              'serious-condition)))
     ;; Until sbcl-0.8.0.x, we did
     ;;   (FRESH-LINE STREAM)
     ;;   (PPRINT-LOGICAL-BLOCK (STREAM NIL)
@@ -65,7 +70,8 @@
     ;; here. (The example method for DESCRIBE-OBJECT does its own
     ;; FRESH-LINEing, which is a physical directive which works poorly
     ;; inside a pretty-printer logical block.)
-    (describe-object object stream)
+    (handler-bind ((print-not-readable #'print-unreadably))
+      (describe-object object stream))
     ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
     ;; again ANSI's specification of DESCRIBE doesn't mention it and
     ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
@@ -249,7 +255,7 @@
                 (:alien "an alien variable"))))
     (when (or (not (eq :unknown kind)) (boundp symbol))
       (pprint-logical-block (stream nil)
-        (format stream "~%~A names ~A:" symbol wot)
+        (format stream "~@:_~A names ~A:" symbol wot)
         (pprint-indent :block 2 stream)
         (when (eq (info :variable :where-from symbol) :declared)
           (format stream "~@:_Declared type: ~S"
@@ -296,10 +302,10 @@
     (when fun
       (pprint-newline :mandatory stream)
       (pprint-logical-block (stream nil)
-        (pprint-indent :block 2 stream)
-        (format stream "~A names a ~@[primitive~* ~]type-specifier:"
+        (format stream "~@:_~A names a ~@[primitive~* ~]type-specifier:"
                 symbol
                 (eq kind :primitive))
+        (pprint-indent :block 2 stream)
         (describe-documentation symbol 'type stream (eq t fun))
         (unless (eq t fun)
           (describe-lambda-list (if (eq :primitive kind)
@@ -382,7 +388,7 @@
       (let ((metaclass-name (class-name (class-of class))))
         (pprint-logical-block (stream nil)
           (when by-name
-            (format stream "~%~A names the ~(~A~) ~S:"
+            (format stream "~@:_~A names the ~(~A~) ~S:"
                     name
                     metaclass-name
                     class)
@@ -441,6 +447,7 @@
                                             (quiet-doc slotd t)))
                                     slots))
                     (format stream "~@:_No direct slots."))))
+          (pprint-indent :block 0 stream)
           (pprint-newline :mandatory stream))))))
 
 (defun describe-instance (object stream)
@@ -634,7 +641,9 @@
                  (format stream "~&~A has a complex setf-expansion:"
                          name)
                  (pprint-indent :block 2 stream)
-                 (describe-documentation name2 'setf stream t))
+                 (describe-lambda-list (%fun-lambda-list expander) stream)
+                 (describe-documentation name2 'setf stream t)
+                 (describe-function-source expander stream))
                (terpri stream)))))
     (when (symbolp name)
       (describe-function `(setf ,name) nil stream))))