1 ;;;; Inspector for sb-aclrepl
3 ;;;; The documentation, which may or may not apply in its entirety at
4 ;;;; any given time, for this functionality is on the ACL website:
5 ;;;; <http://www.franz.com/support/documentation/6.2/doc/inspector.htm>.
7 ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
10 (cl:in-package :sb-aclrepl)
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (defconstant +default-inspect-length+ 10))
16 ;; stack of parents of inspected object
18 ;; a stack of indices of parent object components
21 ;; FIXME - raw mode isn't currently used in object display
22 (defparameter *current-inspect* nil
24 (defparameter *inspect-raw* nil
25 "Raw mode for object display.")
26 (defparameter *inspect-length* +default-inspect-length+
27 "maximum number of components to print")
28 (defparameter *inspect-skip* 0
29 "number of initial components to skip when displaying an object")
31 (defvar *inspect-help*
32 ":istep takes between 0 to 3 arguments.
34 :i redisplay current object
35 :i = redisplay current object
36 :i nil redisplay current object
37 :i ? display this help
38 :i * inspect the current * value
39 :i + <form> inspect the (eval form)
40 :i <index> inspect the numbered component of object
41 :i <name> inspect the named component of object
42 :i <form> evaluation and inspect form
45 :i < inspect previous parent component
46 :i > inspect next parent component
47 :i set <index> <form> set indexed component to evalated form
48 :i set <name> <form> set named component to evalated form
49 :i print <max> set the maximum number of components to print
50 :i skip <n> skip a number of components when printing
51 :i tree print inspect stack
54 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
55 ;;; indicates that that a slot is unbound.
56 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
59 ;; Setup binding for multithreading
60 (let ((*current-inspect* nil)
62 (*inspect-length* +default-inspect-length+)
65 (defun inspector (object input-stream output-stream)
66 (declare (ignore input-stream))
67 (setq object (eval object))
68 (setq *current-inspect* (make-inspect))
69 (new-break :inspect *current-inspect*)
71 (setf (inspect-object-stack *current-inspect*) (list object))
72 (setf (inspect-parent-stack *current-inspect*)
73 (list (format nil "(inspect ~S)" object)))
74 (%inspect output-stream))
77 (defun set-current-inspect (inspect)
78 (setq *current-inspect* inspect))
80 (defun istep (arg-string output-stream)
81 (%istep arg-string output-stream))
83 (setq sb-impl::*inspect-fun* #'inspector)
86 (setf (inspect-object-stack *current-inspect*) nil)
87 (setf (inspect-parent-stack *current-inspect*) nil))
89 (defun %istep (arg-string output-stream)
90 (unless *current-inspect*
91 (setq *current-inspect* (make-inspect)))
92 (let* ((args (when arg-string (string-to-list-skip-spaces arg-string)))
94 (option-read (when arg-string
95 (read-from-string arg-string)))
96 (stack (inspect-object-stack *current-inspect*)))
99 ((or (string= "=" option)
100 (zerop (length args)))
101 (%inspect output-stream))
103 ((or (string= "-" option)
104 (string= "^" option))
106 ((> (length stack) 1)
108 (%inspect output-stream))
110 (format output-stream "Object has no parent.~%"))
112 (%inspect output-stream))))
113 ;; Select * to inspect
114 ((string= "*" option)
116 (setf (inspect-object-stack *current-inspect*) (list *))
117 (setf (inspect-parent-stack *current-inspect*) (list "(inspect ...)"))
118 (set-break-inspect *current-inspect*)
119 (%inspect output-stream))
120 ;; Start new inspect level for eval'd form
121 ((string= "+" option)
122 (inspector (eval (read-from-string (second args))) nil output-stream))
123 ;; Next or previous parent component
124 ((or (string= "<" option)
125 (string= ">" option))
127 (if (eq (length stack) 1)
128 (format output-stream "Object does not have a parent")
129 (let ((parent (second stack))
130 (id (car (inspect-parent-stack *current-inspect*))))
131 (multiple-value-bind (position list-type elements)
132 (find-object-component parent id)
133 (declare (list elements)
135 (let ((new-position (if (string= ">" option)
138 (if (< -1 new-position (length elements))
139 (let ((new-object (elt elements new-position)))
140 (setf (car stack) new-object)
141 (setf (car (inspect-parent-stack *current-inspect*))
145 (car (nth new-position elements)))))
146 (%inspect output-stream))
147 (format output-stream "Parent has no selectable component indexed by ~d"
149 (%inspect output-stream)))
150 ;; Set component to eval'd form
151 ((string-equal "set" option)
153 (let ((id (when (second args)
154 (read-from-string (second args)))))
155 (multiple-value-bind (position list-type elements)
156 (find-object-component (car stack) id)
157 (declare (ignore list-type))
160 (let ((value-stirng (third args)))
162 (let ((new-value (eval (read-from-string (third args)))))
164 (set-component-value (car stack)
167 (nth position elements))))
170 (format output-stream result))
172 (%inspect output-stream)))))))
173 (format output-stream
174 "Object has no selectable component named by ~A" id))
175 (format output-stream
176 "Object has no selectable components"))))
177 (%inspect output-stream)))
178 ;; Set/reset raw display mode for components
179 ((string-equal "raw" option)
181 (when (and (second args)
182 (or (null (second args))
183 (eq (read-from-string (second args)) t)))
184 (setq *inspect-raw* t))
185 (%inspect output-stream)))
187 ((string-equal "q" option)
189 (set-break-inspect *current-inspect*))
191 ((string-equal "?" option)
192 (format output-stream *inspect-help*))
193 ;; Set number of components to skip
194 ((string-equal "skip" option)
195 (let ((len (read-from-string (second args))))
196 (if (and (integerp len) (>= len 0))
197 (let ((*inspect-skip* len))
198 (%inspect output-stream))
199 (format output-stream "Skip missing or invalid~%"))))
201 ((string-equal "tree" option)
204 (format output-stream "The current object is:~%")
205 (dotimes (i (length stack))
206 (format output-stream "~A, ~A~%"
207 (inspected-parts (nth i stack) :description t)
208 (let ((select (nth i (inspect-parent-stack *current-inspect*))))
211 (format nil "which is componenent number ~d of" select))
213 (format nil "which is the ~a component of" select))
215 (format nil "which was selected by ~S" select))
217 (write-to-string select)))))))
218 (%inspect output-stream)))
219 ;; Set maximum number of components to print
220 ((string-equal "print" option)
221 (let ((len (read-from-string (second args))))
222 (if (and (integerp len) (plusp len))
223 (setq *inspect-length* len)
224 (format output-stream "Cannot set print limit to ~A~%" len))))
225 ;; Select numbered or named component
226 ((or (symbolp option-read)
227 (integerp option-read))
229 (multiple-value-bind (position list-type elements)
230 (find-object-component (car stack) option-read)
233 (let* ((element (elt elements position))
234 (value (if (eq list-type :named) (cdr element) element)))
235 (cond ((eq value *inspect-unbound-object-marker*)
236 (format output-stream "That slot is unbound~%"))
238 (push value (inspect-object-stack *current-inspect*))
239 (push option-read (inspect-parent-stack *current-inspect*))
240 (%inspect output-stream)))))
242 (format output-stream "Object does not contain any subobjects~%"))
244 (typecase option-read
246 (format output-stream
247 "Object has no selectable component named ~A"
250 (format output-stream
251 "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
253 (= (length elements) 1)
254 (1- (length elements))))))))
255 (%inspect output-stream)))
256 ;; Default is to select eval'd form
259 (let ((object (eval option-read)))
260 (setf (inspect-object-stack *current-inspect*) (list object))
261 (setf (inspect-parent-stack *current-inspect*)
262 (list (format nil ":i ~S" object))))
263 (set-break-inspect *current-inspect*)
264 (%inspect output-stream))
267 (defun find-object-component (object id)
268 "COMPONENT-ID can be an integer or a name of a id.
269 Returns POSITION LIST-TYPE ELEMENTS
270 POSITION is NIL if the id is invalid or not found."
272 (multiple-value-bind (description list-type elements)
273 (inspected-parts object)
274 (declare (ignore description)
277 (setq id (symbol-name id)))
279 (cond ((and (eq list-type :named)
281 (position id elements :key #'car :test #'string-equal))
283 (when (< -1 id (length elements))
285 (values position list-type elements)))
286 (values nil nil nil)))
290 (if (inspect-object-stack *current-inspect*)
291 (let ((inspected (car (inspect-object-stack *current-inspect*))))
292 (setq cl:* inspected)
293 (multiple-value-bind (description list-type elements)
294 (inspected-parts inspected)
295 (display-inspected-parts inspected description list-type elements s)))
296 (format s "No object is being inspected")))
299 (defun current-length ()
300 "returns the current LENGTH for component display"
303 (defun current-skip ()
304 "returns the current SKIP for component display"
308 (defun display-inspected-parts (object description list-type elements stream)
309 (format stream "~&~A" description)
310 (unless (or (characterp object) (typep object 'fixnum))
311 (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
312 (princ #\newline stream)
314 (let* ((n-elem (length elements))
316 (max (min last (+ *inspect-skip* *inspect-length*))))
317 (do* ((index *inspect-skip* (1+ index))
318 (count (if (typep elements 'sequence)
323 (setq element (elt elements index))
325 ((eq list-type :index-with-tail)
326 (if (eql index (- count 1))
327 (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
328 (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
329 ((eq list-type :named)
330 (destructuring-bind (name . value) element
331 (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A " name)
332 (if (eq value *inspect-unbound-object-marker*)
334 (inspected-parts value :description t)))))
336 (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))
337 (when (< (+ *inspect-skip* *inspect-length*) last)
338 (format stream "~& ...~%~4,' D ~A~%" last (elt elements last))))
341 ) ;; end binding for multithreading
347 ;;; 20030408 - Reworked by KMR to take a :DESCRIPTION keyword
348 ;;; and to return LIST-TYPE rather than NAMED-P
350 ;;; Destructure an object for inspection, returning either
352 ;;; if description keyword is T, otherwise returns
353 ;;; (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
356 ;;; DESCRIPTION is a summary description of the destructured object,
357 ;;; e.g. "the object is a CONS.~%".
359 ;;; LIST-TYPE determines what representation is used for elements
361 ;;; If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
362 ;;; If LIST-TYPE is :index-with-tail, then each element is just value,
363 ;;; but the last element is labelled as "tail"
364 ;;; If LIST-TYPE is :long, then each element is just value,
365 ;;; and suspension points ('...) are shown before the last element.
366 ;;; Otherwise, each element is just VALUE.
368 ;;; ELEMENTS is a list of the component parts of OBJECT (whose
369 ;;; representation is determined by LIST-TYPE).
371 ;;; (LIST-TYPE is useful because symbols and instances
372 ;;; need to display both a slot name and a value, while lists and
373 ;;; vectors need only display a value.)
375 (defgeneric inspected-parts (object &key description))
377 (defmethod inspected-parts ((object symbol) &key description)
378 (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
382 (list (cons "name" (symbol-name object))
383 (cons "package" (symbol-package object))
384 (cons "value" (if (boundp object)
385 (symbol-value object)
386 *inspect-unbound-object-marker*))
387 (cons "function" (if (fboundp object)
388 (symbol-function object)
389 *inspect-unbound-object-marker*))
390 (cons "plist" (symbol-plist object)))))))
392 (defun inspected-structure-elements (object)
393 (let ((parts-list '())
394 (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
395 (when (sb-kernel::defstruct-description-p info)
396 (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse parts-list))
397 (push (cons (sb-kernel:dsd-%name dd-slot)
398 (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
401 (defmethod inspected-parts ((object structure-object) &key description)
402 (let ((desc (format nil "~W" (find-class (type-of object)))))
405 (values desc :named (inspected-structure-elements object)))))
407 (defmethod inspected-parts ((object package) &key description)
408 (let ((desc (format nil "the ~A package" (package-name object))))
411 (values desc :named (inspected-structure-elements object)))))
413 (defun inspected-standard-object-elements (object)
414 (let ((reversed-elements nil)
415 (class-slots (sb-pcl::class-slots (class-of object))))
416 (dolist (class-slot class-slots (nreverse reversed-elements))
417 (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
418 (slot-value (if (slot-boundp object slot-name)
419 (slot-value object slot-name)
420 *inspect-unbound-object-marker*)))
421 (push (cons slot-name slot-value) reversed-elements)))))
423 (defmethod inspected-parts ((object standard-object) &key description)
424 (let ((desc (format nil "~W" (class-of object))))
428 (inspected-standard-object-elements object)))))
430 (defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
431 (let ((desc (format nil "a funcallable-instance of type ~S"
436 (inspected-structure-elements object)))))
438 (defmethod inspected-parts ((object function) &key description)
439 (let* ((type (sb-kernel:widetag-of object))
440 (object (if (= type sb-vm:closure-header-widetag)
441 (sb-kernel:%closure-fun object)
443 (desc (format nil "~S" object)))
447 (list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
449 (defmethod inspected-parts ((object vector) &key description)
450 (declare (vector object))
451 (let ((desc (format nil
452 "a ~:[~;displaced ~]vector (~W)"
453 (and (sb-kernel:array-header-p object)
454 (sb-kernel:%array-displaced-p object))
456 (sb-kernel:get-lisp-obj-address object))))
459 (values desc nil object))))
461 (defun inspected-index-string (index rev-dimensions)
462 (if (null rev-dimensions)
465 (dolist (dim rev-dimensions)
466 (multiple-value-bind (q r) (floor index dim)
469 (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
471 (defmethod inspected-parts ((object simple-vector) &key description)
472 (declare (simple-vector object))
473 (let ((desc (format nil "a simple ~A vector (~D)"
474 (array-element-type object)
478 (values desc nil object))))
480 (defmethod inspected-parts ((object array) &key description)
481 (declare (array object))
482 (let* ((length (array-total-size object))
483 (reference-array (make-array length :displaced-to object))
484 (dimensions (array-dimensions object))
485 (reversed-elements nil)
486 (desc (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
487 (and (sb-kernel:array-header-p object)
488 (sb-kernel:%array-displaced-p object))
489 (array-element-type object)
491 (declare (array reference-array))
496 (push (cons (format nil "~A "
497 (inspected-index-string i (reverse dimensions)))
498 (aref reference-array i))
500 (values desc :named (nreverse reversed-elements))))))
502 (defmethod inspected-parts ((object cons) &key description)
503 (if (or (consp (cdr object)) (null (cdr object)))
504 (inspected-parts-of-nontrivial-list object description)
505 (inspected-parts-of-simple-cons object description)))
507 (defun inspected-parts-of-simple-cons (object description)
508 (let ((desc (format nil "a cons pair")))
512 (list (cons "car" (car object))
513 (cons "cdr" (cdr object)))))))
515 (defun inspected-parts-of-nontrivial-list (object description)
518 (reversed-elements nil))
519 (flet ((done (description-format list-type)
520 (let ((desc (format nil description-format length length)))
521 (return-from inspected-parts-of-nontrivial-list
524 (values desc list-type (nreverse reversed-elements)))))))
526 (cond ((null in-list)
527 (done "a proper list with ~D element~P" nil))
529 (push (pop in-list) reversed-elements)
532 (push in-list reversed-elements)
533 (done "a improper list with ~D element~P" :index-with-tail)))))))
535 (defmethod inspected-parts ((object simple-string) &key description)
536 (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
539 (values desc nil object))))
541 (defmethod inspected-parts ((object double-float) &key description)
542 (let ((desc (format nil "double-float ~W" object)))
545 (values desc nil nil))))
547 (defmethod inspected-parts ((object single-float) &key description)
548 (let ((desc (format nil "single-float ~W" object)))
551 (values desc nil nil))))
553 (defmethod inspected-parts ((object fixnum) &key description)
554 (let ((desc (format nil "fixnum ~W" object)))
557 (values desc nil nil))))
559 (defmethod inspected-parts ((object complex) &key description)
560 (let ((desc (format nil "complex number ~W" object)))
564 (list (cons "real" (realpart object))
565 (cons "imag" (imagpart object)))))))
567 (defmethod inspected-parts ((object bignum) &key description)
568 (let ((desc (format nil "bignum ~W" object)))
571 (values desc nil nil))))
573 (defmethod inspected-parts ((object ratio) &key description)
574 (let ((desc (format nil "ratio ~W" object)))
578 (list (cons "numerator" (numerator object))
579 (cons "denominator" (denominator object)))))))
581 (defmethod inspected-parts ((object character) &key description)
582 (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
585 (values desc nil nil))))
587 (defmethod inspected-parts ((object t) &key description)
588 (let ((desc (format nil "a generic object ~W" object)))
591 (values desc nil nil))))
593 ;; FIXME - implement setting of component values
595 (defgeneric set-component-value (object component-id value element))
597 (defmethod set-component-value ((object cons) id value element)
598 (format nil "Cons object does not support setting of component ~A" id))
600 (defmethod set-component-value ((object array) id value element)
601 (format nil "Array object does not support setting of component ~A" id))
603 (defmethod set-component-value ((object symbol) id value element)
604 (format nil "Symbol object does not support setting of component ~A" id))
606 (defmethod set-component-value ((object structure-object) id value element)
607 (format nil "Structure object does not support setting of component ~A" id))
609 (defmethod set-component-value ((object standard-object) id value element)
610 (format nil "Standard object does not support setting of component ~A" id))
612 (defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
613 (format nil "Funcallable instance object does not support setting of component ~A" id))
615 (defmethod set-component-value ((object function) id value element)
616 (format nil "Function object does not support setting of component ~A" id))
618 ;; whn believes it is unsafe to change components of this object
619 (defmethod set-component-value ((object complex) id value element)
620 (format nil "Object does not support setting of component ~A" id))
622 ;; whn believes it is unsafe to change components of this object
623 (defmethod set-component-value ((object ratio) id value element)
624 (format nil "Object does not support setting of component ~A" id))
626 (defmethod set-component-value ((object t) id value element)
627 (format nil "Object does not support setting of component ~A" id))