X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=c2ce9dc81f99b67674403e8643275f0877e7e4b0;hb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;hp=333aa33d2bdbdcd840af88a482786a8fea0a480b;hpb=2d195da5e29feadce7190ea1a68a2efa83a5e1c0;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 333aa33..c2ce9dc 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -10,7 +10,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-IMPL") +(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) (defvar *describe-indentation-step* 3 #+sb-doc @@ -23,9 +23,10 @@ #+sb-doc "Print a description of the object X." (let ((stream (out-synonym-of stream-designator))) - #+nil (fresh-line stream) (pprint-logical-block (stream nil) - (describe-object x stream))) + (fresh-line stream) + (describe-object x stream) + (fresh-line stream))) (values)) ;;;; miscellaneous DESCRIBE-OBJECT methods @@ -37,7 +38,8 @@ (call-next-method) (when (and (legal-function-name-p x) (fboundp x)) - (format s "Its FDEFINITION is ~S.~@:_" (fdefinition x)) + (%describe-function (fdefinition x) s :function x) + ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x)) ;; TO DO: should check for SETF documentation. ;; TO DO: should make it clear whether the definition is a ;; DEFUN (SETF FOO) or DEFSETF FOO or what. @@ -94,7 +96,7 @@ ;;; Print the specified kind of documentation about the given NAME. If ;;; NAME is null, or not a valid name, then don't print anything. -(declaim (ftype (function (symbol stream t t) (values)) %describe-doc)) +(declaim (ftype (function (t stream t t) (values)) %describe-doc)) (defun %describe-doc (name s kind kind-doc) (when (and name (typep name '(or symbol cons))) (let ((doc (fdocumentation name kind))) @@ -104,52 +106,28 @@ (values)) ;;; Describe various stuff about the functional semantics attached to -;;; the specified Name. Type-Spec is the function type specifier +;;; the specified NAME, if NAME is the kind of thing you can look +;;; up as a name. (In the case of anonymous closures and other +;;; things, it might not be.) TYPE-SPEC is the function type specifier ;;; extracted from the definition, or NIL if none. -(declaim (ftype (function ((or symbol cons) stream t)) %describe-function-name)) +(declaim (ftype (function (t stream t)) %describe-function-name)) (defun %describe-function-name (name s type-spec) - (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)) - (when (consp 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~);~ + (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)) + (when (consp 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 name))))) - -;;; Interpreted function describing; handles both closure and -;;; non-closure functions. Instead of printing the compiled-from info, -;;; we print the definition. -(defun %describe-function-interpreted (x s kind name) - (declare (type stream s)) - (multiple-value-bind (exp closure-p dname) - (sb-eval:interpreted-function-lambda-expression x) - (let ((args (sb-eval:interpreted-function-arglist x))) - (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind) - (if args - (format s " ~<~S~:>" args) - (write-string " There are no arguments." s))) - (let ((name (or name dname))) - (%describe-doc name s 'function kind) - (unless (eq kind :macro) - (%describe-function-name - name - s - (type-specifier (sb-eval:interpreted-function-type x))))) - (when closure-p - (format s "~@:_Its closure environment is:") - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (let ((clos (sb-eval:interpreted-function-closure x))) - (dotimes (i (length clos)) - (format s "~@:_~S: ~S" i (svref clos i)))))) - (format s "~@:_Its definition is:~@:_ ~S" exp))) + inlinep (info :function :inline-expansion name)))))) ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. @@ -172,22 +150,22 @@ (ecase (sb-c::debug-source-from source) (:file (format s "~@:_~A~@:_ Created: " (namestring name)) - (sb-int:format-universal-time t (sb-c::debug-source-created - source))) + (format-universal-time s (sb-c::debug-source-created + source))) (:lisp (format s "~@:_~S" name)))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. (defun %describe-function-compiled (x s kind name) (declare (type stream s)) - ;; FIXME: The lowercaseness of %FUNCTION-ARGLIST results, and the + ;; FIXME: The lowercaseness of %SIMPLE-FUN-ARGLIST results, and the ;; non-sentenceness of the "Arguments" label, makes awkward output. ;; Better would be "Its arguments are: ~S" (with uppercase argument ;; names) when arguments are known, and otherwise "There is no ;; information available about its arguments." or "It has no - ;; arguments." (And why is %FUNCTION-ARGLIST a string instead of a + ;; arguments." (And why is %SIMPLE-FUN-ARGLIST a string instead of a ;; list of symbols anyway?) - (let ((args (%function-arglist x))) + (let ((args (%simple-fun-arglist x))) (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind) (cond ((not args) (format s " There is no argument information available.")) @@ -198,23 +176,15 @@ (pprint-logical-block (s nil) (pprint-indent :current 2) (write-string args s))))) - (let ((name (or name (%function-name x)))) + (let ((name (or name (%simple-fun-name x)))) (%describe-doc name s 'function kind) (unless (eq kind :macro) - (%describe-function-name name s (%function-type x)))) - (%describe-compiled-from (sb-kernel:function-code-header x) s)) - -(defun %describe-function-byte-compiled (x s kind name) - (declare (type stream s)) - (let ((name (or name (sb-c::byte-function-name x)))) - (%describe-doc name s 'function kind) - (unless (eq kind :macro) - (%describe-function-name name s 'function))) - (%describe-compiled-from (sb-c::byte-function-component x) s)) + (%describe-function-name name s (%simple-fun-type x)))) + (%describe-compiled-from (sb-kernel:fun-code-header x) s)) ;;; Describe a function with the specified kind and name. The latter ;;; arguments provide some information about where the function came -;;; from. Kind NIL means not from a name. +;;; from. KIND=NIL means not from a name. (defun %describe-function (x s &optional (kind nil) name) (declare (type function x)) (declare (type stream s)) @@ -226,29 +196,16 @@ ((nil) (format s "~S is a function." x))) (case (get-type x) (#.sb-vm:closure-header-type - (%describe-function-compiled (%closure-function x) s kind name) + (%describe-function-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:function-header-type #.sb-vm:closure-function-header-type) + ((#.sb-vm:simple-fun-header-type #.sb-vm:closure-fun-header-type) (%describe-function-compiled x s kind name)) (#.sb-vm:funcallable-instance-header-type (typecase x - (sb-kernel:byte-function - (%describe-function-byte-compiled x s kind name)) - (sb-kernel:byte-closure - (%describe-function-byte-compiled (byte-closure-function x) - s kind name) - (format s "~@:_Its closure environment is:") - (pprint-logical-block (s nil) - (pprint-indent :current 8) - (let ((data (byte-closure-data x))) - (dotimes (i (length data)) - (format s "~@:_~S: ~S" i (svref data i)))))) - (sb-eval:interpreted-function - (%describe-function-interpreted x s kind name)) (standard-generic-function ;; There should be a special method for this case; we'll ;; delegate to that. @@ -270,9 +227,9 @@ (multiple-value-bind (symbol status) (find-symbol (symbol-name x) package) (declare (ignore symbol)) - (format s "~S is an ~(~A~) symbol in ~S." + (format s "~S is ~_an ~(~A~) symbol ~_in ~S." x status (symbol-package x))) - (format s "~S is an uninterned symbol." 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 @@ -295,12 +252,12 @@ (format s "~@" (eval x)))) ((boundp x) - (format s "~@:_It is a ~A; its value is ~S." wot (symbol-value x))) + (format s "~@:_It is a ~A; its ~_value is ~S." wot (symbol-value x))) ((not (eq kind :global)) (format s "~@:_It is a ~A; no current value." wot))) (when (eq (info :variable :where-from x) :declared) - (format s "~@:_Its declared type is ~S." + (format s "~@:_Its declared type ~_is ~S." (type-specifier (info :variable :type x)))) (%describe-doc x s 'variable kind)) @@ -316,18 +273,25 @@ ((fboundp x) (%describe-function (fdefinition x) s :function x))) - ;; TO DO: Print out other stuff from the INFO database: - ;; * Does it name a type or class? - ;; * Is it a structure accessor? (important since those are + ;; FIXME: Print out other stuff from the INFO database: + ;; * Does it name a type? + ;; * Is it a structure accessor? (This is important since those are ;; magical in some ways, e.g. blasting the structure if you - ;; redefine them) + ;; redefine them.) ;; Print other documentation. (%describe-doc x s 'structure "Structure") (%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)))) + (cdr assoc))) + + ;; Describe the associated class, if any. + (let ((symbol-named-class (cl:find-class x nil))) + (when symbol-named-class + (format t "~&It names a class ~A." symbol-named-class) + (describe symbol-named-class))))