1.0.41.42: ppc: Documentation and NEWS updates for threading.
[sbcl.git] / src / code / inspect.lisp
1 ;;;; the CL:INSPECT function
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
13
14 (defparameter *inspect-length* 10)
15
16 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
17 ;;; indicates that that a slot is unbound.
18 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
19
20 (defun inspector (object input-stream output-stream)
21   (declare (ignore input-stream))
22   (catch 'quit-inspect
23     (%inspect object output-stream))
24   (values))
25
26 (defvar *inspect-fun* #'inspector
27   "a function of three arguments OBJECT, INPUT, and OUTPUT which starts an interactive inspector.")
28
29 (defvar *inspected*)
30 (setf (documentation '*inspected* 'variable)
31       "the value currently being inspected in CL:INSPECT")
32
33 (defun inspect (object)
34   (funcall *inspect-fun* object *standard-input* *standard-output*))
35
36 (defvar *help-for-inspect*
37   "
38 help for INSPECT:
39   Q, E        -  Quit the inspector.
40   <integer>   -  Inspect the numbered slot.
41   R           -  Redisplay current inspected object.
42   U           -  Move upward/backward to previous inspected object.
43   ?, H, Help  -  Show this help.
44   <other>     -  Evaluate the input as an expression.
45 Within the inspector, the special variable SB-EXT:*INSPECTED* is bound
46 to the current inspected object, so that it can be referred to in
47 evaluated expressions.
48 ")
49
50 (defun %inspect (*inspected* s)
51   (named-let redisplay () ; "LAMBDA, the ultimate GOTO":-|
52     (multiple-value-bind (description named-p elements)
53         (inspected-parts *inspected*)
54       (tty-display-inspected-parts description named-p elements s)
55       (named-let reread ()
56         (format s "~&> ")
57         (force-output)
58         (let* (;; newly-consed object for hermetic protection against
59                ;; mischievous input like #.*EOF-OBJECT*:
60                (eof (cons *eof-object* nil))
61                (command (read *standard-input* nil eof)))
62           (when (eq command eof)
63              ;; currently-undocumented feature: EOF is handled as Q.
64              ;; If there's ever consensus that this is *the* right
65              ;; thing to do (as opposed to e.g. handling it as U), we
66              ;; could document it. Meanwhile, it seems more Unix-y to
67              ;; do this than to signal an error.
68              (/show0 "THROWing QUIT-INSPECT for EOF")
69              (throw 'quit-inspect nil))
70           (typecase command
71             (integer
72              (let ((elements-length (length elements)))
73                (cond ((< -1 command elements-length)
74                       (let* ((element (nth command elements))
75                              (value (if named-p (cdr element) element)))
76                         (cond ((eq value *inspect-unbound-object-marker*)
77                                (format s "~%That slot is unbound.~%")
78                                (return-from %inspect (reread)))
79                               (t
80                                (%inspect value s)
81                                ;; If we ever return, then we should be
82                                ;; looking at *INSPECTED* again.
83                                (return-from %inspect (redisplay))))))
84                      ((zerop elements-length)
85                       (format s "~%The object contains nothing to inspect.~%")
86                       (return-from %inspect (reread)))
87                      (t
88                       (format s "~%Enter a valid index (~:[0-~W~;0~]).~%"
89                               (= elements-length 1) (1- elements-length))
90                       (return-from %inspect (reread))))))
91             (symbol
92              (case (find-symbol (symbol-name command) *keyword-package*)
93                ((:q :e)
94                 (/show0 "THROWing QUIT-INSPECT for :Q or :E")
95                 (throw 'quit-inspect nil))
96                (:u
97                 (return-from %inspect))
98                (:r
99                 (return-from %inspect (redisplay)))
100                ((:h :? :help)
101                 (write-string *help-for-inspect* s)
102                 (return-from %inspect (reread)))
103                (t
104                 (eval-for-inspect command s)
105                 (return-from %inspect (reread)))))
106             (t
107              (eval-for-inspect command s)
108              (return-from %inspect (reread)))))))))
109
110 (defun eval-for-inspect (command stream)
111   (let ((result-list (restart-case
112                          (multiple-value-list (interactive-eval command))
113                        (nil () :report "Return to the inspector."
114                           (format stream "~%returning to the inspector~%")
115                           (return-from eval-for-inspect nil)))))
116     (format stream "~&~{~S~%~}" result-list)))
117
118 (defun tty-display-inspected-parts (description named-p elements stream)
119   (format stream "~%~A" description)
120   (let ((index 0))
121     (dolist (element elements)
122       (if named-p
123           (destructuring-bind (name . value) element
124             (format stream "~W. ~A: ~W~%" index name
125                     (if (eq value *inspect-unbound-object-marker*)
126                         "unbound"
127                         value)))
128           (format stream "~W. ~W~%" index element))
129       (incf index))))
130 \f
131 ;;;; INSPECTED-PARTS
132
133 ;;; Destructure an object for inspection, returning
134 ;;;   (VALUES DESCRIPTION NAMED-P ELEMENTS),
135 ;;; where..
136 ;;;
137 ;;;   DESCRIPTION is a summary description of the destructured object,
138 ;;;   e.g. "The object is a CONS.~%".
139 ;;;
140 ;;;   NAMED-P determines what representation is used for elements
141 ;;;   of ELEMENTS. If NAMED-P is true, then each element is
142 ;;;   (CONS NAME VALUE); otherwise each element is just VALUE.
143 ;;;
144 ;;;   ELEMENTS is a list of the component parts of OBJECT (whose
145 ;;;   representation is determined by NAMED-P).
146 ;;;
147 ;;; (The NAMED-P dichotomy is useful because symbols and instances
148 ;;; need to display both a slot name and a value, while lists and
149 ;;; vectors need only display a value.)
150 (defgeneric inspected-parts (object))
151
152 (defmethod inspected-parts ((object symbol))
153   (values (format nil "The object is a SYMBOL.~%")
154           t
155           (list (cons "Name" (symbol-name object))
156                 (cons "Package" (symbol-package object))
157                 (cons "Value" (if (boundp object)
158                                   (symbol-value object)
159                                   *inspect-unbound-object-marker*))
160                 (cons "Function" (if (fboundp object)
161                                      (symbol-function object)
162                                      *inspect-unbound-object-marker*))
163                 (cons "Plist" (symbol-plist object)))))
164
165 (defun inspected-structure-elements (object)
166   (let ((parts-list '())
167         (info (layout-info (sb-kernel:layout-of object))))
168     (when (sb-kernel::defstruct-description-p info)
169       (dolist (dd-slot (dd-slots info) (nreverse parts-list))
170         (push (cons (dsd-name dd-slot)
171                     (funcall (dsd-accessor-name dd-slot) object))
172               parts-list)))))
173
174 (defmethod inspected-parts ((object structure-object))
175   (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%"
176                   (type-of object))
177           t
178           (inspected-structure-elements object)))
179
180 (defun inspected-standard-object-elements (object)
181   (let ((reversed-elements nil)
182         (class-slots (sb-pcl::class-slots (class-of object))))
183     (dolist (class-slot class-slots (nreverse reversed-elements))
184       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
185              (slot-value (if (slot-boundp object slot-name)
186                              (slot-value object slot-name)
187                              *inspect-unbound-object-marker*)))
188         (push (cons slot-name slot-value) reversed-elements)))))
189
190 (defmethod inspected-parts ((object standard-object))
191   (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%"
192                   (type-of object))
193           t
194           (inspected-standard-object-elements object)))
195
196 (defmethod inspected-parts ((object sb-mop:funcallable-standard-object))
197   (values (format nil "The object is a ~S of type ~S.~%"
198                   'sb-mop:funcallable-standard-object (type-of object))
199           t
200           (inspected-standard-object-elements object)))
201
202 (defmethod inspected-parts ((object condition))
203   (values (format nil "The object is a CONDITION of type ~S.~%"
204                   (type-of object))
205           t
206           (inspected-standard-object-elements object)))
207
208 (defmethod inspected-parts ((object function))
209   (values (format nil "The object is a ~A named ~S.~%"
210                   (if (closurep object) 'closure 'function)
211                   (nth-value 2 (function-lambda-expression object)))
212           t
213           ;; Defined-from stuff used to be here. Someone took
214           ;; it out. FIXME: We should make it easy to get
215           ;; to DESCRIBE from the inspector.
216           (list*
217            (cons "Lambda-list" (%fun-lambda-list object))
218            (cons "Ftype" (%fun-type object))
219            (when (closurep object)
220              (list
221               (cons "Closed over values" (%closure-values object)))))))
222
223 #+sb-eval
224 (defmethod inspected-parts ((object sb-eval:interpreted-function))
225   (values (format nil "The object is an interpreted function named ~S.~%"
226                   (nth-value 2 (function-lambda-expression object)))
227           t
228           ;; Defined-from stuff used to be here. Someone took
229           ;; it out. FIXME: We should make it easy to get
230           ;; to DESCRIBE from the inspector.
231           (list
232            (cons "Lambda-list" (sb-eval:interpreted-function-lambda-list object))
233            (cons "Definition" (function-lambda-expression object))
234            (cons "Documentation" (sb-eval:interpreted-function-documentation object)))))
235
236 (defmethod inspected-parts ((object vector))
237   (values (format nil
238                   "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%"
239                   (and (array-header-p object)
240                        (%array-displaced-p object))
241                   (length object))
242           nil
243           ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what
244           ;; does *INSPECT-LENGTH* mean?
245           (coerce object 'list)))
246
247 (defun inspected-index-string (index rev-dimensions)
248   (if (null rev-dimensions)
249       "[]"
250       (let ((list nil))
251         (dolist (dim rev-dimensions)
252           (multiple-value-bind (q r) (floor index dim)
253             (setq index q)
254             (push r list)))
255         (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
256
257 (defmethod inspected-parts ((object array))
258   (let* ((length (min (array-total-size object) *inspect-length*))
259          (reference-array (make-array length
260                                       :element-type (array-element-type object)
261                                       :displaced-to object))
262          (dimensions (array-dimensions object))
263          (reversed-elements nil))
264     ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what does
265     ;; *INSPECT-LENGTH* mean?
266     (dotimes (i length)
267       (push (cons (format nil
268                           "~A "
269                           (inspected-index-string i (reverse dimensions)))
270                   (aref reference-array i))
271             reversed-elements))
272     (values (format nil "The object is ~:[a displaced~;an~] ARRAY of ~A.~%~
273                          Its dimensions are ~S.~%"
274                     (array-element-type object)
275                     (and (array-header-p object)
276                          (%array-displaced-p object))
277                     dimensions)
278             t
279             (nreverse reversed-elements))))
280
281 (defmethod inspected-parts ((object cons))
282   (if (consp (cdr object))
283       (inspected-parts-of-nontrivial-list object)
284       (inspected-parts-of-simple-cons object)))
285
286 (defun inspected-parts-of-simple-cons (object)
287   (values "The object is a CONS.
288 "
289           t
290           (list (cons 'car (car object))
291                 (cons 'cdr (cdr object)))))
292
293 (defun inspected-parts-of-nontrivial-list (object)
294   (let ((length 0)
295         (in-list object)
296         (reversed-elements nil))
297     (flet ((done (description-format)
298              (return-from inspected-parts-of-nontrivial-list
299                (values (format nil description-format length)
300                        t
301                        (nreverse reversed-elements)))))
302       (loop
303        (cond ((null in-list)
304               (done "The object is a proper list of length ~S.~%"))
305              ((>= length *inspect-length*)
306               (push (cons 'rest in-list) reversed-elements)
307               (done "The object is a long list (more than ~S elements).~%"))
308              ((consp in-list)
309               (push (cons length (pop in-list)) reversed-elements)
310               (incf length))
311              (t
312               (push (cons 'rest in-list) reversed-elements)
313               (done "The object is an improper list of length ~S.~%")))))))
314
315 (defmethod inspected-parts ((object t))
316   (values (format nil "The object is an ATOM:~%  ~W~%" object) nil nil))