X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=b89842fd1eb2c8a2e0805bbbc329f4b946075b3a;hb=ad613f03c3e077e63ae871a4e1967ac57a4c59c9;hp=d0859474e4c701ac3868c2a709b7e7c7ff77782e;hpb=e27303999070c06c788a0e1359ee4b0900186aa1;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index d085947..b89842f 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -11,26 +11,18 @@ ;;;; files for more information. (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) - -(declaim #.*optimize-byte-compilation*) - -(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." - (declare #.*optimize-external-despite-byte-compilation*) (let ((stream (out-synonym-of stream-designator))) + (fresh-line stream) (pprint-logical-block (stream nil) - (fresh-line stream) (describe-object x stream) - (fresh-line stream))) + (pprint-newline :mandatory stream))) (values)) ;;;; miscellaneous DESCRIBE-OBJECT methods @@ -40,9 +32,9 @@ (defmethod describe-object ((x cons) s) (call-next-method) - (when (and (legal-function-name-p x) + (when (and (legal-fun-name-p x) (fboundp x)) - (%describe-function (fdefinition x) s :function x) + (%describe-fun (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 @@ -51,18 +43,18 @@ (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 + (cond ((= rank 1) (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)))))) + (fill-pointer x)))) + (t + (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))))) (let ((array-element-type (array-element-type x))) (unless (eq array-element-type t) (format s @@ -114,8 +106,8 @@ ;;; 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 (t stream t)) %describe-function-name)) -(defun %describe-function-name (name s type-spec) +(declaim (ftype (function (t stream t)) %describe-fun-name)) +(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))) @@ -131,7 +123,7 @@ (format s "~@:_It is currently declared ~(~A~);~ ~:[no~;~] expansion is available." - inlinep (info :function :inline-expansion name)))))) + inlinep (info :function :inline-expansion-designator name)))))) ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. @@ -160,87 +152,74 @@ ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. -(defun %describe-function-compiled (x s kind name) +(defun %describe-fun-compiled (x s kind name) (declare (type stream s)) - ;; FIXME: The lowercaseness of %FUNCTION-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 - ;; list of symbols anyway?) - (let ((args (%function-arglist x))) - (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind) + (let ((args (%simple-fun-arglist x))) (cond ((not args) - (format s " There is no argument information available.")) - ((string= args "()") (write-string " There are no arguments." s)) (t + (format s "~@:_~@(The ~@[~A's ~]arguments are:~@:_~)" kind) (write-string " " s) - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (write-string args s))))) - (let ((name (or name (%function-name x)))) + (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)))))) + (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)) + (%describe-fun-name name s (%simple-fun-type x)))) + (%describe-compiled-from (sb-kernel:fun-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 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. -(defun %describe-function (x s &optional (kind nil) 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)) (declare (type function x)) (declare (type stream s)) - (declare (type (member :macro :function nil) kind)) + (declare (type (member :macro :function) kind)) (fresh-line s) (ecase kind (:macro (format s "Macro-function: ~S" x)) - (:function (format s "Function: ~S" x)) - ((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) + (:function (if name + (format s "Function: ~S" x) + (format s "~S is a function." x)))) + (format 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:function-header-type #.sb-vm:closure-function-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)))))) - (standard-generic-function - ;; There should be a special method for this case; we'll - ;; delegate to that. - (describe-object x s)) - (t - (format s "~@:_It is an unknown type of funcallable instance.")))) + ((#.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.")))) (defmethod describe-object ((x function) s) - (%describe-function x s)) - + (%describe-fun x s :function)) + +(defgeneric describe-symbol-fdefinition (function stream &key name)) + +(defmethod describe-symbol-fdefinition ((fun function) stream &key name) + (%describe-fun fun stream :function name)) + +(defmethod describe-symbol-fdefinition ((fun standard-generic-function) stream + &key name) + (declare (ignore name)) + ;; just delegate + (describe-object fun stream)) + (defmethod describe-object ((x symbol) s) (declare (type stream s)) @@ -250,9 +229,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 @@ -262,6 +241,7 @@ (let* ((kind (info :variable :kind x)) (wot (ecase kind (:special "special variable") + (:macro "symbol macro") (:constant "constant") (:global "undefined variable") (:alien nil)))) @@ -274,13 +254,17 @@ (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 "~@:_It is a ~A; its ~_value is ~S." wot (symbol-value x))) + (format s "~@:_~@" + wot (symbol-value x))) ((not (eq kind :global)) - (format s "~@:_It is a ~A; no current value." wot))) + (format s "~@:_~@" wot))) (when (eq (info :variable :where-from x) :declared) - (format s "~@:_Its declared type ~_is ~S." + (format s "~@:_~@" (type-specifier (info :variable :type x)))) (%describe-doc x s 'variable kind)) @@ -290,31 +274,34 @@ ;; Describe the function cell. (cond ((macro-function x) - (%describe-function (macro-function x) s :macro x)) + (%describe-fun (macro-function x) s :macro x)) ((special-operator-p x) - (%describe-doc x s 'function "Special form")) + (%describe-doc x s :function "Special form")) ((fboundp x) - (%describe-function (fdefinition x) s :function x))) - - ;; 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.) + (describe-symbol-fdefinition (fdefinition x) s :name x))) ;; 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))) - ;; Describe the associated class, if any. + ;; Mention the associated type information, if any. + ;; + ;; As of sbcl-0.7.2, (INFO :TYPE :KIND X) might be + ;; * :PRIMITIVE, which is handled by the FIND-CLASS case. + ;; * :DEFINED, which is handled specially. + ;; * :INSTANCE, which is handled by the FIND-CLASS case. + ;; * :FORTHCOMING-DEFCLASS-TYPE, which is an internal-to-the-compiler + ;; 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))) (when symbol-named-class - (format t "~&It names a class ~A." symbol-named-class) - (describe symbol-named-class)))) + (format s "~@:_It names a class ~A." symbol-named-class) + (describe symbol-named-class s))))