X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=8f64b6ae1dbdf5c5251a4380417a4a890ef4a687;hb=0c08cc954cc0910079bdcf153cccf9a95ef11d67;hp=4f36a91e73856927a579c15d7022bd45acde9f60;hpb=d5ec4e5681e0dbe44b3fbd5f35df9f9bde5ee337;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 4f36a91..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) @@ -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" @@ -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))) @@ -296,18 +302,21 @@ (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) (%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*) @@ -382,7 +391,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 +450,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) @@ -494,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) @@ -535,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)))) @@ -547,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 @@ -555,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" @@ -584,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 @@ -634,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))))