X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=8f64b6ae1dbdf5c5251a4380417a4a890ef4a687;hb=0c08cc954cc0910079bdcf153cccf9a95ef11d67;hp=8c7802fabd245f922dcf13baf46579850ce0326b;hpb=43a526583b7015e6b9945d16e31da72fda1325f5;p=sbcl.git

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 8c7802f..8f64b6a 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.
@@ -198,8 +204,8 @@
 
 (defmethod describe-object ((x character) s)
   (print-standard-describe-header x s)
-  (format s "~%:_Char-code: ~S" (char-code x))
-  (format s "~%:_Char-name: ~A~%_" (char-name x)))
+  (format s "~%Char-code: ~S" (char-code x))
+  (format s "~%Char-name: ~A" (char-name x)))
 
 (defmethod describe-object ((x array) s)
   (print-standard-describe-header x s)
@@ -264,7 +270,7 @@
                      (sb-alien-internals:unparse-alien-type
                       (sb-alien::heap-alien-info-type info)))
              (format stream "~@:_Address: #x~8,'0X"
-                     (sap-int (eval (sb-alien::heap-alien-info-sap-form info))))))
+                     (sap-int (sb-alien::heap-alien-info-sap info)))))
           ((eq kind :macro)
            (let ((expansion (info :variable :macro-expansion symbol)))
              (format stream "~@:_Expansion: ~S" expansion)))
@@ -306,8 +312,11 @@
                                     (%fun-lambda-list fun)
                                     (info :type :lambda-list symbol))
                                 stream)
-          (when (eq (%fun-fun fun) (%fun-fun (constant-type-expander t)))
-            (format stream "~@:_Expansion: ~S" (funcall fun (list symbol))))))
+          (multiple-value-bind (expansion ok)
+              (handler-case (typexpand-1 symbol)
+                (error () (values nil nil)))
+            (when ok
+              (format stream "~@:_Expansion: ~S" expansion)))))
       (terpri stream)))
 
   (when (or (member symbol sb-c::*policy-qualities*)
@@ -495,7 +504,10 @@
         (format stream "~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list))))
 
 (defun describe-lambda-list (lambda-list stream)
-  (format stream "~@:_Lambda-list: ~:A" lambda-list))
+  (let ((*print-circle* nil)
+        (*print-level* 24)
+        (*print-length* 24))
+    (format stream "~@:_Lambda-list: ~:A" lambda-list)))
 
 (defun describe-function-source (function stream)
   (if (compiled-function-p function)
@@ -536,8 +548,7 @@
                         from
                         (type-specifier (info :function :type name)))))))
         ;; Defined.
-        (multiple-value-bind (fun what lambda-list ftype from inline
-                                  methods)
+        (multiple-value-bind (fun what lambda-list ftype from inline methods)
             (cond ((and (not function) (symbolp name) (special-operator-p name))
                    (let ((fun (symbol-function name)))
                      (values fun "a special operator" (%fun-lambda-list fun))))
@@ -548,7 +559,7 @@
                    (let ((fun (or function (fdefinition name))))
                      (multiple-value-bind (ftype from)
                          (if function
-                             (values (%fun-type function) "Derived")
+                             (values (%fun-type function) :derived)
                              (let ((ctype (info :function :type name)))
                                (values (when ctype (type-specifier ctype))
                                        (when ctype
@@ -556,9 +567,9 @@
                                          ;; from methods.
                                          (sb-c::maybe-update-info-for-gf name)
                                          (ecase (info :function :where-from name)
-                                           (:declared "Declared")
+                                           (:declared :declared)
                                            ;; This is hopefully clearer to users
-                                           ((:defined-method :defined) "Derived"))))))
+                                           ((:defined-method :defined) :derived))))))
                        (if (typep fun 'generic-function)
                            (values fun
                                    "a generic function"
@@ -585,12 +596,19 @@
               (pprint-indent :block 2 stream))
             (describe-lambda-list lambda-list stream)
             (when (and ftype from)
-              (format stream "~@:_~A type: ~S" from ftype))
+              (format stream "~@:_~:(~A~) type: ~S" from ftype))
+            (when (eq :declared from)
+              (let ((derived-ftype (%fun-type fun)))
+                (unless (equal derived-ftype ftype)
+                  (format stream "~@:_Derived type: ~S" derived-ftype))))
             (describe-documentation name 'function stream)
             (when (car inline)
               (format stream "~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
                       (car inline)
                       (cdr inline)))
+            (awhen (info :function :info name)
+              (awhen (sb-c::decode-ir1-attributes (sb-c::fun-info-attributes it))
+                  (format stream "~@:_Known attributes: ~(~{~A~^, ~}~)" it)))
             (when methods
               (format stream "~@:_Method-combination: ~S"
                       (sb-pcl::method-combination-type-name
@@ -635,7 +653,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))))