X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=47a8af252ede7e679fc5b5d7bd20accbac788f86;hb=f22ad70037030c07074327cf239bd84dc17b44b6;hp=814a1b9938e500cddcb976d647eb81a9f3ec7242;hpb=4d5c5d322dcca0753474496cde44a9dbfe627496;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 814a1b9..47a8af2 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -1,4 +1,4 @@ -;;;; most of the DESCRIBE mechanism -- that part which isn't derived +;;;; most of the DESCRIBE system -- that part which isn't derived ;;;; from PCL code ;;;; This software is part of the SBCL system. See the README file for @@ -12,32 +12,44 @@ (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) -(defvar *describe-indentation-step* 3 - #+sb-doc - "the number of spaces that sets off each line of a recursive description") - (declaim (ftype (function (t stream)) describe-object)) -(defgeneric describe-object ((x t) stream)) +(defgeneric describe-object (x stream)) (defun describe (x &optional (stream-designator *standard-output*)) #+sb-doc "Print a description of the object X." (let ((stream (out-synonym-of stream-designator))) - (pprint-logical-block (stream nil) - (fresh-line stream) - (describe-object x stream) - (fresh-line stream))) + ;; Until sbcl-0.8.0.x, we did + ;; (FRESH-LINE STREAM) + ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL) + ;; ... + ;; here. However, ANSI's specification of DEFUN DESCRIBE, + ;; DESCRIBE exists as an interface primarily to manage argument + ;; defaulting (including conversion of arguments T and NIL into + ;; stream objects) and to inhibit any return values from + ;; DESCRIBE-OBJECT. + ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing, + ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's + ;; specification of DESCRIBE-OBJECT will work poorly if we do them + ;; 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 x 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. + ) (values)) ;;;; miscellaneous DESCRIBE-OBJECT methods (defmethod describe-object ((x t) s) - (format s "~@<~S ~_is a ~S.~:>" x (type-of x))) + (format s "~&~@<~S ~_is a ~S.~:>~%" x (type-of x))) (defmethod describe-object ((x cons) s) (call-next-method) (when (and (legal-fun-name-p x) - (fboundp x)) + (fboundp x)) (%describe-fun (fdefinition x) s :function x) ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x)) ;; TO DO: should check for SETF documentation. @@ -46,53 +58,59 @@ )) (defmethod describe-object ((x array) s) - (let ((rank (array-rank x))) - (cond ((> rank 1) - (format s "~S ~_is " x) - (write-string (if (%array-displaced-p x) "a displaced" "an") s) - (format s " array of rank ~S." rank) - (format s "~@:_Its dimensions are ~S." (array-dimensions x))) - (t - (format s - "~@:_~S is a ~:[~;displaced ~]vector of length ~S." x - (and (array-header-p x) (%array-displaced-p x)) (length x)) - (when (array-has-fill-pointer-p x) - (format s "~@:_It has a fill pointer, currently ~S." - (fill-pointer x)))))) - (let ((array-element-type (array-element-type x))) - (unless (eq array-element-type t) - (format s - "~@:_Its element type is specialized to ~S." - array-element-type)))) + (fresh-line s) + (pprint-logical-block (s nil) + (cond + ((= 1 (array-rank x)) + (format s "~S is a vector with ~D elements." + x (car (array-dimensions x))) + (when (array-has-fill-pointer-p x) + (format s "~@:_It has a fill pointer value of ~S." + (fill-pointer x)))) + (t + (format s "~S is an array of dimension ~:S." + x (array-dimensions x)))) + (let ((array-element-type (array-element-type x))) + (unless (eq array-element-type t) + (format s + "~@:_Its element type is specialized to ~S." + array-element-type))) + (if (and (array-header-p x) (%array-displaced-p x)) + (format s "~@:_The array is displaced with offset ~S." + (%array-displacement x)))) + (terpri s)) (defmethod describe-object ((x hash-table) s) (declare (type stream s)) - (format s "~@<~S ~_is an ~S hash table.~:>" x (hash-table-test x)) - (format s "~_Its SIZE is ~S." (hash-table-size x)) + (format s "~&~@<~S ~_is an ~S hash table.~:>" x (hash-table-test x)) + (format s "~&Its SIZE is ~S." (hash-table-size x)) (format s - "~@:_~@" - (hash-table-rehash-size x) - (hash-table-rehash-threshold x)) - (let ((count (hash-table-count x))) - (format s "~@:_It holds ~S key/value pair~:P~:[: ~2I~_~;.~]" - count (zerop count)) - (let ((n 0)) - (declare (type index n)) - (dohash (k v x) - (unless (zerop n) - (write-char #\space s)) - (incf n) - (when (and *print-length* (> n *print-length*)) - (format s "~:_...") - (return)) - (format s "~:_(~@<~S ~:_~S~:>)" k v))))) + "~&~@" + (hash-table-rehash-size x) + (hash-table-rehash-threshold x)) + (fresh-line s) + (pprint-logical-block (s nil) + (let ((count (hash-table-count x))) + (format s "It holds ~S key/value pair~:P~:[: ~2I~_~;.~]" + count (zerop count)) + (let ((n 0)) + (declare (type index n)) + (dohash ((k v) x :locked t) + (unless (zerop n) + (write-char #\space s)) + (incf n) + (when (and *print-length* (> n *print-length*)) + (format s "~:_...") + (return)) + (format s "~:_(~@<~S ~:_~S~:>)" k v))))) + (terpri s)) (defmethod describe-object ((condition condition) s) (sb-kernel:describe-condition condition s)) ;;;; DESCRIBE-OBJECT methods for symbols and functions, including all ;;;; sorts of messy stuff about documentation, type information, -;;;; packaging, function implementation, etc.. +;;;; packaging, function implementation, etc... ;;; Print the specified kind of documentation about the given NAME. If ;;; NAME is null, or not a valid name, then don't print anything. @@ -101,8 +119,8 @@ (when (and name (typep name '(or symbol cons))) (let ((doc (fdocumentation name kind))) (when doc - (format s "~_~@(~A documentation:~)~@:_ ~A" - (or kind-doc kind) doc)))) + (format s "~&~@(~A documentation:~)~% ~A" + (or kind-doc kind) doc)))) (values)) ;;; Describe various stuff about the functional semantics attached to @@ -111,23 +129,23 @@ ;;; things, it might not be.) TYPE-SPEC is the function type specifier ;;; extracted from the definition, or NIL if none. (declaim (ftype (function (t stream t)) %describe-fun-name)) -(defun %describe-fun-name (name s type-spec) +(defun %describe-fun-name (name s type-spec) (when (and name (typep name '(or symbol cons))) (multiple-value-bind (type where) - (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) - (values (type-specifier (info :function :type name)) - (info :function :where-from name)) - (values type-spec :defined)) + (if (legal-fun-name-p name) + (values (type-specifier (info :function :type name)) + (info :function :where-from name)) + (values type-spec :defined)) (when (consp type) - (format s "~@:_Its ~(~A~) argument types are:~@:_ ~S" - where (second type)) - (format s "~@:_Its result type is:~@:_ ~S" (third type)))) + (format s "~&Its ~(~A~) argument types are:~% ~S" + where (second type)) + (format s "~&Its result type is:~% ~S" (third type)))) (let ((inlinep (info :function :inlinep name))) (when inlinep - (format s - "~@:_It is currently declared ~(~A~);~ - ~:[no~;~] expansion is available." - inlinep (info :function :inline-expansion-designator name)))))) + (format s + "~&It is currently declared ~(~A~);~ + ~:[no~;~] expansion is available." + inlinep (info :function :inline-expansion-designator name)))))) ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. @@ -135,24 +153,22 @@ (declare (type stream s)) (let ((info (sb-kernel:%code-debug-info code-obj))) (when info - (let ((sources (sb-c::debug-info-source info))) - (when sources - (format s "~@:_On ~A it was compiled from:" - ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system - ;; should become more consistent, probably not using - ;; any nondefault options. - (format-universal-time nil - (sb-c::debug-source-compiled - (first sources)) - :style :abbreviated)) - (dolist (source sources) - (let ((name (sb-c::debug-source-name source))) - (ecase (sb-c::debug-source-from source) - (:file - (format s "~@:_~A~@:_ Created: " (namestring name)) - (format-universal-time s (sb-c::debug-source-created - source))) - (:lisp (format s "~@:_~S" name)))))))))) + (let ((source (sb-c::debug-info-source info))) + (when source + (format s "~&On ~A it was compiled from:" + ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system + ;; should become more consistent, probably not using + ;; any nondefault options. + (format-universal-time nil (sb-c::debug-source-compiled source) + :style :abbreviated)) + (let ((name (sb-c::debug-source-namestring source))) + (cond (name + (format s "~&~A~@:_ Created: " name) + (format-universal-time s (sb-c::debug-source-created source))) + ((sb-di:debug-source-form source) + (format s "~& ~S" (sb-di:debug-source-form source))) + (t (bug "Don't know how to use a DEBUG-SOURCE without ~ + a namestring or a form."))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. @@ -160,10 +176,10 @@ (declare (type stream s)) (let ((args (%simple-fun-arglist x))) (cond ((not args) - (write-string " There are no arguments." s)) - (t - (format s "~@:_~@(The ~@[~A's ~]arguments are:~@:_~)" kind) - (write-string " " s) + (write-string " There are no arguments." s)) + (t + (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) + (write-string " " s) (let ((*print-pretty* t) (*print-escape* t) (*print-base* 10) @@ -177,43 +193,92 @@ (%describe-fun-name name s (%simple-fun-type x)))) (%describe-compiled-from (sb-kernel:fun-code-header x) s)) +(defun %describe-fun (x s &optional (kind :function) (name nil)) + (etypecase x + #+sb-eval + (sb-eval:interpreted-function + (%describe-interpreted-fun x s kind name)) + (function + (%describe-compiled-fun x s kind name)))) + ;;; Describe a function object. KIND and NAME provide some information ;;; about where the function came from. -(defun %describe-fun (x s &optional (kind :function) (name nil)) +(defun %describe-compiled-fun (x s &optional (kind :function) (name nil)) (declare (type function x)) (declare (type stream s)) (declare (type (member :macro :function) kind)) (fresh-line s) - (ecase kind - (:macro (format s "Macro-function: ~S" x)) - (:function (if name - (format s "Function: ~S" x) - (format s "~S is a function." x)))) - (format s "~@:_Its associated name (as in ~S) is ~S." - 'function-lambda-expression - (%fun-name x)) - (case (widetag-of x) - (#.sb-vm:closure-header-widetag - (%describe-fun-compiled (%closure-fun x) s kind name) - (format s "~@:_Its closure environment is:") - (pprint-logical-block (s nil) - (pprint-indent :current 8) - (dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset))) - (format s "~@:_~S: ~S" i (%closure-index-ref x i))))) - ((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag) - (%describe-fun-compiled x s kind name)) - (#.sb-vm:funcallable-instance-header-widetag - ;; Only STANDARD-GENERIC-FUNCTION would be handled here, but - ;; since it has its own DESCRIBE-OBJECT method, it should've been - ;; picked off before getting here. So hopefully we never get here. - (format s "~@:_It is an unknown type of funcallable instance.")) - (t - (format s "~@:_It is an unknown type of function.")))) + (pprint-logical-block (s nil) + (ecase kind + (:macro (format s "Macro-function: ~S" x)) + (:function (if name + (format s "Function: ~S" x) + (format s "~S is a function." x)))) + (format s "~@:_~@" + 'function-lambda-expression + (nth-value 2 (function-lambda-expression x))) + (case (widetag-of x) + (#.sb-vm:closure-header-widetag + (%describe-fun-compiled (%closure-fun x) s kind name) + (format s "~&Its closure environment is:") + (loop for value in (%closure-values x) + for i = 0 then (1+ i) + do (format s "~& ~S: ~S" i value))) + (#.sb-vm:simple-fun-header-widetag + (%describe-fun-compiled x s kind name)) + (#.sb-vm:funcallable-instance-header-widetag + ;; Only STANDARD-GENERIC-FUNCTION would be handled here, but + ;; since it has its own DESCRIBE-OBJECT method, it should've been + ;; picked off before getting here. So hopefully we never get here. + (format s "~@:_It is an unknown type of funcallable instance.")) + (t + (format s "~@:_It is an unknown type of function.")))) + (terpri s)) + +;; Describe an interpreted function. +#+sb-eval +(defun %describe-interpreted-fun (x s &optional (kind :function) (name nil)) + (declare (type sb-eval:interpreted-function x)) + (declare (type stream s)) + (declare (type (member :macro :function) kind)) + (fresh-line s) + (pprint-logical-block (s nil) + (ecase kind + (:macro (format s "Macro-function: ~S" x)) + (:function (if name + (format s "Function: ~S" x) + (format s "~S is a function." x)))) + (format s "~@:_~@" + 'function-lambda-expression + (nth-value 2 (function-lambda-expression x))) + (format s "~&It is an interpreted function.~%") + (let ((args (sb-eval:interpreted-function-lambda-list x))) + (cond ((not args) + (write-string "There are no arguments." s)) + (t + (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) + (write-string " " s) + (let ((*print-pretty* t) + (*print-escape* t) + (*print-base* 10) + (*print-radix* nil)) + (pprint-logical-block (s nil) + (pprint-indent :current 2) + (format s "~A" args))))) + (format s "~&It was defined as: ") + (let ((*print-pretty* t) + (*print-escape* t) + (*print-base* 10) + (*print-radix* nil)) + (pprint-logical-block (s nil) + (pprint-indent :current 2) + (format s "~A" (function-lambda-expression x)))))) + (terpri s)) (defmethod describe-object ((x function) s) (%describe-fun x s :function)) -(defgeneric describe-symbol-fdefinition (function stream &key (name nil) )) +(defgeneric describe-symbol-fdefinition (function stream &key name)) (defmethod describe-symbol-fdefinition ((fun function) stream &key name) (%describe-fun fun stream :function name)) @@ -221,7 +286,7 @@ (defmethod describe-symbol-fdefinition ((fun standard-generic-function) stream &key name) (declare (ignore name)) - ;; just delegate + ;; Just delegate. (describe-object fun stream)) (defmethod describe-object ((x symbol) s) @@ -230,12 +295,12 @@ ;; Describe the packaging. (let ((package (symbol-package x))) (if package - (multiple-value-bind (symbol status) - (find-symbol (symbol-name x) package) - (declare (ignore symbol)) - (format s "~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" - x status (symbol-package x))) - (format s "~@<~S is ~_an uninterned symbol.~:>" x))) + (multiple-value-bind (symbol status) + (find-symbol (symbol-name x) package) + (declare (ignore symbol)) + (format s "~&~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" + x status (symbol-package x))) + (format s "~&~@<~S is ~_an uninterned symbol.~:>" x))) ;; TO DO: We could grovel over all packages looking for and ;; reporting other phenomena, e.g. IMPORT and SHADOW, or ;; availability in some package even after (SYMBOL-PACKAGE X) has @@ -243,45 +308,46 @@ ;; Describe the value cell. (let* ((kind (info :variable :kind x)) - (wot (ecase kind - (:special "special variable") + (wot (ecase kind + (:special "special variable") (:macro "symbol macro") - (:constant "constant") - (:global "undefined variable") - (:alien nil)))) - (cond - ((eq kind :alien) - (let ((info (info :variable :alien-info x))) - (format s "~@:_~@~@:_" - (sap-int (eval (sb-alien::heap-alien-info-sap-form info))) - (sb-alien-internals:unparse-alien-type - (sb-alien::heap-alien-info-type info))) - (format s "~@" - (eval x)))) - ((eq kind :macro) - (let ((expansion (info :variable :macro-expansion x))) - (format s "~@:_It is a ~A with expansion ~S." wot expansion))) - ((boundp x) - (format s "~@:_~@" - wot (symbol-value x))) - ((not (eq kind :global)) - (format s "~@:_~@" wot))) + (:constant "constant") + (:global "undefined variable") + (:alien nil)))) + (pprint-logical-block (s nil) + (cond + ((eq kind :alien) + (let ((info (info :variable :alien-info x))) + (format s "~&~@" + (sap-int (eval (sb-alien::heap-alien-info-sap-form info))) + (sb-alien-internals:unparse-alien-type + (sb-alien::heap-alien-info-type info))) + (format s "~&~@" + (eval x)))) + ((eq kind :macro) + (let ((expansion (info :variable :macro-expansion x))) + (format s "~&It is a ~A with expansion ~S." wot expansion))) + ((boundp x) + (format s "~&~@" + wot (symbol-value x))) + ((not (eq kind :global)) + (format s "~&~@" wot))) - (when (eq (info :variable :where-from x) :declared) - (format s "~@:_~@" - (type-specifier (info :variable :type x)))) + (when (eq (info :variable :where-from x) :declared) + (format s "~&~@" + (type-specifier (info :variable :type x))))) (%describe-doc x s 'variable kind)) ;; Print out properties. - (format s "~@[~@:_Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x)) + (format s "~@[~&Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x)) ;; Describe the function cell. (cond ((macro-function x) - (%describe-fun (macro-function x) s :macro x)) - ((special-operator-p x) - (%describe-doc x s :function "Special form")) - ((fboundp x) + (%describe-fun (macro-function x) s :macro x)) + ((special-operator-p x) + (%describe-doc x s :function "Special form")) + ((fboundp x) (describe-symbol-fdefinition (fdefinition x) s :name x))) ;; Print other documentation. @@ -289,11 +355,14 @@ (%describe-doc x s 'type "Type") (%describe-doc x s 'setf "Setf macro") (dolist (assoc (info :random-documentation :stuff x)) - (format s - "~@:_Documentation on the ~(~A~):~@:_~A" - (car assoc) - (cdr assoc))) - + (let ((type (car assoc))) + (format s + "~&~@" + (case type + ((optimize) "optimize quality") + (t (car assoc))) + (cdr assoc)))) + ;; Mention the associated type information, if any. ;; ;; As of sbcl-0.7.2, (INFO :TYPE :KIND X) might be @@ -304,8 +373,10 @@ ;; note that we don't try to report. ;; * NIL, in which case there's nothing to see here, move along. (when (eq (info :type :kind x) :defined) - (format s "~@:_It names a type specifier.")) - (let ((symbol-named-class (cl:find-class x nil))) + (format s "~&It names a type specifier.")) + (let ((symbol-named-class (find-class x nil))) (when symbol-named-class - (format s "~@:_It names a class ~A." symbol-named-class) - (describe symbol-named-class s)))) + (format s "~&It names a class ~A." symbol-named-class) + (describe symbol-named-class s))) + + (terpri s))