0.7.13.24:
[sbcl/simd.git] / src / code / inspect.lisp
blobf143295fd155b0e257bb32141a4eb6af19689401
1 ;;;; the CL:INSPECT function
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.
12 (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
14 (defparameter *inspect-length* 10)
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-"))
20 (defun inspect (object)
21 (catch 'quit-inspect
22 (%inspect object *standard-output*))
23 (values))
25 (defvar *inspected*)
26 (setf (documentation '*inspected* 'variable)
27 "the value currently being inspected in CL:INSPECT")
29 (defvar *help-for-inspect*
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.
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)))
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)))
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)))
95 (eval-for-inspect command s)
96 (return-from %inspect (reread)))))
98 (eval-for-inspect command s)
99 (return-from %inspect (reread)))))))))
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~%~}" /)))
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))))
127 ;;;; INSPECTED-PARTS
129 ;;; Destructure an object for inspection, returning
130 ;;; (VALUES DESCRIPTION NAMED-P ELEMENTS),
131 ;;; where..
133 ;;; DESCRIPTION is a summary description of the destructured object,
134 ;;; e.g. "The object is a CONS.~%".
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.
140 ;;; ELEMENTS is a list of the component parts of OBJECT (whose
141 ;;; representation is determined by NAMED-P).
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))
148 (defmethod inspected-parts ((object symbol))
149 (values (format nil "The object is a SYMBOL.~%" object)
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)))))
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)))))
170 (defmethod inspected-parts ((object structure-object))
171 (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%"
172 (type-of object))
174 (inspected-structure-elements object)))
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)))))
186 (defmethod inspected-parts ((object standard-object))
187 (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%"
188 (type-of object))
190 (inspected-standard-object-elements object)))
192 (defmethod inspected-parts ((object funcallable-instance))
193 (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%"
194 (type-of object))
196 (inspected-structure-elements object)))
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.
210 nil)))
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))
219 ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what
220 ;; does *INSPECT-LENGTH* mean?
221 (coerce object 'list)))
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)))))
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)
253 (nreverse reversed-elements))))
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)))
260 (defun inspected-parts-of-simple-cons (object)
261 (values "The object is a CONS.
264 (list (cons 'car (car object))
265 (cons 'cdr (cdr object)))))
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)
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))
286 (push (cons 'rest in-list) reversed-elements)
287 (done "The object is an improper list of length ~S.~%")))))))
289 (defmethod inspected-parts ((object t))
290 (values (format nil "The object is an ATOM:~% ~W~%" object) nil nil))