/[cmucl]/src/code/describe.lisp
ViewVC logotype

Contents of /src/code/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.58 - (show annotations)
Tue Jun 1 20:27:09 2010 UTC (3 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-07, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.57: +4 -3 lines
Output time in ISO 8601 format.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/describe.lisp,v 1.58 2010/06/01 20:27:09 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This is the describe mechanism for Common Lisp.
13 ;;;
14 ;;; Written by Skef Wholey or Rob MacLachlan originally.
15 ;;; Cleaned up, reorganized, and enhanced by Blaine Burks.
16 ;;; Ported to the new system and cleaned up some more by Rob MacLachlan.
17 ;;;
18 ;;; This should be done better using CLOS more effectively once CMU Common
19 ;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX
20 ;;; should be unnecessary. -- Bill Chiles
21 ;;;
22
23 (in-package "LISP")
24
25 (intl:textdomain "cmucl")
26
27 (export '(describe))
28
29 (in-package "EXT")
30 (export '(*describe-level* *describe-verbose* *describe-print-level*
31 *describe-print-length* *describe-indentation*))
32
33 (in-package "LISP")
34
35
36 ;;;; DESCRIBE public switches.
37
38 (defvar *describe-level* 2
39 "Depth of recursive descriptions allowed.")
40
41 (defvar *describe-verbose* nil
42 "If non-nil, descriptions may provide interpretations of information and
43 pointers to additional information. Normally nil.")
44
45 (defvar *describe-print-level* 2
46 "*print-level* gets bound to this inside describe. If null, use
47 *print-level*")
48
49 (defvar *describe-print-length* 5
50 "*print-length* gets bound to this inside describe. If null, use
51 *print-length*.")
52
53 (defvar *describe-indentation* 3
54 "Number of spaces that sets off each line of a recursive description.")
55
56 (defvar *in-describe* nil
57 "Used to tell whether we are doing a recursive describe.")
58 (defvar *current-describe-level* 0
59 "Used to implement recursive description cutoff. Don't touch.")
60 (defvar *describe-output* nil
61 "An output stream used by Describe for indenting and stuff.")
62 (defvar *described-objects* nil
63 "List of all objects describe within the current top-level call to describe.")
64 (defvar *current-describe-object* nil
65 "The last object passed to describe.")
66
67 ;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
68 ;;; hard stuff.
69 ;;;
70 (defun describe (x &optional stream)
71 "Prints a description of the object X."
72 (declare (type (or stream (member t nil)) stream))
73 (unless *describe-output*
74 (setq *describe-output* (make-indenting-stream *standard-output*)))
75 (cond (*in-describe*
76 (unless (or (eq x nil) (eq x t))
77 (let ((*current-describe-level* (1+ *current-describe-level*))
78 (*current-describe-object* x))
79 (indenting-further *describe-output* *describe-indentation*
80 (describe-aux x)))))
81 (t
82 (setf (indenting-stream-stream *describe-output*)
83 (case stream
84 ((t) *terminal-io*)
85 ((nil) *standard-output*)
86 (t stream)))
87 (let ((*standard-output* *describe-output*)
88 (*print-level* (or *describe-print-level* *print-level*))
89 (*print-length* (or *describe-print-length* *print-length*))
90 (*described-objects* ())
91 (*in-describe* t)
92 (*current-describe-object* x))
93 (describe-aux x))
94 (values))))
95
96 ;;; DESCRIBE-AUX does different things for each type. We punt a given call if
97 ;;; the current level is greater than *describe-level*, or if we detect an
98 ;;; object into which we have already descended.
99 ;;;
100 (defun describe-aux (x)
101 (when (or (not (integerp *describe-level*))
102 (minusp *describe-level*))
103 (error (intl:gettext "*describe-level* should be a nonnegative integer - ~A.")
104 *describe-level*))
105 (when (or (>= *current-describe-level* *describe-level*)
106 (member x *described-objects*))
107 (return-from describe-aux x))
108 (push x *described-objects*)
109 (typecase x
110 (symbol (describe-symbol x))
111 (function (describe-function x))
112 (package (describe-package x))
113 (hash-table (describe-hash-table x))
114 (instance (describe-instance x))
115 (array (describe-array x))
116 (fixnum (describe-fixnum x))
117 (character (describe-character x))
118 #+double-double
119 (double-double-float (describe-double-double-float x))
120 (cons
121 (if (and (valid-function-name-p x)
122 (fboundp x))
123 (describe-function (fdefinition x) :function x)
124 (default-describe x)))
125 (t (default-describe x)))
126 x)
127
128
129
130 ;;;; Implementation properties.
131
132 ;;; This suppresses random garbage that users probably don't want to see.
133 ;;;
134 (defparameter *implementation-properties*
135 '(%loaded-address CONDITIONS::MAKE-FUNCTION CONDITIONS::REPORT-FUNCTION
136 CONDITIONS::CONC-NAME CONDITIONS::SLOTS
137 CONDITIONS::PARENT-TYPE))
138
139
140 ;;;; Miscellaneous DESCRIBE methods:
141
142 (defun default-describe (x)
143 (format t (intl:gettext "~&~S is a ~S.") x (type-of x)))
144
145 (defun describe-character (x)
146 (format t (intl:gettext "~&~S is a ~S.") x (type-of x))
147 (format t (intl:gettext "~&Its code is #x~4,'0x.") (char-code x))
148 (format t (intl:gettext "~&Its name is ~A.") (char-name x))
149 (when (surrogatep x)
150 (format t (intl:gettext "~&It is a ~:[high (leading)~;low (trailing)~] surrogate character.")
151 (surrogatep x :low))))
152
153 (defun describe-instance (x &optional (kind :structure))
154 (cond ((let ((so-class (kernel::find-class 'standard-object nil)))
155 (and so-class (typep x so-class)))
156 (fresh-line *standard-output*)
157 (describe-object x *standard-output*))
158 (t
159 (format t (intl:gettext "~&~S is a ~(~A~) of type ~A.") x kind (type-of x))
160 (dolist (slot (cddr (inspect::describe-parts x)))
161 (format t "~%~A: ~S." (car slot) (cdr slot))))))
162
163 (defun describe-array (x)
164 (let ((rank (array-rank x))
165 (element-type (array-element-type x)))
166 (cond ((= rank 1)
167 (format t (intl:gettext "~&~S is a ~:[~;displaced ~]vector of length ~D.") x
168 (and (array-header-p x) (%array-displaced-p x))
169 (array-dimension x 0))
170 (if (array-has-fill-pointer-p x)
171 (format t (intl:gettext "~&It has a fill pointer, currently ~d")
172 (fill-pointer x))
173 (format t (intl:gettext "~&It has no fill pointer."))))
174 (t
175 (format t (intl:gettext "~&~S is ~:[an~;a displaced~] array of rank ~A")
176 x (%array-displaced-p x) rank)
177 (format t (intl:gettext "~%Its dimensions are ~S.") (array-dimensions x))))
178 (unless (eq t element-type)
179 (format t (intl:gettext "~&Its element type is specialized to ~S.") element-type))
180 (when (adjustable-array-p x)
181 (format t (intl:gettext "~&It is adjustable.")))
182 (when (static-array-p x)
183 (format t (intl:gettext "~&It is static.")))))
184
185 (defun describe-fixnum (x)
186 (cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
187 ((primep x)
188 (format t (intl:gettext "~&It is a prime number.")))
189 (t
190 (format t (intl:gettext "~&It is a composite number.")))))
191
192 #+double-double
193 (defun describe-double-double-float (x)
194 (format t (intl:gettext "~&~S is a ~S.") x (type-of x))
195 (format t (intl:gettext "~&Its components are ~S and ~S.")
196 (kernel:double-double-hi x) (kernel:double-double-lo x)))
197
198 (defun describe-hash-table (x)
199 (format t (intl:gettext "~&~S is an ~A hash table.") x (hash-table-test x))
200 (format t (intl:gettext "~&Its size is ~D buckets.") (length (hash-table-table x)))
201 (format t (intl:gettext "~&Its rehash-size is ~S.") (hash-table-rehash-size x))
202 (format t (intl:gettext "~&Its rehash-threshold is ~S.")
203 (hash-table-rehash-threshold x))
204 (format t (intl:gettext "~&It currently holds ~d entries.")
205 (hash-table-number-entries x))
206 (when (hash-table-weak-p x)
207 (format t (intl:gettext "~&It is weak ~A table.") (hash-table-weak-p x))))
208
209 (defun describe-package (x)
210 (describe-instance x)
211 (let* ((internal (package-internal-symbols x))
212 (internal-count (- (package-hashtable-size internal)
213 (package-hashtable-free internal)))
214 (external (package-external-symbols x))
215 (external-count (- (package-hashtable-size external)
216 (package-hashtable-free external))))
217 (format t (intl:gettext "~&~d symbols total: ~d internal and ~d external.")
218 (+ internal-count external-count) internal-count external-count)))
219
220
221 ;;;; Function and symbol description (documentation):
222
223 ;;; DESC-DOC prints the specified kind of documentation about the given Name.
224 ;;; If Name is null, or not a valid name, then don't print anything.
225 ;;;
226 (defun desc-doc (name kind kind-doc)
227 (when (and name (typep name '(or symbol cons)))
228 (let ((doc (documentation name kind))
229 (domain (case kind
230 (variable
231 (info variable textdomain name))
232 (function
233 (info function textdomain name))
234 (structure
235 (info typed-structure textdomain name))
236 (type
237 (info type textdomain name))
238 (setf
239 (info setf textdomain name)))))
240 (when doc
241 (format t (intl:gettext "~&~@(~A documentation:~)~& ~A")
242 (or kind-doc kind)
243 (dgettext domain doc))))))
244
245
246 ;;; DESCRIBE-FUNCTION-NAME -- Internal
247 ;;;
248 ;;; Describe various stuff about the functional semantics attached to the
249 ;;; specified Name. Type-Spec is the function type specifier extracted from
250 ;;; the definition, or NIL if none.
251 ;;;
252 (defun describe-function-name (name type-spec)
253 (let ((*print-level* nil)
254 (*print-length* nil))
255 (multiple-value-bind
256 (type where)
257 (if (valid-function-name-p name)
258 (values (type-specifier (info function type name))
259 (info function where-from name))
260 (values type-spec :defined))
261 (when (consp type)
262 (format t (intl:gettext "~&Its ~(~A~) argument types are:~% ~S")
263 where (second type))
264 (format t (intl:gettext "~&Its result type is:~% ~S") (third type)))))
265
266 (let ((inlinep (info function inlinep name)))
267 (when inlinep
268 (format t (intl:gettext "~&It is currently declared ~(~A~);~
269 ~:[no~;~] expansion is available.")
270 inlinep (info function inline-expansion name)))))
271
272
273 ;;; DESCRIBE-FUNCTION-INTERPRETED -- Internal
274 ;;;
275 ;;; Interpreted function describing; handles both closure and non-closure
276 ;;; functions. Instead of printing the compiled-from info, we print the
277 ;;; definition.
278 ;;;
279 (defun describe-function-interpreted (x kind name)
280 (multiple-value-bind (exp closure-p dname)
281 (eval:interpreted-function-lambda-expression x)
282 (let ((args (eval:interpreted-function-arglist x)))
283 (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind)
284 (cond ((not args)
285 (write-string (intl:gettext " There are no arguments.")))
286 (t
287 (write-string " ")
288 (indenting-further *standard-output* 2
289 (prin1 args)))))
290
291 (let ((name (or name dname)))
292 (desc-doc name 'function kind)
293 (unless (eq kind :macro)
294 (describe-function-name
295 name
296 (type-specifier (eval:interpreted-function-type x)))))
297
298 (when closure-p
299 (format t (intl:gettext "~&Its closure environment is:"))
300 (indenting-further *standard-output* 2
301 (let ((clos (eval:interpreted-function-closure x)))
302 (dotimes (i (length clos))
303 (format t "~&~D: ~S" i (svref clos i))))))
304
305 (format t (intl:gettext "~&Its definition is:~% ~S") exp)))
306
307
308 ;;; PRINT-COMPILED-FROM -- Internal
309 ;;;
310 ;;; Print information from the debug-info about where X was compiled from.
311 ;;;
312 (defun print-compiled-from (code-obj)
313 (let ((info (kernel:%code-debug-info code-obj)))
314 (when info
315 (let ((sources (c::debug-info-source info)))
316 (format t (intl:gettext "~&On ~A it was compiled from:")
317 (format-universal-time nil
318 (c::debug-source-compiled
319 (first sources))
320 :style :iso8601))
321 (dolist (source sources)
322 (let ((name (c::debug-source-name source)))
323 (ecase (c::debug-source-from source)
324 (:file
325 (format t (intl:gettext "~&~A~% Created: ") (namestring name))
326 (ext:format-universal-time t (c::debug-source-created source) :style :iso8601)
327 (let ((comment (c::debug-source-comment source)))
328 (when comment
329 (format t (intl:gettext "~& Comment: ~A") comment))))
330 (:stream (format t "~&~S" name))
331 (:lisp (format t "~&~S" name)))))))))
332
333
334 ;;; DESCRIBE-FUNCTION-COMPILED -- Internal
335 ;;;
336 ;;; Describe a compiled function. The closure case calls us to print the
337 ;;; guts.
338 ;;;
339 (defun describe-function-compiled (x kind name)
340 (let ((args (%function-arglist x)))
341 (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind)
342 (cond ((not args)
343 (format t (intl:gettext " There is no argument information available.")))
344 ((string= args "()")
345 (write-string (intl:gettext " There are no arguments.")))
346 (t
347 (write-string " ")
348 (indenting-further *standard-output* 2
349 (write-string args)))))
350
351 (let ((name (or name (%function-name x))))
352 (desc-doc name 'function kind)
353 (unless (eq kind :macro)
354 (describe-function-name name (%function-type x))))
355
356 (print-compiled-from (kernel:function-code-header x)))
357
358
359 (defun describe-function-byte-compiled (x kind name)
360
361 (let ((name (or name (c::byte-function-name x))))
362 (desc-doc name 'function kind)
363 (unless (eq kind :macro)
364 (describe-function-name name 'function)))
365
366 (print-compiled-from (c::byte-function-component x)))
367
368
369 ;;; DESCRIBE-FUNCTION -- Internal
370 ;;;
371 ;;; Describe a function with the specified kind and name. The latter
372 ;;; arguments provide some information about where the function came from. Kind
373 ;;; NIL means not from a name.
374 ;;;
375 (defun describe-function (x &optional (kind nil) name)
376 (declare (type function x) (type (member :macro :function nil) kind))
377 (fresh-line)
378 (ecase kind
379 (:macro (format t (intl:gettext "Macro-function: ~S") x))
380 (:function (format t (intl:gettext "Function: ~S") x))
381 ((nil)
382 (format t (intl:gettext "~S is a function.") x)))
383 (case (get-type x)
384 (#.vm:closure-header-type
385 (describe-function-compiled (%closure-function x) kind name)
386 (format t (intl:gettext "~&Its closure environment is:"))
387 (indenting-further *standard-output* 8)
388 (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset)))
389 (format t "~&~D: ~S" i (%closure-index-ref x i))))
390 ((#.vm:function-header-type #.vm:closure-function-header-type)
391 (describe-function-compiled x kind name))
392 (#.vm:funcallable-instance-header-type
393 (typecase x
394 (kernel:byte-function
395 (describe-function-byte-compiled x kind name))
396 (kernel:byte-closure
397 (describe-function-byte-compiled (byte-closure-function x)
398 kind name)
399 (format t (intl:gettext "~&Its closure environment is:"))
400 (indenting-further *standard-output* 8)
401 (let ((data (byte-closure-data x)))
402 (dotimes (i (length data))
403 (format t "~&~D: ~S" i (svref data i)))))
404 (eval:interpreted-function
405 (describe-function-interpreted x kind name))
406 (t
407 (describe-instance x :funcallable-instance))))
408 (t
409 (format t (intl:gettext "~&It is an unknown type of function.")))))
410
411
412 (defun describe-symbol (x)
413 (let ((package (symbol-package x)))
414 (if package
415 (multiple-value-bind (symbol status)
416 (find-symbol (symbol-name x) package)
417 (declare (ignore symbol))
418 (format t (intl:gettext "~&~A is an ~A symbol in the ~A package.") x
419 (string-downcase (symbol-name status))
420 (package-name (symbol-package x))))
421 (format t (intl:gettext "~&~A is an uninterned symbol.") x)))
422 ;;
423 ;; Describe the value cell.
424 (let* ((kind (info variable kind x))
425 (wot (ecase kind
426 (:special (intl:gettext "special variable"))
427 (:constant (intl:gettext "constant"))
428 (:global (intl:gettext "undefined variable"))
429 (:macro (intl:gettext "symbol macro"))
430 (:alien nil))))
431 (cond
432 ((eq kind :alien)
433 (let ((info (info variable alien-info x)))
434 (format t (intl:gettext "~&~@<It is an alien at #x~8,'0X of type ~3I~:_~S.~:>~%")
435 (sap-int (eval (alien::heap-alien-info-sap-form info)))
436 (alien-internals:unparse-alien-type
437 (alien::heap-alien-info-type info)))
438 (format t (intl:gettext "~@<Its current value is ~3I~:_~S.~:>")
439 (eval x))))
440 ((eq kind :macro)
441 (let ((expansion (info variable macro-expansion x)))
442 (format t (intl:gettext "~&It is a ~A with expansion: ~S.") wot expansion)))
443 ((boundp x)
444 (let ((value (symbol-value x)))
445 (format t (intl:gettext "~&It is a ~A; its value is ~S.") wot value)
446 (describe value)))
447 ((not (eq kind :global))
448 (format t (intl:gettext "~&It is a ~A; no current value.") wot)))
449
450 (when (eq (info variable where-from x) :declared)
451 (format t (intl:gettext "~&Its declared type is ~S.")
452 (type-specifier (info variable type x))))
453
454 (desc-doc x 'variable kind))
455 ;;
456 ;; Describe the function cell.
457 (cond ((macro-function x)
458 (describe-function (macro-function x) :macro x))
459 ((special-operator-p x)
460 (desc-doc x 'function (intl:gettext "Special form")))
461 ((fboundp x)
462 (describe-function (fdefinition x) :function x)))
463 ;;
464 ;; Print other documentation.
465 (desc-doc x 'structure (intl:gettext "Structure"))
466 (desc-doc x 'type (intl:gettext "Type"))
467 (desc-doc x 'setf (intl:gettext "Setf macro"))
468 (dolist (assoc (info random-documentation stuff x))
469 (format t (intl:gettext "~&Documentation on the ~(~A~):~%~A") (car assoc) (cdr assoc)))
470 ;;
471 ;; Print Class information
472 (let ((class (kernel::find-class x nil)))
473 (when class
474 (format t (intl:gettext "~&It names a class ~A.") class)
475 (describe class)
476 (let ((pcl-class (%class-pcl-class class)))
477 (when pcl-class
478 (format t (intl:gettext "~&It names a PCL class ~A.") pcl-class)
479 (describe pcl-class)))))
480 ;;
481 ;; Print out information about any types named by the symbol
482 (when (eq (info type kind x) :defined)
483 (format t (intl:gettext "~&It names a type specifier.")))
484 ;;
485 ;; Print out properties, possibly ignoring implementation details.
486 (do ((plist (symbol-plist X) (cddr plist)))
487 ((null plist) ())
488 (unless (member (car plist) *implementation-properties*)
489 (format t (intl:gettext "~&Its ~S property is ~S.") (car plist) (cadr plist))
490 (describe (cadr plist))))
491
492 ;; Describe where it was defined.
493 (let ((locn (info :source-location :defvar x)))
494 (when locn
495 (format t (intl:gettext "~&It is defined in:~&~A") (c::file-source-location-pathname locn)))))

  ViewVC Help
Powered by ViewVC 1.1.5