X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdescribe.lisp;h=b4f1b9406a35b5282a8cbaa2661a1af8c0675b89;hb=df871446529da0e83d670f35a9566c11d814be32;hp=afbb66c063fbb9b2cc010160baa8b89da23ff7fb;hpb=479ef26343b45753fc019b6535d3aa0ee54cb324;p=sbcl.git diff --git a/src/code/describe.lisp b/src/code/describe.lisp index afbb66c..b4f1b94 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -27,7 +27,7 @@ ;; 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. + ;; 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 @@ -49,7 +49,7 @@ (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. @@ -60,26 +60,24 @@ (defmethod describe-object ((x array) s) (fresh-line s) (pprint-logical-block (s nil) - (let ((rank (array-rank x))) - (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)))) - (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))))) + (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)))) + (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) @@ -87,24 +85,24 @@ (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)) - (fresh-line) + "~&~@" + (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)) + 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))))) + (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) @@ -121,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 @@ -131,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 (legal-fun-name-p name) - (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. @@ -155,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. @@ -180,10 +176,10 @@ (declare (type stream s)) (let ((args (%simple-fun-arglist x))) (cond ((not args) - (write-string " There are no arguments." s)) - (t + (write-string " There are no arguments." s)) + (t (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) - (write-string " " s) + (write-string " " s) (let ((*print-pretty* t) (*print-escape* t) (*print-base* 10) @@ -197,9 +193,17 @@ (%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)) @@ -208,22 +212,21 @@ (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: ~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 + 'function-lambda-expression + (nth-value 2 (function-lambda-expression x))) + (typecase x + (closure (%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) + (format s "~&Its closure environment is:") + (let ((i -1)) + (do-closure-values (value x) + (format s "~& ~S: ~S" (incf i) value)))) + (simple-fun (%describe-fun-compiled x s kind name)) - (#.sb-vm:funcallable-instance-header-widetag + (funcallable-instance ;; 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. @@ -232,6 +235,42 @@ (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-debug-lambda-list x))) + (format s "Its lambda-list is: ") + (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 "~S" (function-lambda-expression x)))))) + (terpri s)) + (defmethod describe-object ((x function) s) (%describe-fun x s :function)) @@ -252,12 +291,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 @@ -265,34 +304,35 @@ ;; Describe the value cell. (let* ((kind (info :variable :kind x)) - (wot (ecase kind - (:special "special variable") - (:macro "symbol macro") - (:constant "constant") - (:global "undefined variable") - (:alien nil)))) + (wot (ecase kind + (:special "special variable") + (:macro "symbol macro") + (:constant "constant") + (:global "global variable") + (:unknown "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)))) + (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))) + (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))) + (format s "~&~@" + wot (symbol-value x))) + ((not (eq kind :unknown)) + (format s "~&~@" wot))) (when (eq (info :variable :where-from x) :declared) - (format s "~&~@" - (type-specifier (info :variable :type x))))) + (format s "~&~@" + (type-specifier (info :variable :type x))))) (%describe-doc x s 'variable kind)) @@ -301,22 +341,29 @@ ;; 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-symbol-fdefinition (fdefinition x) s :name 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))) + + ;; Describe deftype lambda-list and doc + (when (info :type :expander x) + (format s "~&DEFTYPE lambda-list: ~A" (info :type :lambda-list x)) + (%describe-doc x s 'type "Type")) ;; 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 - "~&~@" - (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