90025b57f2bc49c725bbfbd1b756aa2ff78afc78
[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 (multiple-value-list (eval command))
112                        (nil () :report "Return to the inspector."
113                           (format stream "~%returning to the inspector~%")
114                           (return-from eval-for-inspect nil)))))
115     ;; FIXME: Much of this interactive-EVAL logic is shared with
116     ;; the main REPL EVAL and with the debugger EVAL. The code should
117     ;; be shared explicitly.
118     (setf /// // // / / result-list)
119     (setf +++ ++ ++ + + - - command)
120     (setf *** ** ** * * (car /))
121     (format stream "~&~{~S~%~}" /)))
122
123 (defun tty-display-inspected-parts (description named-p elements stream)
124   (format stream "~%~A" description)
125   (let ((index 0))
126     (dolist (element elements)
127       (if named-p
128           (destructuring-bind (name . value) element
129             (format stream "~W. ~A: ~W~%" index name
130                     (if (eq value *inspect-unbound-object-marker*)
131                         "unbound"
132                         value)))
133           (format stream "~W. ~W~%" index element))
134       (incf index))))
135 \f
136 ;;;; INSPECTED-PARTS
137
138 ;;; Destructure an object for inspection, returning
139 ;;;   (VALUES DESCRIPTION NAMED-P ELEMENTS),
140 ;;; where..
141 ;;;
142 ;;;   DESCRIPTION is a summary description of the destructured object,
143 ;;;   e.g. "The object is a CONS.~%".
144 ;;;
145 ;;;   NAMED-P determines what representation is used for elements
146 ;;;   of ELEMENTS. If NAMED-P is true, then each element is
147 ;;;   (CONS NAME VALUE); otherwise each element is just VALUE.
148 ;;;
149 ;;;   ELEMENTS is a list of the component parts of OBJECT (whose
150 ;;;   representation is determined by NAMED-P).
151 ;;;
152 ;;; (The NAMED-P dichotomy is useful because symbols and instances
153 ;;; need to display both a slot name and a value, while lists and
154 ;;; vectors need only display a value.)
155 (defgeneric inspected-parts (object))
156
157 (defmethod inspected-parts ((object symbol))
158   (values (format nil "The object is a SYMBOL.~%" object)
159           t
160           (list (cons "Name" (symbol-name object))
161                 (cons "Package" (symbol-package object))
162                 (cons "Value" (if (boundp object)
163                                   (symbol-value object)
164                                   *inspect-unbound-object-marker*))
165                 (cons "Function" (if (fboundp object)
166                                      (symbol-function object)
167                                      *inspect-unbound-object-marker*))
168                 (cons "Plist" (symbol-plist object)))))
169
170 (defun inspected-structure-elements (object)
171   (let ((parts-list '())
172         (info (layout-info (sb-kernel:layout-of object))))
173     (when (sb-kernel::defstruct-description-p info)
174       (dolist (dd-slot (dd-slots info) (nreverse parts-list))
175         (push (cons (dsd-%name dd-slot)
176                     (funcall (dsd-accessor-name dd-slot) object))
177               parts-list)))))
178
179 (defmethod inspected-parts ((object structure-object))
180   (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%"
181                   (type-of object))
182           t
183           (inspected-structure-elements object)))
184
185 (defun inspected-standard-object-elements (object)
186   (let ((reversed-elements nil)
187         (class-slots (sb-pcl::class-slots (class-of object))))
188     (dolist (class-slot class-slots (nreverse reversed-elements))
189       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
190              (slot-value (if (slot-boundp object slot-name)
191                              (slot-value object slot-name)
192                              *inspect-unbound-object-marker*)))
193         (push (cons slot-name slot-value) reversed-elements)))))
194
195 (defmethod inspected-parts ((object standard-object))
196   (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%"
197                   (type-of object))
198           t
199           (inspected-standard-object-elements object)))
200
201 (defmethod inspected-parts ((object funcallable-instance))
202   (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%"
203                   (type-of object))
204           t
205           (inspected-structure-elements object)))
206
207 (defmethod inspected-parts ((object function))
208   (let* ((type (sb-kernel:widetag-of object))
209          (object (if (= type sb-vm:closure-header-widetag)
210                      (sb-kernel:%closure-fun object)
211                      object)))
212     (values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object
213                     (sb-kernel:%simple-fun-arglist object)
214                     ;; Defined-from stuff used to be here. Someone took
215                     ;; it out. FIXME: We should make it easy to get
216                     ;; to DESCRIBE from the inspector.
217                     )
218             t
219             nil)))
220
221 (defmethod inspected-parts ((object vector))
222   (values (format nil
223                   "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%"
224                   (and (array-header-p object)
225                        (%array-displaced-p object))
226                   (length object))
227           nil
228           ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what
229           ;; does *INSPECT-LENGTH* mean?
230           (coerce object 'list)))
231
232 (defun inspected-index-string (index rev-dimensions)
233   (if (null rev-dimensions)
234       "[]"
235       (let ((list nil))
236         (dolist (dim rev-dimensions)
237           (multiple-value-bind (q r) (floor index dim)
238             (setq index q)
239             (push r list)))
240         (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
241
242 (defmethod inspected-parts ((object array))
243   (let* ((length (min (array-total-size object) *inspect-length*))
244          (reference-array (make-array length :displaced-to object))
245          (dimensions (array-dimensions object))
246          (reversed-elements nil))
247     ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what does
248     ;; *INSPECT-LENGTH* mean?
249     (dotimes (i length)
250       (push (cons (format nil
251                           "~A "
252                           (inspected-index-string i (reverse dimensions)))
253                   (aref reference-array i))
254             reversed-elements))
255     (values (format nil "The object is ~:[a displaced~;an~] ARRAY of ~A.~%~
256                          Its dimensions are ~S.~%"
257                     (array-element-type object)
258                     (and (array-header-p object)
259                          (%array-displaced-p object))
260                     dimensions)
261             t
262             (nreverse reversed-elements))))
263
264 (defmethod inspected-parts ((object cons))
265   (if (consp (cdr object))
266       (inspected-parts-of-nontrivial-list object)
267       (inspected-parts-of-simple-cons object)))
268
269 (defun inspected-parts-of-simple-cons (object)
270   (values "The object is a CONS.
271 "
272           t
273           (list (cons 'car (car object))
274                 (cons 'cdr (cdr object)))))
275
276 (defun inspected-parts-of-nontrivial-list (object)
277   (let ((length 0)
278         (in-list object)
279         (reversed-elements nil))
280     (flet ((done (description-format)
281              (return-from inspected-parts-of-nontrivial-list
282                (values (format nil description-format length)
283                        t
284                        (nreverse reversed-elements)))))
285       (loop
286        (cond ((null in-list)
287               (done "The object is a proper list of length ~S.~%"))
288              ((>= length *inspect-length*)
289               (push (cons 'rest in-list) reversed-elements)
290               (done "The object is a long list (more than ~S elements).~%"))
291              ((consp in-list)
292               (push (cons length (pop in-list)) reversed-elements)
293               (incf length))
294              (t
295               (push (cons 'rest in-list) reversed-elements)
296               (done "The object is an improper list of length ~S.~%")))))))
297
298 (defmethod inspected-parts ((object t))
299   (values (format nil "The object is an ATOM:~%  ~W~%" object) nil nil))