Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (Scott.Fahlman@cs.cmu.edu).
;;; **********************************************************************
;;;
;;; This is the describe mechanism for Common Lisp.
;;;
;;; Written by Skef Wholey or Rob MacLachlan originally.
;;; Cleaned up, reorganized, and enhanced by Blaine Burks.
;;;
;;; This should be done better using CLOS more effectively once CMU Common
;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX
;;; should be unnecessary. -- Bill Chiles
;;;
(in-package "LISP")
(export '(describe *describe-level* *describe-verbose*
*describe-implementation-details* *describe-print-level*
*describe-print-length* *describe-indentation*))
;;;; DESCRIBE public switches.
(defvar *describe-level* 2
"Depth of recursive descriptions allowed.")
(defvar *describe-verbose* nil
"If non-nil, descriptions may provide interpretations of information and
pointers to additional information. Normally nil.")
(defvar *describe-implementation-details* nil
"If non-null, normally concealed implementation information won't be.")
(defvar *describe-print-level* 2
"*print-level* gets bound to this inside describe.")
(defvar *describe-print-length* 5
"*print-length gets bound to this inside describe.")
(defvar *describe-indentation* 3
"Number of spaces that sets off each line of a recursive description.")
(defvar *in-describe* nil
"Used to tell whether we are doing a recursive describe.")
(defvar *current-describe-level* 0
"Used to implement recursive description cutoff. Don't touch.")
(defvar *describe-output* nil
"An output stream used by Describe for indenting and stuff.")
(defvar *used-documentation* nil "Documentation already described.")
(defvar *described-objects* nil
"List of all objects describe within the current top-level call to describe.")
(defvar *current-describe-object* nil
"The last object passed to describe.")
;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
;;; hard stuff.
;;;
(defun describe (x &optional (stream *standard-output*))
"Prints a description of the object X.
See also *describe-level*, defdescribe, *describe-verbose*,
*describe-implementation-details*, *describe-print-level*,
*describe-print-length*, and *describe-indentation*."
(unless *describe-output*
(setq *describe-output* (make-indenting-stream *standard-output*)))
(cond (*in-describe*
(unless (or (eq x nil) (eq x t))
(let ((*current-describe-level* (1+ *current-describe-level*))
(*current-describe-object* x))
(indenting-further *describe-output* *describe-indentation*
(describe-aux x)))))
(t
(setf (indenting-stream-stream *describe-output*) stream)
(let ((*standard-output* *describe-output*)
(*print-level* *describe-print-level*)
(*print-length* *describe-print-length*)
(*used-documentation* ())
(*described-objects* ())
(*in-describe* t)
(*current-describe-object* x))
(describe-aux x))
(values))))
;;; DESCRIBE-AUX does different things for each type. The order of the
;;; TYPECASE branches matters with respect to:
;;; - symbols and functions until the new standard makes them disjoint.
;;; - packages and structure since packages are structures.
;;; We punt a given call if the current level is greater than *describe-level*,
;;; or if we detect an object into which we have already descended.
;;;
(defun describe-aux (x)
(when (or (not (integerp *describe-level*))
(minusp *describe-level*))
(error "*describe-level* should be a nonnegative integer - ~A."
*describe-level*))
(when (or (>= *current-describe-level* *describe-level*)
(member x *described-objects*))
(return-from describe-aux x))
(push x *described-objects*)
(typecase x
(symbol (describe-symbol x))
(function (describe-function x))
(package (describe-package x))
(hash-table (describe-hash-table x))
(structure (describe-structure x))
(array (describe-array x))
(fixnum (describe-fixnum x))
(t (default-describe x)))
x)
;;;; Implementation properties.
;;; This supresses random garbage that users probably don't want to see.
;;;
(defparameter *implementation-properties*
'(%loaded-address
;;
;; Documentation properties:
%var-documentation %fun-documentation %struct-documentation
%type-documentation %setf-documentation %documentation))
;;;; DESCRIBE methods.
;;; DESC-DOC prints the specified kind of documentation about the given Symbol.
;;;
(defun desc-doc (symbol name string)
(let ((doc (documentation symbol name)))
(when (and doc (not (member doc *used-documentation*)))
(push doc *used-documentation*)
(format t "~&~A~& ~A" string doc))))
(defun default-describe (x)
(format t "~&~S is a ~S." x (type-of x)))
(defun describe-symbol (x)
(let ((package (symbol-package x)))
(if package
(multiple-value-bind (symbol status)
(find-symbol (symbol-name x) package)
(declare (ignore symbol))
(format t "~&~A is an ~A symbol in the ~A package." x
(string-downcase (symbol-name status))
(package-name (symbol-package x))))
(format t "~&~A is an uninterned symbol." x)))
;;
;; Describe the value cell.
(when (boundp x)
(let ((value (symbol-value x))
(constantp (constantp x)))
(cond ((get x 'globally-special)
(if constantp
(format t "~&It is a constant; its value is ~S." value)
(format t "~&It is a special variable; ~
its current binding is ~S."
value)))
(t
(fresh-line)
(write-string "Its value is ")
(print-for-describe value nil)))
(desc-doc x 'variable
(format nil "~:[Variable~;Constant~] Documentation:"
constantp))
(describe value)))
;;
;; Describe the function cell.
(cond ((macro-function x)
(let ((fun (macro-function x)))
(format t "~&Its macroexpansion function is ~A." fun)
(describe-function fun)
(desc-doc x 'function "Macro Documentation:")))
((fboundp x)
(describe-function (symbol-function x))))
;;
;; Print other documentation.
(desc-doc x 'structure "Documentation on the structure:")
(desc-doc x 'type "Documentation on the type:")
(desc-doc x 'setf "Documentation on the SETF form:")
(dolist (assoc (get x '%documentation))
(unless (member (cdr assoc) *used-documentation*)
(format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc))))
;;
;; Print out properties, possibly ignoring implementation details.
(do ((plist (symbol-plist X) (cddr plist))
(properties-to-ignore (if *describe-implementation-details*
nil
*implementation-properties*)))
((null plist) ())
(unless (member (car plist) properties-to-ignore)
(format t "~&Its ~S property is ~S." (car plist) (cadr plist))
(describe (cadr plist)))))
(defun describe-structure (x)
(format t "~&~S is a structure of type ~A." x (svref x 0))
(dolist (slot (cddr (inspect::describe-parts x)))
(format t "~%~A: ~S." (car slot) (cdr slot))))
(defun describe-array (x)
(let ((rank (array-rank x)))
(cond ((> rank 1)
(format t "~&~S is " x)
(write-string (if (%array-displaced-p x) "a displaced" "an"))
(format t " array of rank ~A." rank)
(format t "~%Its dimensions are ~S." (array-dimensions x)))
(t
(format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
(and (array-header-p x) (%array-displaced-p x)) (length x))
(if (array-has-fill-pointer-p x)
(format t "~&It has a fill pointer, currently ~d"
(fill-pointer x))
(format t "~&It has no fill pointer."))))
(format t "~&Its element type is ~S." (array-element-type x))))
(defmacro describe-function-arg-list (object test output)
`(progn
(print-for-describe ,object)
(if ,test
(write-string " is called with zero arguments.")
(indenting-further *standard-output* 2
(format t " can be called with these arguments:~%")
,output))))
(defun describe-function (x)
(declare (type function x))
(case (get-type x)
(#.vm:closure-header-type
((#.vm:function-header-type #.vm:closure-function-header-type)
(describe-function-compiled x))
(t
(format t "~&It is an unknown type of function."))))
(defun describe-function-compiled (x)
(let ((args (%function-header-arglist x)))
(describe-function-arg-list
*current-describe-object* (string= args "()") (write-string args)))
(let ((*print-level* nil)
(*print-length* nil)
(type (%function-header-type x)))
(format t "~&Its argument types are:~% ~S" (second type))
(format t "~&Its result type is:~% ~S" (third type)))
(let ((name (%function-header-name x)))
(desc-doc name 'function "Function Documention:")))
(let ((info (di::code-debug-info (di::function-code-header x))))
(when info
(let ((sources (c::compiled-debug-info-source info)))
(format t "~&On ~A it was compiled from:"
(format-universal-time nil
(c::debug-source-compiled
(first sources))))
(dolist (source sources)
(let ((name (c::debug-source-name source)))
(ecase (c::debug-source-from source)
(:file
(format t "~&~A~% Created: " (namestring name))
(ext:format-universal-time t (c::debug-source-created source))
(let ((comment (c::debug-source-comment source)))
(when comment
(format t "~& Comment: ~A" comment))))
(:stream (format t "~&~S" name))
(:lisp (format t "~&~S" name)))))))))
(defun describe-function-lex-closure (x)
(print-for-describe x)
(format t " is a lexical closure.~%")
(describe-function-compiled (%closure-function x))
(indenting-further *standard-output* 8)
(dotimes (i (get-closure-length x))
(format t "~&~D: ~S" i (%closure-index-ref x i))))
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
(defun print-for-describe (x &optional (freshp t))
(when freshp (fresh-line))
(cond ((symbolp x)
(write-string (symbol-name x)))
(t
(princ x))))
(defun describe-fixnum (x)
(cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
((primep x)
(format t "~&It is a prime number."))
(t
(format t "~&It is a composite number."))))
(defun describe-hash-table (x)
(format t "~&~S is an ~a hash table." x (hash-table-kind x))
(format t "~&Its size is ~d buckets." (hash-table-size x))
(format t "~&Its rehash-size is ~d." (hash-table-rehash-size x))
(format t "~&Its rehash-threshold is ~d."
(hash-table-rehash-threshold x))
(format t "~&It currently holds ~d entries."
(hash-table-number-entries x)))
(defun describe-package (x)
(describe-structure x)
(let* ((internal (package-internal-symbols x))
(internal-count (- (package-hashtable-size internal)
(package-hashtable-free internal)))
(external (package-external-symbols x))
(external-count (- (package-hashtable-size external)
(package-hashtable-free external))))
(format t "~&~d symbols total: ~d internal and ~d external."
(+ internal-count external-count) internal-count external-count)))