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+ 20))
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 *skip-address-display* nil
29 "Skip displaying addresses of objects.")
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 slot <name> inspect component of object, even if name is an istep cmd
41 :i <index> inspect the numbered component of object
42 :i <name> inspect the named component of object
43 :i <form> evaluation and inspect form
46 :i < inspect previous parent component
47 :i > inspect next parent component
48 :i set <index> <form> set indexed 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 (eval-when (:compile-toplevel :load-toplevel :execute)
57 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
60 (defun inspector-fun (object input-stream output-stream)
61 (let ((*current-inspect* nil)
63 (*inspect-length* *inspect-length*)
64 (*skip-address-display* nil))
65 (setq *current-inspect* (make-inspect))
66 (reset-stack object "(inspect ...)")
67 (redisplay output-stream)
68 (let ((*input* input-stream)
69 (*output* output-stream))
73 (setq sb-impl::*inspect-fun* #'inspector-fun)
75 (defun istep (args stream)
76 (unless *current-inspect*
77 (setq *current-inspect* (make-inspect)))
80 (when (first args) (read-from-string (first args)))
83 (defun istep-dispatch (args option-string option stream)
85 ((or (string= "=" option-string) (zerop (length args)))
86 (istep-cmd-redisplay stream))
87 ((or (string= "-" option-string) (string= "^" option-string))
88 (istep-cmd-parent stream))
89 ((string= "*" option-string)
90 (istep-cmd-inspect-* stream))
91 ((string= "+" option-string)
92 (istep-cmd-inspect-new-form (read-from-string (second args)) stream))
93 ((or (string= "<" option-string)
94 (string= ">" option-string))
95 (istep-cmd-select-parent-component option-string stream))
96 ((string-equal "set" option-string)
97 (istep-cmd-set (second args) (third args) stream))
98 ((string-equal "raw" option-string)
99 (istep-cmd-set-raw (second args) stream))
100 ((string-equal "q" option-string)
102 ((string-equal "?" option-string)
103 (istep-cmd-help stream))
104 ((string-equal "skip" option-string)
105 (istep-cmd-skip (second args) stream))
106 ((string-equal "tree" option-string)
107 (istep-cmd-tree stream))
108 ((string-equal "print" option-string)
109 (istep-cmd-print (second args) stream))
110 ((string-equal "slot" option-string)
111 (istep-cmd-select-component (read-from-string (second args)) stream))
112 ((or (symbolp option)
114 (istep-cmd-select-component option stream))
116 (istep-cmd-set-stack option stream))))
118 (defun set-current-inspect (inspect)
119 (setq *current-inspect* inspect))
121 (defun reset-stack (&optional object label)
124 (setf (inspect-object-stack *current-inspect*) nil)
125 (setf (inspect-select-stack *current-inspect*) nil))
127 (setf (inspect-object-stack *current-inspect*) (list object))
128 (setf (inspect-select-stack *current-inspect*) (list label)))))
130 (defun output-inspect-note (stream note &rest args)
131 (apply #'format stream note args)
132 (princ #\Newline stream))
135 (inspect-object-stack *current-inspect*))
137 (defun redisplay (stream &optional (skip 0))
138 (display-current stream *inspect-length* skip))
141 ;;; istep command processing
144 (defun istep-cmd-redisplay (stream)
147 (defun istep-cmd-parent (stream)
149 ((> (length (inspect-object-stack *current-inspect*)) 1)
150 (setf (inspect-object-stack *current-inspect*)
151 (cdr (inspect-object-stack *current-inspect*)))
152 (setf (inspect-select-stack *current-inspect*)
153 (cdr (inspect-select-stack *current-inspect*)))
156 (output-inspect-note stream "Object has no parent"))
158 (no-object-msg stream))))
160 (defun istep-cmd-inspect-* (stream)
161 (reset-stack * "(inspect *)")
164 (defun istep-cmd-inspect-new-form (form stream)
165 (inspector-fun (eval form) nil stream))
167 (defun istep-cmd-select-parent-component (option stream)
169 (if (eql (length (stack)) 1)
170 (output-inspect-note stream "Object does not have a parent")
171 (let ((parent (second (stack)))
172 (id (car (inspect-select-stack *current-inspect*))))
173 (multiple-value-bind (position parts)
174 (find-part-id parent id)
175 (let ((new-position (if (string= ">" option)
178 (if (< -1 new-position (parts-count parts))
179 (let* ((value (component-at parts new-position)))
180 (setf (car (inspect-object-stack *current-inspect*))
182 (setf (car (inspect-select-stack *current-inspect*))
183 (id-at parts new-position))
185 (output-inspect-note stream
186 "Parent has no selectable component indexed by ~d"
188 (no-object-msg stream)))
190 (defun istep-cmd-set-raw (option-string stream)
191 (when (inspect-object-stack *current-inspect*)
193 ((null option-string)
194 (setq *inspect-raw* t))
195 ((eq (read-from-string option-string) t)
196 (setq *inspect-raw* t))
197 ((eq (read-from-string option-string) nil)
198 (setq *inspect-raw* nil)))
201 (defun istep-cmd-reset ()
203 (throw 'repl-catcher (values :inspect nil)))
205 (defun istep-cmd-help (stream)
206 (format stream *inspect-help*))
208 (defun istep-cmd-skip (option-string stream)
210 (let ((len (read-from-string option-string)))
211 (if (and (integerp len) (>= len 0))
212 (redisplay stream len)
213 (output-inspect-note stream "Skip length invalid")))
214 (output-inspect-note stream "Skip length missing")))
216 (defun istep-cmd-print (option-string stream)
218 (let ((len (read-from-string option-string)))
219 (if (and (integerp len) (plusp len))
220 (setq *inspect-length* len)
221 (output-inspect-note stream "Cannot set print limit to ~A~%" len)))
222 (output-inspect-note stream "Print length missing")))
224 (defun select-description (select)
227 (format nil "which is componenent number ~d of" select))
229 (format nil "which is the ~a component of" select))
231 (format nil "which was selected by ~A" select))
233 (write-to-string select))))
235 (defun istep-cmd-tree (stream)
236 (let ((stack (inspect-object-stack *current-inspect*)))
239 (output-inspect-note stream "The current object is:")
240 (dotimes (i (length stack))
243 (inspected-description (nth i stack))
245 (nth i (inspect-select-stack *current-inspect*))))))
246 (no-object-msg stream))))
248 (defun istep-cmd-set (id-string value-string stream)
250 (let ((id (when id-string (read-from-string id-string))))
251 (multiple-value-bind (position parts)
252 (find-part-id (car (stack)) id)
256 (let ((new-value (eval (read-from-string value-string))))
257 (let ((result (set-component-value (car (stack))
264 (output-inspect-note stream result))
266 (redisplay stream))))))
269 "Object has no selectable component named by ~A" id))
270 (output-inspect-note stream
271 "Object has no selectable components"))))
272 (no-object-msg stream)))
274 (defun istep-cmd-select-component (id stream)
276 (multiple-value-bind (position parts)
277 (find-part-id (car (stack)) id)
280 (let* ((value (component-at parts position)))
281 (cond ((eq value *inspect-unbound-object-marker*)
282 (output-inspect-note stream "That slot is unbound"))
284 (push value (inspect-object-stack *current-inspect*))
285 (push id (inspect-select-stack *current-inspect*))
286 (redisplay stream)))))
288 (output-inspect-note stream "Object does not contain any subobjects"))
293 stream "Object has no selectable component named ~A"
297 stream "Object has no selectable component indexed by ~d"
299 (no-object-msg stream)))
301 (defun istep-cmd-set-stack (form stream)
302 (reset-stack (eval form) ":i ...")
306 (defun no-object-msg (s)
307 (output-inspect-note s "No object is being inspected"))
309 (defun display-current (s length skip)
311 (let ((inspected (car (stack))))
312 (setq cl:* inspected)
313 (display-inspect inspected s length skip))
318 ;;; aclrepl-specific inspection display
321 (defun display-inspect (object stream &optional length (skip 0))
322 (multiple-value-bind (elements labels count)
323 (inspected-elements object length skip)
325 (format stream "~A" (inspected-description object))
326 (unless (or *skip-address-display*
327 (eq object *inspect-unbound-object-marker*)
328 (characterp object) (typep object 'fixnum))
329 (format stream " at #x~X" (logand
330 (sb-kernel:get-lisp-obj-address object)
331 (lognot sb-vm:lowtag-mask))))
334 (display-labeled-element (elt elements i) (elt labels i) stream))))
336 (defun hex32-label-p (label)
337 (and (consp label) (eq (cdr label) :hex32)))
339 (defun array-label-p (label)
341 (stringp (cdr label))
342 (char= (char (cdr label) 0) #\[)))
344 (defun named-or-array-label-p (label)
346 (not (hex32-label-p label))))
348 (defun display-labeled-element (element label stream)
350 ((eq label :ellipses)
351 (format stream " ..."))
353 (format stream "tail-> ~A" (inspected-description element)))
354 ((named-or-array-label-p label)
356 (if (array-label-p label)
358 "~4,' D ~16,1,1,'-A> ~A")
360 (format nil "~A " (cdr label))
361 (inspected-description element)))
362 ((hex32-label-p label)
363 (format stream "~4,' D-> #x~8,'0X" (car label) element))
365 (format stream "~4,' D-> ~A" label (inspected-description element)))))
367 ;;; THE BEGINNINGS OF AN INSPECTOR API
368 ;;; which can be used to retrieve object descriptions as component values/labels and also
369 ;;; process print length and skip selectors
371 ;;; FUNCTIONS TO CONSIDER FOR EXPORT
375 ;;; INSPECTED-ELEMENTS
376 ;;; INSPECTED-DESCRIPTION
378 ;;; will also need hooks
379 ;;; *inspect-start-inspection*
380 ;;; (maybe. Would setup a window for a GUI inspector)
381 ;;; *inspect-prompt-fun*
382 ;;; *inspect-read-cmd*
384 ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
385 ;;; That'll depend if choose to have standardized inspector commands such that
386 ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
387 ;;; process and then call the *inspect-display* hook, or if the
388 ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will
389 ;;; send to the contributed inspector for processing and display.
391 (defun find-part-id (object id)
392 "COMPONENT-ID can be an integer or a name of a id.
393 Returns (VALUES POSITION PARTS).
394 POSITION is NIL if the id is invalid or not found."
395 (let* ((parts (inspected-parts object))
396 (name (if (symbolp id) (symbol-name id) id)))
400 (< -1 id (parts-count parts))
401 (not (eq (parts-seq-type parts) :bignum)))
404 (case (parts-seq-type parts)
406 (position name (the list (parts-components parts))
407 :key #'car :test #'string-equal))
408 ((:dotted-list :cyclic-list)
409 (when (string-equal name "tail")
410 (1- (parts-count parts)))))))
413 (defun component-at (parts position)
414 (let ((count (parts-count parts))
415 (components (parts-components parts)))
416 (when (< -1 position count)
417 (case (parts-seq-type parts)
419 (if (= position (1- count))
420 (cdr (last components))
421 (elt components position)))
423 (if (= position (1- count))
425 (elt components position)))
427 (cdr (elt components position)))
429 (aref (the array components) position))
431 (bignum-component-at components position))
433 (elt components position))))))
435 (defun id-at (parts position)
436 (let ((count (parts-count parts)))
437 (when (< -1 position count)
438 (case (parts-seq-type parts)
439 ((:dotted-list :cyclic-list)
440 (if (= position (1- count))
444 (array-index-string position parts))
446 (car (elt (parts-components parts) position)))
450 (defun inspected-elements (object &optional length (skip 0))
451 "Returns elements of an object that have been trimmed and labeled based on
452 length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT)
453 where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items.
454 LABELS elements may be a string, number, cons pair, :tail, or :ellipses.
455 This function may return an ELEMENT-COUNT of up to (+ 3 length) which would
456 include an :ellipses at the beginning, :ellipses at the end,
457 and the last element."
458 (let* ((parts (inspected-parts object))
459 (print-length (if length length (parts-count parts)))
460 (last-part (last-part parts))
461 (last-requested (last-requested parts print-length skip))
462 (element-count (compute-elements-count parts print-length skip))
463 (first-to (if (first-element-ellipses-p parts skip) 1 0))
464 (elements (when (plusp element-count) (make-array element-count)))
465 (labels (when (plusp element-count) (make-array element-count))))
466 (when (plusp element-count)
467 ;; possible first ellipses
468 (when (first-element-ellipses-p parts skip)
469 (set-element-values elements labels 0 nil :ellipses))
472 ((> i (- last-requested skip)))
473 (set-element elements labels parts (+ i first-to) (+ i skip)))
474 ;; last parts value if needed
475 (when (< last-requested last-part)
476 (set-element elements labels parts (- element-count 1) last-part))
477 ;; ending ellipses or next to last parts value if needed
478 (when (< last-requested (1- last-part))
479 (if (= last-requested (- last-part 2))
480 (set-element elements labels parts (- element-count 2) (1- last-part))
481 (set-element-values elements labels (- element-count 2) nil :ellipses))))
482 (values elements labels element-count)))
484 (defun last-requested (parts print skip)
485 (min (1- (parts-count parts)) (+ skip print -1)))
487 (defun last-part (parts)
488 (1- (parts-count parts)))
490 (defun compute-elements-count (parts length skip)
491 "Compute the number of elements in parts given the print length and skip."
492 (let ((element-count (min (parts-count parts) length
493 (max 0 (- (parts-count parts) skip)))))
494 (when (and (plusp (parts-count parts)) (plusp skip)) ; starting ellipses
495 (incf element-count))
496 (when (< (last-requested parts length skip)
497 (last-part parts)) ; last value
499 (when (< (last-requested parts length skip)
500 (1- (last-part parts))) ; ending ellipses
501 (incf element-count)))
504 (defun set-element (elements labels parts to-index from-index)
505 (set-element-values elements labels to-index (component-at parts from-index)
506 (label-at parts from-index)))
508 (defun set-element-values (elements labels index element label)
509 (setf (aref elements index) element)
510 (setf (aref labels index) label))
512 (defun first-element-ellipses-p (parts skip)
513 (and (parts-count parts) (plusp skip)))
515 (defun label-at (parts position)
516 "Helper function for inspected-elements. Conses the
517 position with the label if the label is a string."
518 (let ((id (id-at parts position)))
522 ((eq (parts-seq-type parts) :bignum)
523 (cons position :hex32))
527 (defun array-index-string (index parts)
528 "Formats an array index in row major format."
529 (let ((rev-dimensions (parts-seq-hint parts)))
530 (if (null rev-dimensions)
533 (dolist (dim rev-dimensions)
534 (multiple-value-bind (q r) (floor index dim)
537 (format nil "[~W~{,~W~}]" (car list) (cdr list))))))
540 ;;; INSPECTED-DESCRIPTION
542 ;;; Accepts an object and returns
543 ;;; DESCRIPTION is a summary description of the destructured object,
544 ;;; e.g. "the object is a CONS".
546 (defgeneric inspected-description (object))
548 (defmethod inspected-description ((object symbol))
549 (format nil "the symbol ~A" object))
551 (defmethod inspected-description ((object structure-object))
552 (format nil "~W" (find-class (type-of object))))
554 (defmethod inspected-description ((object package))
555 (format nil "the ~A package" (package-name object)))
557 (defmethod inspected-description ((object standard-object))
558 (format nil "~W" (class-of object)))
560 (defmethod inspected-description ((object sb-kernel:funcallable-instance))
561 (format nil "a funcallable-instance of type ~S" (type-of object)))
563 (defmethod inspected-description ((object function))
564 (format nil "~S" object) nil)
566 (defmethod inspected-description ((object vector))
567 (declare (vector object))
568 (format nil "a ~:[~;displaced ~]vector (~W)"
569 (and (sb-kernel:array-header-p object)
570 (sb-kernel:%array-displaced-p object))
573 (defmethod inspected-description ((object simple-vector))
574 (declare (simple-vector object))
575 (format nil "a simple ~A vector (~D)"
576 (array-element-type object)
579 (defmethod inspected-description ((object array))
580 (declare (array object))
581 (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
582 (and (sb-kernel:array-header-p object)
583 (sb-kernel:%array-displaced-p object))
584 (array-element-type object)
585 (array-dimensions object)))
587 (defun simple-cons-pair-p (object)
590 (defmethod inspected-description ((object cons))
591 (if (simple-cons-pair-p object)
593 (inspected-description-of-nontrivial-list object)))
595 (defun cons-safe-length (object)
596 "Returns (VALUES LENGTH LIST-TYPE) where length is the number of
597 cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
598 (do ((length 1 (1+ length))
599 (lst (cdr object) (cdr lst)))
600 ((or (not (consp lst))
604 (values length :normal))
606 (values length :dotted))
608 (values length :cyclic))))
609 ;; nothing to do in body
612 (defun inspected-description-of-nontrivial-list (object)
613 (multiple-value-bind (length list-type) (cons-safe-length object)
614 (format nil "a ~A list with ~D element~:*~P~A"
615 (string-downcase (symbol-name list-type)) length
617 ((:dotted :cyclic) "+tail")
620 (defun ref32-hexstr (obj &optional (offset 0))
621 (format nil "~8,'0X" (ref32 obj offset)))
623 (defun ref32 (obj &optional (offset 0))
624 (sb-sys::without-gcing
627 (logand (sb-kernel:get-lisp-obj-address obj) (lognot sb-vm:lowtag-mask)))
630 (defun description-maybe-internals (fmt objects internal-fmt &rest args)
631 (let ((base (apply #'format nil fmt objects)))
632 (if *skip-address-display*
635 base " " (apply #'format nil internal-fmt args)))))
637 (defmethod inspected-description ((object double-float))
638 (description-maybe-internals "double-float ~W" (list object)
640 (ref32-hexstr object 12)
641 (ref32-hexstr object 8)))
643 (defmethod inspected-description ((object single-float))
644 (description-maybe-internals "single-float ~W" (list object)
646 (ref32-hexstr object 4)))
648 (defmethod inspected-description ((object fixnum))
649 (description-maybe-internals "fixnum ~W" (list object)
651 (ash object (1- sb-vm:n-lowtag-bits))))
653 (defmethod inspected-description ((object complex))
654 (format nil "complex number ~W" object))
656 (defmethod inspected-description ((object simple-string))
657 (format nil "a simple-string (~W) ~W" (length object) object))
659 (defun bignum-words (bignum)
660 "Return the number of 32-bit words in a bignum"
662 (logand (ref32 bignum)
663 (lognot sb-vm:widetag-mask))
664 (- sb-vm:n-widetag-bits)))
666 (defun bignum-component-at (bignum offset)
667 "Return the 32-bit word at 32-bit wide offset"
668 (ref32 bignum (* 4 (1+ offset))))
670 (defmethod inspected-description ((object bignum))
671 (format nil "bignum ~W with ~D 32-bit word~:*~P" object
672 (bignum-words object)))
674 (defmethod inspected-description ((object ratio))
675 (format nil "ratio ~W" object))
677 (defmethod inspected-description ((object character))
678 ;; FIXME: This will need to change as and when we get more characters
679 ;; than just the 256 we have today.
680 (description-maybe-internals "character ~W char-code #x~2,'0X"
681 (list object (char-code object))
683 (logior sb-vm:base-char-widetag
684 (ash (char-code object)
685 sb-vm:n-widetag-bits))))
687 (defmethod inspected-description ((object t))
688 (format nil "a generic object ~W" object))
690 (defmethod inspected-description ((object (eql *inspect-unbound-object-marker*)))
696 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
697 ;;; (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
700 ;;; COMPONENTS are the component parts of OBJECT (whose
701 ;;; representation is determined by SEQ-TYPE). Except for the
702 ;;; SEQ-TYPE :named and :array, components is just the OBJECT itself
704 ;;; SEQ-TYPE determines what representation is used for components
706 ;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
707 ;;; If SEQ-TYPE is :dotted-list, then each element is just value,
708 ;;; but the last element must be retrieved by
709 ;;; (cdr (last components))
710 ;;; If SEQ-TYPE is :cylic-list, then each element is just value,
711 ;;; If SEQ-TYPE is :list, then each element is a value of an array
712 ;;; If SEQ-TYPE is :vector, then each element is a value of an vector
713 ;;; If SEQ-TYPE is :array, then each element is a value of an array
714 ;;; with rank >= 2. The
715 ;;; If SEQ-TYPE is :bignum, then object is just a bignum and not a
718 ;;; COUNT is the total number of components in the OBJECT
720 ;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
721 ;;; to hold the reverse-dimensions of the orignal array.
723 (declaim (inline parts-components))
724 (defun parts-components (parts)
727 (declaim (inline parts-count))
728 (defun parts-count (parts)
731 (declaim (inline parts-seq-type))
732 (defun parts-seq-type (parts)
735 (declaim (inline parts-seq-hint))
736 (defun parts-seq-hint (parts)
739 (defgeneric inspected-parts (object)
742 (defmethod inspected-parts ((object symbol))
744 (list (cons "NAME" (symbol-name object))
745 (cons "PACKAGE" (symbol-package object))
746 (cons "VALUE" (if (boundp object)
747 (symbol-value object)
748 *inspect-unbound-object-marker*))
749 (cons "FUNCTION" (if (fboundp object)
750 (symbol-function object)
751 *inspect-unbound-object-marker*))
752 (cons "PLIST" (symbol-plist object)))))
753 (list components (length components) :named nil)))
755 (defun inspected-structure-parts (object)
756 (let ((components-list '())
757 (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
758 (when (sb-kernel::defstruct-description-p info)
759 (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
760 (push (cons (string (sb-kernel:dsd-name dd-slot))
761 (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
764 (defmethod inspected-parts ((object structure-object))
765 (let ((components (inspected-structure-parts object)))
766 (list components (length components) :named nil)))
768 (defun inspected-standard-object-parts (object)
769 (let ((components nil)
770 (class-slots (sb-pcl::class-slots (class-of object))))
771 (dolist (class-slot class-slots components)
772 (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
773 (slot-value (if (slot-boundp object slot-name)
774 (slot-value object slot-name)
775 *inspect-unbound-object-marker*)))
776 (push (cons (symbol-name slot-name) slot-value) components)))))
779 (defmethod inspected-parts ((object standard-object))
780 (let ((components (inspected-standard-object-parts object)))
781 (list components (length components) :named nil)))
783 (defmethod inspected-parts ((object sb-kernel:funcallable-instance))
784 (let ((components (inspected-standard-object-parts object)))
785 (list components (length components) :named nil)))
787 (defmethod inspected-parts ((object condition))
788 (let ((components (inspected-standard-object-parts object)))
789 (list components (length components) :named nil)))
791 (defmethod inspected-parts ((object function))
792 (let* ((type (sb-kernel:widetag-of object))
793 (object (if (= type sb-vm:closure-header-widetag)
794 (sb-kernel:%closure-fun object)
796 (components (list (cons "arglist"
797 (sb-kernel:%simple-fun-arglist object)))))
798 (list components (length components) :named nil)))
800 (defmethod inspected-parts ((object vector))
801 (list object (length object) :vector nil))
803 (defmethod inspected-parts ((object array))
804 (let ((size (array-total-size object)))
805 (list (make-array size :displaced-to object)
808 (reverse (array-dimensions object)))))
810 (defmethod inspected-parts ((object cons))
811 (if (simple-cons-pair-p object)
812 (inspected-parts-of-simple-cons object)
813 (inspected-parts-of-nontrivial-list object)))
815 (defun inspected-parts-of-simple-cons (object)
816 (let ((components (list (cons "car" (car object))
817 (cons "cdr" (cdr object)))))
818 (list components 2 :named nil)))
820 (defun inspected-parts-of-nontrivial-list (object)
821 (multiple-value-bind (count list-type) (cons-safe-length object)
824 (list object count :list nil))
826 (list object (1+ count) :cyclic-list nil))
828 ;; count tail element
829 (list object (1+ count) :dotted-list nil)))))
831 (defmethod inspected-parts ((object complex))
832 (let ((components (list (cons "real" (realpart object))
833 (cons "imag" (imagpart object)))))
834 (list components (length components) :named nil)))
836 (defmethod inspected-parts ((object ratio))
837 (let ((components (list (cons "numerator" (numerator object))
838 (cons "denominator" (denominator object)))))
839 (list components (length components) :named nil)))
841 (defmethod inspected-parts ((object bignum))
842 (list object (bignum-words object) :bignum nil))
844 (defmethod inspected-parts ((object t))
845 (list nil 0 nil nil))
848 ;; FIXME - implement setting of component values
850 (defgeneric set-component-value (object component-id value element))
852 (defmethod set-component-value ((object cons) id value element)
853 (format nil "Cons object does not support setting of component ~A" id))
855 (defmethod set-component-value ((object array) id value element)
856 (format nil "Array object does not support setting of component ~A" id))
858 (defmethod set-component-value ((object symbol) id value element)
859 (format nil "Symbol object does not support setting of component ~A" id))
861 (defmethod set-component-value ((object structure-object) id value element)
862 (format nil "Structure object does not support setting of component ~A" id))
864 (defmethod set-component-value ((object standard-object) id value element)
865 (format nil "Standard object does not support setting of component ~A" id))
867 (defmethod set-component-value ((object t) id value element)
868 (format nil "Object does not support setting of component ~A" id))