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