1 ;;;; the DESCRIBE system
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 ;;; SB-IMPL, not SB!IMPL, since we're built in warm load.
13 (in-package "SB-IMPL")
15 ;;;; Utils, move elsewhere.
17 (defun class-name-or-class (class)
18 (let ((name (class-name class
)))
19 (if (eq class
(find-class name nil
))
24 (if (typep x
'generic-function
)
25 (sb-pcl:generic-function-name x
)
28 ;;; Prints X on a single line, limiting output length by *PRINT-RIGHT-MARGIN*
29 ;;; -- good for printing object parts, etc.
30 (defun prin1-to-line (x &key
(columns 1) (reserve 0))
31 (let* ((line (write-to-string x
:escape t
:readably nil
:lines
2 :circle t
))
32 (p (position #\newline line
))
33 (limit (truncate (- *print-right-margin
* reserve
) columns
)))
34 (flet ((trunc (&optional end
)
35 (let ((line-end (- limit
2)))
36 (with-output-to-string (s)
37 (write-string line s
:end
(if end
40 (write-string ".." s
)))))
43 ((> (length line
) limit
)
48 (defun describe (object &optional
(stream-designator *standard-output
*))
50 "Print a description of OBJECT to STREAM-DESIGNATOR."
51 (let ((stream (out-synonym-of stream-designator
))
52 (*print-right-margin
* (or *print-right-margin
* 72)))
53 ;; Until sbcl-0.8.0.x, we did
54 ;; (FRESH-LINE STREAM)
55 ;; (PPRINT-LOGICAL-BLOCK (STREAM NIL)
57 ;; here. However, ANSI's specification of DEFUN DESCRIBE,
58 ;; DESCRIBE exists as an interface primarily to manage argument
59 ;; defaulting (including conversion of arguments T and NIL into
60 ;; stream objects) and to inhibit any return values from
62 ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing,
63 ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's
64 ;; specification of DESCRIBE-OBJECT will work poorly if we do them
65 ;; here. (The example method for DESCRIBE-OBJECT does its own
66 ;; FRESH-LINEing, which is a physical directive which works poorly
67 ;; inside a pretty-printer logical block.)
68 (describe-object object stream
)
69 ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
70 ;; again ANSI's specification of DESCRIBE doesn't mention it and
71 ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.
78 ;;;; * Each interesting class has a primary method of its own.
80 ;;;; * Output looks like
82 ;;;; object-self-string
83 ;;;; [object-type-string]
92 ;;;; * The newline policy that gets the whitespace right is for
93 ;;;; each block to both start and end with a newline.
95 (defgeneric object-self-string
(x))
97 (defmethod object-self-string (x)
100 (defmethod object-self-string ((x symbol
))
101 (let ((*package
* (find-package :keyword
)))
102 (prin1-to-string x
)))
104 (defgeneric object-type-string
(x))
106 (defmethod object-type-string (x)
107 (let ((type (class-name-or-class (class-of x
))))
109 (string-downcase type
)
110 (prin1-to-string type
))))
112 (defmethod object-type-string ((x cons
))
113 (if (listp (cdr x
)) "list" "cons"))
115 (defmethod object-type-string ((x hash-table
))
118 (defmethod object-type-string ((x condition
))
121 (defmethod object-type-string ((x structure-object
))
124 (defmethod object-type-string ((x standard-object
))
127 (defmethod object-type-string ((x function
))
129 (simple-fun "compiled function")
130 (closure "compiled closure")
132 (sb-eval:interpreted-function
133 "interpreted function")
137 "funcallable-instance")))
139 (defmethod object-type-string ((x stream
))
142 (defmethod object-type-string ((x sb-gray
:fundamental-stream
))
145 (defmethod object-type-string ((x package
))
148 (defmethod object-type-string ((x array
))
149 (cond ((or (stringp x
) (bit-vector-p x
))
150 (format nil
"~@[simple-~*~]~A"
151 (typep x
'simple-array
)
153 (base-string "base-string")
157 (if (simple-vector-p x
)
159 (format nil
"~@[simple ~*~]~@[specialized ~*~]~:[array~;vector~]"
160 (typep x
'simple-array
)
161 (neq t
(array-element-type x
))
164 (defmethod object-type-string ((x character
))
166 (standard-char "standard-char")
167 (base-char "base-char")
170 (declaim (ftype (function (t stream
)) describe-object
))
171 (defgeneric describe-object
(x stream
))
173 (defvar *in-describe
* nil
)
175 (defmethod describe-object :around
(x s
)
179 (format s
"~&~A~% [~A]~%"
180 (object-self-string x
)
181 (object-type-string x
))
182 (pprint-logical-block (s nil
)
183 (call-next-method x s
)))))
186 (defmethod describe-object ((x t
) s
)
189 (defmethod describe-object ((x cons
) s
)
190 (describe-function x nil s
))
192 (defmethod describe-object ((x function
) s
)
193 (describe-function nil x s
))
195 (defmethod describe-object ((x class
) s
)
196 (describe-class nil x s
)
197 (describe-instance x s
))
199 (defmethod describe-object ((x sb-pcl
::slot-object
) s
)
200 (describe-instance x s
))
202 (defmethod describe-object ((x character
) s
)
203 (format s
"~%:_Char-code: ~S" (char-code x
))
204 (format s
"~%:_Char-name: ~A~%_" (char-name x
)))
206 (defmethod describe-object ((x array
) s
)
207 (format s
"~%Element-type: ~S" (array-element-type x
))
209 (if (array-has-fill-pointer-p x
)
210 (format s
"~%Fill-pointer: ~S~%Size: ~S"
212 (array-total-size x
))
213 (format s
"~%Length: ~S" (length x
)))
214 (format s
"~%Dimensions: ~S" (array-dimensions x
)))
215 (let ((*print-array
* nil
))
216 (unless (typep x
'simple-array
)
217 (format s
"~%Adjustable: ~A" (if (adjustable-array-p x
) "yes" "no"))
218 (multiple-value-bind (to offset
) (array-displacement x
)
219 (if (format s
"~%Displaced-to: ~A~%Displaced-offset: ~S"
222 (format s
"~%Displaced: no"))))
223 (when (and (not (array-displacement x
)) (array-header-p x
))
224 (format s
"~%Storage vector: ~A"
225 (prin1-to-line (array-storage-vector x
))))
228 (defmethod describe-object ((x hash-table
) s
)
229 ;; Don't print things which are already apparent from the printed representation
230 ;; -- COUNT, TEST, and WEAKNESS
231 (format s
"~%Occupancy: ~,1F" (float (/ (hash-table-count x
) (hash-table-size x
))))
232 (format s
"~%Rehash-threshold: ~S" (hash-table-rehash-threshold x
))
233 (format s
"~%Rehash-size: ~S" (hash-table-rehash-size x
))
234 (format s
"~%Size: ~S" (hash-table-size x
))
235 (format s
"~%Synchronized: ~A" (if (hash-table-synchronized-p x
) "yes" "no"))
238 (defmethod describe-object ((symbol symbol
) stream
)
239 ;; Describe the value cell.
240 (let* ((kind (info :variable
:kind symbol
))
242 (:special
"a special variable")
243 (:macro
"a symbol macro")
244 (:constant
"a constant variable")
245 (:global
"a global variable")
246 (:unknown
"an undefined variable")
247 (:alien
"an alien variable"))))
248 (when (or (not (eq :unknown kind
)) (boundp symbol
))
249 (pprint-logical-block (stream nil
)
250 (format stream
"~%~A names ~A:" symbol wot
)
251 (pprint-indent :block
2 stream
)
252 (when (eq (info :variable
:where-from symbol
) :declared
)
253 (format stream
"~@:_Declared type: ~S"
254 (type-specifier (info :variable
:type symbol
))))
257 (let ((info (info :variable
:alien-info symbol
)))
258 (format stream
"~@:_Value: ~S" (eval symbol
))
259 (format stream
"~@:_Type: ~S"
260 (sb-alien-internals:unparse-alien-type
261 (sb-alien::heap-alien-info-type info
)))
262 (format stream
"~@:_Address: #x~8,'0X"
263 (sap-int (eval (sb-alien::heap-alien-info-sap-form info
))))))
265 (let ((expansion (info :variable
:macro-expansion symbol
)))
266 (format stream
"~@:_Expansion: ~S" expansion
)))
268 (format stream
"~:@_Value: ~S" (symbol-value symbol
)))
269 ((not (eq kind
:unknown
))
270 (format stream
"~:@_Currently unbound.")))
271 (describe-documentation symbol
'variable stream
)
274 ;; TODO: We could grovel over all packages looking for and
275 ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
276 ;; availability in some package even after (SYMBOL-PACKAGE SYMBOL) has
279 ;; TODO: It might also be nice to describe (find-package symbol)
280 ;; if one exists. Maybe not all the exports, etc, but the package
282 (describe-function symbol nil stream
)
283 (describe-class symbol nil stream
)
286 (let* ((kind (info :type
:kind symbol
))
289 (or (info :type
:expander symbol
) t
))
291 (or (info :type
:translator symbol
) t
)))))
293 (pprint-newline :mandatory stream
)
294 (pprint-logical-block (stream nil
)
295 (pprint-indent :block
2 stream
)
296 (format stream
"~A names a ~@[primitive~* ~]type-specifier:"
298 (eq kind
:primitive
))
299 (describe-documentation symbol
'type stream
(eq t fun
))
301 (describe-lambda-list (if (eq :primitive kind
)
302 (%fun-lambda-list fun
)
303 (info :type
:lambda-list symbol
))
305 (when (eq (%fun-fun fun
) (%fun-fun
(constant-type-expander t
)))
306 (format stream
"~@:_Expansion: ~S" (funcall fun
(list symbol
))))))
309 ;; Print out properties.
310 (let ((plist (symbol-plist symbol
)))
312 (pprint-logical-block (stream nil
)
313 (format stream
"~%Symbol-plist:")
314 (pprint-indent :block
2 stream
)
315 (sb-pcl::doplist
(key value
) plist
316 (format stream
"~@:_~A -> ~A"
317 (prin1-to-line key
:columns
2 :reserve
5)
318 (prin1-to-line value
:columns
2 :reserve
5))))
321 (defmethod describe-object ((package package
) stream
)
322 (describe-documentation package t stream
)
323 (flet ((humanize (list)
324 (sort (mapcar (lambda (x)
331 (describe-stuff label list stream
:escape nil
)))
332 (let ((implemented (humanize (package-implemented-by-list package
)))
333 (implements (humanize (package-implements-list package
)))
334 (nicks (humanize (package-nicknames package
)))
335 (uses (humanize (package-use-list package
)))
336 (used (humanize (package-used-by-list package
)))
337 (shadows (humanize (package-shadowing-symbols package
)))
338 (this (list (package-name package
)))
340 (do-external-symbols (ext package
)
342 (setf exports
(humanize exports
))
343 (when (package-locked-p package
)
344 (format stream
"~@:_Locked."))
345 (when (set-difference implemented this
:test
#'string
=)
346 (out "Implemented-by-list" implemented
))
347 (when (set-difference implements this
:test
#'string
=)
348 (out "Implements-list" implements
))
349 (out "Nicknames" nicks
)
350 (out "Use-list" uses
)
351 (out "Used-by-list" used
)
352 (out "Shadows" shadows
)
353 (out "Exports" exports
)
354 (format stream
"~@:_~S internal symbols."
355 (package-internal-symbol-count package
))))
358 ;;;; Helpers to deal with shared functionality
360 (defun describe-class (name class stream
)
361 (let* ((by-name (not class
))
362 (name (if class
(class-name class
) name
))
363 (class (if class class
(find-class name nil
))))
365 (let ((metaclass-name (class-name (class-of class
))))
366 (pprint-logical-block (stream nil
)
368 (format stream
"~%~A names the ~(~A~) ~S:"
372 (pprint-indent :block
2 stream
))
373 (describe-documentation class t stream
)
374 (when (sb-mop:class-finalized-p class
)
375 (describe-stuff "Class precedence-list"
376 (mapcar #'class-name-or-class
(sb-mop:class-precedence-list class
))
378 (describe-stuff "Direct superclasses"
379 (mapcar #'class-name-or-class
(sb-mop:class-direct-superclasses class
))
381 (let ((subs (mapcar #'class-name-or-class
(sb-mop:class-direct-subclasses class
))))
383 (describe-stuff "Direct subclasses" subs stream
)
384 (format stream
"~@:_No subclasses.")))
385 (unless (sb-mop:class-finalized-p class
)
386 (format stream
"~@:_Not yet finalized."))
387 (if (eq 'structure-class metaclass-name
)
388 (let* ((dd (find-defstruct-description name
))
389 (slots (dd-slots dd
)))
391 (format stream
"~@:_Slots:~:{~@:_ ~S~
392 ~@:_ Type: ~A ~@[~A~]~
394 (mapcar (lambda (dsd)
398 (unless (eq t
(dsd-raw-type dsd
))
402 (format stream
"~@:_No slots.")))
403 (let ((slots (sb-mop:class-direct-slots class
)))
405 (format stream
"~@:_Direct slots:~:{~@:_ ~S~
407 ~@[~@:_ Allocation: ~S~]~
408 ~@[~@:_ Initargs: ~{~S~^, ~}~]~
409 ~@[~@:_ Initform: ~S~]~
410 ~@[~@:_ Readers: ~{~S~^, ~}~]~
411 ~@[~@:_ Writers: ~{~S~^, ~}~]~
412 ~@[~@:_ Documentation:~@:_ ~@<~@;~A~:>~]~}"
413 (mapcar (lambda (slotd)
414 (list (sb-mop:slot-definition-name slotd
)
415 (let ((type (sb-mop:slot-definition-type slotd
)))
416 (unless (eq t type
) type
))
417 (let ((alloc (sb-mop:slot-definition-allocation slotd
)))
418 (unless (eq :instance alloc
) alloc
))
419 (sb-mop:slot-definition-initargs slotd
)
420 (sb-mop:slot-definition-initform slotd
)
421 (sb-mop:slot-definition-readers slotd
)
422 (sb-mop:slot-definition-writers slotd
)
423 ;; FIXME: does this get the prefix right?
424 (quiet-doc slotd t
)))
426 (format stream
"~@:_No direct slots."))))
427 (pprint-newline :mandatory stream
))))))
429 (defun describe-instance (object stream
)
430 (let* ((class (class-of object
))
431 (slotds (sb-mop:class-slots class
))
432 (max-slot-name-length 0)
435 ;; Figure out a good width for the slot-name column.
436 (flet ((adjust-slot-name-length (name)
437 (setf max-slot-name-length
438 (max max-slot-name-length
(length (symbol-name name
))))))
439 (dolist (slotd slotds
)
440 (adjust-slot-name-length (sb-mop:slot-definition-name slotd
))
441 (push slotd
(getf plist
(sb-mop:slot-definition-allocation slotd
))))
442 (setf max-slot-name-length
(min (+ max-slot-name-length
3) 30)))
444 ;; Now that we know the width, we can print.
445 (flet ((describe-slot (name value
)
446 (format stream
"~% ~A~VT = ~A" name max-slot-name-length
447 (prin1-to-line value
))))
448 (sb-pcl::doplist
(allocation slots
) plist
449 (format stream
"~%Slots with ~S allocation:" allocation
)
450 (dolist (slotd (nreverse slots
))
452 (sb-mop:slot-definition-name slotd
)
453 (sb-pcl::slot-value-or-default object
(sb-mop:slot-definition-name slotd
))))))
455 (format stream
"~@:_No slots."))
458 (defun quiet-doc (object type
)
459 (handler-bind ((warning #'muffle-warning
))
460 (documentation object type
)))
462 (defun describe-documentation (object type stream
&optional undoc newline
)
463 (let ((doc (quiet-doc object type
)))
465 (format stream
"~@:_Documentation:~@:_")
466 (pprint-logical-block (stream nil
:per-line-prefix
" ")
469 (format stream
"~@:_(undocumented)")))
471 (pprint-newline :mandatory stream
))))
473 (defun describe-stuff (label list stream
&key
(escape t
))
476 (format stream
"~@:_~A:~@<~;~{ ~S~^,~:_~}~;~:>" label list
)
477 (format stream
"~@:_~A:~@<~;~{ ~A~^,~:_~}~;~:>" label list
))))
479 (defun describe-lambda-list (lambda-list stream
)
480 (format stream
"~@:_Lambda-list: ~:A" lambda-list
))
482 (defun describe-function-source (function stream
)
483 (if (compiled-function-p function
)
484 (let* ((code (fun-code-header (%fun-fun function
)))
485 (info (sb-kernel:%code-debug-info code
)))
487 (let ((source (sb-c::debug-info-source info
)))
489 (let ((namestring (sb-c::debug-source-namestring source
)))
490 ;; This used to also report the times the source was created
491 ;; and compiled, but that seems more like noise than useful
492 ;; information -- but FWIW that are to be had as
493 ;; SB-C::DEBUG-SOUCE-CREATED/COMPILED.
495 (format stream
"~@:_Source file: ~A" namestring
))
496 ((sb-di:debug-source-form source
)
497 (format stream
"~@:_Source form:~@:_ ~S"
498 (sb-di:debug-source-form source
)))
499 (t (bug "Don't know how to use a DEBUG-SOURCE without ~
500 a namestring or a form."))))))))
502 (let ((source (sb-eval:interpreted-function-source-location function
)))
504 (let ((namestring (sb-c:definition-source-location-namestring source
)))
506 (format stream
"~@:_Source file: ~A" namestring
)))))))
508 (defun describe-function (name function stream
)
509 (let ((name (if function
(fun-name function
) name
)))
510 (when (or function
(and (legal-fun-name-p name
) (fboundp name
)))
511 (multiple-value-bind (fun what lambda-list ftype from inline
513 (cond ((and (not function
) (symbolp name
) (special-operator-p name
))
514 (let ((fun (symbol-function name
)))
515 (values fun
"a special operator" (%fun-lambda-list fun
))))
516 ((and (not function
) (symbolp name
) (macro-function name
))
517 (let ((fun (macro-function name
)))
518 (values fun
"a macro" (%fun-lambda-list fun
))))
520 (let ((fun (or function
(fdefinition name
))))
521 (multiple-value-bind (ftype from
)
523 (values (%fun-type function
) "Derived")
524 (let ((ctype (info :function
:type name
)))
525 (values (when ctype
(type-specifier ctype
))
527 (ecase (info :function
:where-from name
)
528 (:declared
"Declared")
529 ;; This is hopefully clearer to users
530 ((:defined-method
:defined
) "Derived")
532 (if (typep fun
'generic-function
)
535 (sb-mop:generic-function-lambda-list fun
)
539 (or (sb-mop:generic-function-methods fun
)
542 (if (compiled-function-p fun
)
543 "a compiled function"
544 "an interpreted function")
545 (%fun-lambda-list fun
)
550 (info :function
:inlinep name
)
551 (info :function
:inline-expansion-designator name
)))))))))
552 (pprint-logical-block (stream nil
)
554 (format stream
"~%~A names ~A:" name what
)
555 (pprint-indent :block
2 stream
))
556 (describe-lambda-list lambda-list stream
)
557 (when (and ftype from
)
558 (format stream
"~@:_~A type: ~S" from ftype
))
559 (describe-documentation name
'function stream
)
561 (format stream
"~@:_Inline proclamation: ~A (~:[no ~;~]inline expansion available)"
565 (format stream
"~@:_Method-combination: ~S"
566 (sb-pcl::method-combination-type-name
567 (sb-pcl:generic-function-method-combination fun
)))
568 (cond ((eq :none methods
)
569 (format stream
"~@:_No methods."))
571 (pprint-newline :mandatory stream
)
572 (pprint-logical-block (stream nil
)
573 (format stream
"Methods:")
574 (dolist (method methods
)
575 (pprint-indent :block
2 stream
)
576 (format stream
"~@:_(~A ~{~S ~}~:S)"
578 (method-qualifiers method
)
579 (sb-pcl::unparse-specializers fun
(sb-mop:method-specializers method
)))
580 (pprint-indent :block
4 stream
)
581 (describe-documentation method t stream nil
))))))
582 (describe-function-source fun stream
)
585 (awhen (and (legal-fun-name-p name
) (compiler-macro-function name
))
586 (pprint-logical-block (stream nil
)
587 (format stream
"~@:_~A has a compiler-macro:" name
)
588 (pprint-indent :block
2 stream
)
589 (describe-documentation it t stream
)
590 (describe-function-source it stream
))
592 (when (and (consp name
) (eq 'setf
(car name
)) (not (cddr name
)))
593 (let* ((name2 (second name
))
594 (inverse (info :setf
:inverse name2
))
595 (expander (info :setf
:expander name2
)))
597 (pprint-logical-block (stream nil
)
598 (format stream
"~&~A has setf-expansion: ~S"
600 (pprint-indent :block
2 stream
)
601 (describe-documentation name2
'setf stream
))
604 (pprint-logical-block (stream nil
)
605 (format stream
"~&~A has a complex setf-expansion:"
607 (pprint-indent :block
2 stream
)
608 (describe-documentation name2
'setf stream t
))
611 (describe-function `(setf ,name
) nil stream
))))