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")
30 (defparameter *skip-address-display
* nil
31 "Skip displaying addresses of objects.")
33 (defvar *inspect-help
*
34 ":istep takes between 0 to 3 arguments.
36 :i redisplay current object
37 :i = redisplay current object
38 :i nil redisplay current object
39 :i ? display this help
40 :i * inspect the current * value
41 :i + <form> inspect the (eval form)
42 :i <index> inspect the numbered component of object
43 :i <name> inspect the named component of object
44 :i <form> evaluation and inspect form
47 :i < inspect previous parent component
48 :i > inspect next parent component
49 :i set <index> <form> set indexed component to evalated form
50 i set <name> <form> set named component to evalated form
51 :i print <max> set the maximum number of components to print
52 :i skip <n> skip a number of components when printing
53 :i tree print inspect stack
56 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
57 ;;; indicates that that a slot is unbound.
58 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
59 (defvar *inspect-unbound-object-marker
* (gensym "INSPECT-UNBOUND-OBJECT-")))
62 ;; Setup binding for multithreading
63 (let ((*current-inspect
* nil
)
65 (*inspect-length
* +default-inspect-length
+)
67 (*skip-address-display
* nil
))
69 (defun inspector (object input-stream output-stream
)
70 (declare (ignore input-stream
))
71 (setq object
(eval object
))
72 (setq *current-inspect
* (make-inspect))
73 (new-break :inspect
*current-inspect
*)
75 (setf (inspect-object-stack *current-inspect
*) (list object
))
76 (setf (inspect-select-stack *current-inspect
*)
77 (list (format nil
"(inspect ...)")))
78 (redisplay output-stream
))
80 (setq sb-impl
::*inspect-fun
* #'inspector
)
82 (defun istep (args stream
)
83 (unless *current-inspect
*
84 (setq *current-inspect
* (make-inspect)))
87 (when (first args
) (read-from-string (first args
)))
90 (defun istep-dispatch (args option-string option stream
)
92 ((or (string= "=" option-string
) (zerop (length args
)))
93 (istep-cmd-redisplay stream
))
94 ((or (string= "-" option-string
) (string= "^" option-string
))
95 (istep-cmd-parent stream
))
96 ((string= "*" option-string
)
97 (istep-cmd-inspect-* stream
))
98 ((string= "+" option-string
)
99 (istep-cmd-inspect-new-form (read-from-string (second args
)) stream
))
100 ((or (string= "<" option-string
)
101 (string= ">" option-string
))
102 (istep-cmd-select-parent-component option-string stream
))
103 ((string-equal "set" option-string
)
104 (istep-cmd-set (second args
) (third args
) stream
))
105 ((string-equal "raw" option-string
)
106 (istep-cmd-set-raw (second args
) stream
))
107 ((string-equal "q" option-string
)
109 ((string-equal "?" option-string
)
110 (istep-cmd-help stream
))
111 ((string-equal "skip" option-string
)
112 (istep-cmd-skip (second args
) stream
))
113 ((string-equal "tree" option-string
)
114 (istep-cmd-tree stream
))
115 ((string-equal "print" option-string
)
116 (istep-cmd-print (second args
) stream
))
117 ((or (symbolp option
)
119 (istep-cmd-select-component option stream
))
121 (istep-cmd-set-stack option stream
))))
123 (defun set-current-inspect (inspect)
124 (setq *current-inspect
* inspect
))
126 (defun reset-stack ()
127 (setf (inspect-object-stack *current-inspect
*) nil
)
128 (setf (inspect-select-stack *current-inspect
*) nil
))
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)
138 (display-current stream
))
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)
162 (setf (inspect-object-stack *current-inspect
*) (list *))
163 (setf (inspect-select-stack *current-inspect
*) (list "(inspect *)"))
164 (set-break-inspect *current-inspect
*)
167 (defun istep-cmd-inspect-new-form (form stream
)
168 (inspector (eval form
) nil stream
))
170 (defun istep-cmd-select-parent-component (option stream
)
172 (if (eql (length (stack)) 1)
173 (output-inspect-note stream
"Object does not have a parent")
174 (let ((parent (second (stack)))
175 (id (car (inspect-select-stack *current-inspect
*))))
176 (multiple-value-bind (position parts
)
177 (find-part-id parent id
)
178 (let ((new-position (if (string= ">" option
)
181 (if (< -
1 new-position
(parts-count parts
))
182 (let* ((value (component-at parts new-position
)))
183 (setf (car (inspect-object-stack *current-inspect
*))
185 (setf (car (inspect-select-stack *current-inspect
*))
186 (id-at parts new-position
))
188 (output-inspect-note stream
189 "Parent has no selectable component indexed by ~d"
191 (no-object-msg stream
)))
193 (defun istep-cmd-set-raw (option-string stream
)
194 (when (inspect-object-stack *current-inspect
*)
196 ((null option-string
)
197 (setq *inspect-raw
* t
))
198 ((eq (read-from-string option-string
) t
)
199 (setq *inspect-raw
* t
))
200 ((eq (read-from-string option-string
) nil
)
201 (setq *inspect-raw
* nil
)))
204 (defun istep-cmd-reset ()
206 (set-break-inspect *current-inspect
*))
208 (defun istep-cmd-help (stream)
209 (format stream
*inspect-help
*))
211 (defun istep-cmd-skip (option-string stream
)
213 (let ((len (read-from-string option-string
)))
214 (if (and (integerp len
) (>= len
0))
215 (let ((*inspect-skip
* len
))
217 (output-inspect-note stream
"Skip length invalid")))
218 (output-inspect-note stream
"Skip length missing")))
220 (defun istep-cmd-print (option-string stream
)
222 (let ((len (read-from-string option-string
)))
223 (if (and (integerp len
) (plusp len
))
224 (setq *inspect-length
* len
)
225 (output-inspect-note stream
"Cannot set print limit to ~A~%" len
)))
226 (output-inspect-note stream
"Print length missing")))
228 (defun select-description (select)
231 (format nil
"which is componenent number ~d of" select
))
233 (format nil
"which is the ~a component of" select
))
235 (format nil
"which was selected by ~A" select
))
237 (write-to-string select
))))
239 (defun istep-cmd-tree (stream)
240 (let ((stack (inspect-object-stack *current-inspect
*)))
243 (output-inspect-note stream
"The current object is:")
244 (dotimes (i (length stack
))
247 (inspected-description (nth i stack
))
249 (nth i
(inspect-select-stack *current-inspect
*))))))
250 (no-object-msg stream
))))
252 (defun istep-cmd-set (id-string value-string stream
)
254 (let ((id (when id-string
(read-from-string id-string
))))
255 (multiple-value-bind (position parts
)
256 (find-part-id (car (stack)) id
)
260 (let ((new-value (eval (read-from-string value-string
))))
261 (let ((result (set-component-value (car (stack))
268 (output-inspect-note stream result
))
270 (redisplay stream
))))))
273 "Object has no selectable component named by ~A" id
))
274 (output-inspect-note stream
275 "Object has no selectable components"))))
276 (no-object-msg stream
)))
278 (defun istep-cmd-select-component (id stream
)
280 (multiple-value-bind (position parts
)
281 (find-part-id (car (stack)) id
)
284 (let* ((value (component-at parts position
)))
285 (cond ((eq value
*inspect-unbound-object-marker
*)
286 (output-inspect-note stream
"That slot is unbound"))
288 (push value
(inspect-object-stack *current-inspect
*))
289 (push id
(inspect-select-stack *current-inspect
*))
290 (redisplay stream
)))))
292 (output-inspect-note stream
"Object does not contain any subobjects"))
297 stream
"Object has no selectable component named ~A"
301 stream
"Object has no selectable component indexed by ~d"
304 stream
"Enter a valid index (~:[0-~W~;0~])"
305 (= (parts-count parts
) 1)
306 (1- (parts-count parts
))))))))
307 (no-object-msg stream
)))
309 (defun istep-cmd-set-stack (form stream
)
311 (let ((object (eval form
)))
312 (setf (inspect-object-stack *current-inspect
*) (list object
))
313 (setf (inspect-select-stack *current-inspect
*)
314 (list (format nil
":i ..."))))
315 (set-break-inspect *current-inspect
*)
319 ;;; aclrepl-specific inspection display
322 (defun no-object-msg (s)
323 (output-inspect-note s
"No object is being inspected"))
325 (defun display-current (s)
327 (let ((inspected (car (stack))))
328 (setq cl
:* inspected
)
329 (display-inspect inspected s
*inspect-length
* *inspect-skip
*))
332 ) ;; end binding for multithreading
335 (defun display-inspect (object stream
&optional length
(skip 0))
336 (multiple-value-bind (elements labels count
)
337 (inspected-elements object length skip
)
339 (format stream
"~A" (inspected-description object
))
340 (unless (or *skip-address-display
*
341 (characterp object
) (typep object
'fixnum
))
342 (format stream
" at #x~X" (sb-kernel:get-lisp-obj-address object
)))
345 (display-labeled-element (elt elements i
) (elt labels i
) stream
))))
347 (defun array-label-p (label)
348 (and (stringp (cdr label
)) (char= (char (cdr label
) 0) #\
[)))
350 (defun named-or-array-label-p (label)
353 (defun display-labeled-element (element label stream
)
355 ((eq label
:ellipses
)
356 (format stream
" ..."))
358 (format stream
"tail-> ~A" (inspected-description element
)))
359 ((named-or-array-label-p label
)
361 (if (array-label-p label
)
363 "~4,' D ~16,1,1,'-A> ~A")
365 (format nil
"~A " (cdr label
))
366 (inspected-description element
)))
368 (format stream
"~4,' D-> ~A" label
(inspected-description element
)))))
370 ;;; THE BEGINNINGS OF AN INSPECTOR API
371 ;;; which can be used to retrieve object descriptions as component values/labels and also
372 ;;; process print length and skip selectors
374 ;;; FUNCTIONS TO CONSIDER FOR EXPORT
378 ;;; INSPECTED-ELEMENTS
379 ;;; INSPECTED-DESCRIPTION
381 ;;; will also need hooks
382 ;;; *inspect-start-inspection*
383 ;;; (maybe. Would setup a window for a GUI inspector)
384 ;;; *inspect-prompt-fun*
385 ;;; *inspect-read-cmd*
387 ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
388 ;;; That'll depend if choose to have standardized inspector commands such that
389 ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
390 ;;; process and then call the *inspect-display* hook, or if the
391 ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will
392 ;;; send to the contributed inspector for processing and display.
394 (defun find-part-id (object id
)
395 "COMPONENT-ID can be an integer or a name of a id.
396 Returns (VALUES POSITION PARTS).
397 POSITION is NIL if the id is invalid or not found."
398 (let* ((parts (inspected-parts object
))
399 (name (if (symbolp id
) (symbol-name id
) id
)))
402 (when (< -
1 id
(parts-count parts
)) id
)
403 (case (parts-seq-type parts
)
405 (position name
(the list
(parts-components parts
))
406 :key
#'car
:test
#'string-equal
))
407 ((:dotted-list
:cyclic-list
)
408 (when (string-equal name
"tail")
409 (1- (parts-count parts
))))))
412 (defun component-at (parts position
)
413 (let ((count (parts-count parts
))
414 (components (parts-components parts
)))
415 (when (< -
1 position count
)
416 (case (parts-seq-type parts
)
418 (if (= position
(1- count
))
419 (cdr (last components
))
420 (elt components position
)))
422 (if (= position
(1- count
))
424 (elt components position
)))
426 (cdr (elt components position
)))
428 (aref (the array components
) position
))
430 (elt components position
))))))
432 (defun id-at (parts position
)
433 (let ((count (parts-count parts
)))
434 (when (< -
1 position count
)
435 (case (parts-seq-type parts
)
436 ((:dotted-list
:cyclic-list
)
437 (if (= position
(1- count
))
441 (array-index-string position parts
))
443 (car (elt (parts-components parts
) position
)))
447 (defun inspected-elements (object &optional length
(skip 0))
448 "Returns elements of an object that have been trimmed and labeled based on
449 length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT)
450 where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items.
451 LABELS may be a string, number, cons pair, :tail, or :ellipses.
452 This function may return an ELEMENT-COUNT of up to (+ 3 length) which would
453 include an :ellipses at the beginning, :ellipses at the end,
454 and the last element."
455 (let* ((parts (inspected-parts object
))
456 (print-length (if length length
(parts-count parts
)))
457 (last-part (last-part parts
))
458 (last-requested (last-requested parts print-length skip
))
459 (element-count (compute-elements-count parts print-length skip
))
460 (first-to (if (first-element-ellipses-p parts skip
) 1 0))
461 (elements (when (plusp element-count
) (make-array element-count
)))
462 (labels (when (plusp element-count
) (make-array element-count
))))
463 (when (plusp element-count
)
464 ;; possible first ellipses
465 (when (first-element-ellipses-p parts skip
)
466 (set-element-values elements labels
0 nil
:ellipses
))
469 ((> i
(- last-requested skip
)))
470 (set-element elements labels parts
(+ i first-to
) (+ i skip
)))
471 ;; last parts value if needed
472 (when (< last-requested last-part
)
473 (set-element elements labels parts
(- element-count
1) last-part
))
474 ;; ending ellipses or next to last parts value if needed
475 (when (< last-requested
(1- last-part
))
476 (if (= last-requested
(- last-part
2))
477 (set-element elements labels parts
(- element-count
2) (1- last-part
))
478 (set-element-values elements labels
(- element-count
2) nil
:ellipses
))))
479 (values elements labels element-count
)))
481 (defun last-requested (parts print skip
)
482 (min (1- (parts-count parts
)) (+ skip print -
1)))
484 (defun last-part (parts)
485 (1- (parts-count parts
)))
487 (defun compute-elements-count (parts length skip
)
488 "Compute the number of elements in parts given the print length and skip."
489 (let ((element-count (min (parts-count parts
) length
490 (max 0 (- (parts-count parts
) skip
)))))
491 (when (and (plusp (parts-count parts
)) (plusp skip
)) ; starting ellipses
492 (incf element-count
))
493 (when (< (last-requested parts length skip
)
494 (last-part parts
)) ; last value
496 (when (< (last-requested parts length skip
)
497 (1- (last-part parts
))) ; ending ellipses
498 (incf element-count
)))
501 (defun set-element (elements labels parts to-index from-index
)
502 (set-element-values elements labels to-index
(component-at parts from-index
)
503 (label-at parts from-index
)))
505 (defun set-element-values (elements labels index element label
)
506 (setf (aref elements index
) element
)
507 (setf (aref labels index
) label
))
509 (defun first-element-ellipses-p (parts skip
)
510 (and (parts-count parts
) (plusp skip
)))
512 (defun label-at (parts position
)
513 "Helper function for inspected-elements. Conses the
514 position with the label if the label is a string."
515 (let ((id (id-at parts position
)))
520 (defun array-index-string (index parts
)
521 "Formats an array index in row major format."
522 (let ((rev-dimensions (parts-seq-hint parts
)))
523 (if (null rev-dimensions
)
526 (dolist (dim rev-dimensions
)
527 (multiple-value-bind (q r
) (floor index dim
)
530 (format nil
"[~W~{,~W~}]" (car list
) (cdr list
))))))
533 ;;; INSPECTED-DESCRIPTION
535 ;;; Accepts an object and returns
536 ;;; DESCRIPTION is a summary description of the destructured object,
537 ;;; e.g. "the object is a CONS".
539 (defgeneric inspected-description
(object))
541 (defmethod inspected-description ((object symbol
))
542 (format nil
"the symbol ~A" object
))
544 (defmethod inspected-description ((object structure-object
))
545 (format nil
"~W" (find-class (type-of object
))))
547 (defmethod inspected-description ((object package
))
548 (format nil
"the ~A package" (package-name object
)))
550 (defmethod inspected-description ((object standard-object
))
551 (format nil
"~W" (class-of object
)))
553 (defmethod inspected-description ((object sb-kernel
:funcallable-instance
))
554 (format nil
"a funcallable-instance of type ~S" (type-of object
)))
556 (defmethod inspected-description ((object function
))
557 (format nil
"~S" object
) nil
)
559 (defmethod inspected-description ((object vector
))
560 (declare (vector object
))
561 (format nil
"a ~:[~;displaced ~]vector (~W)"
562 (and (sb-kernel:array-header-p object
)
563 (sb-kernel:%array-displaced-p object
))
566 (defmethod inspected-description ((object simple-vector
))
567 (declare (simple-vector object
))
568 (format nil
"a simple ~A vector (~D)"
569 (array-element-type object
)
572 (defmethod inspected-description ((object array
))
573 (declare (array object
))
574 (format nil
"~:[A displaced~;An~] array of ~A with dimensions ~W"
575 (and (sb-kernel:array-header-p object
)
576 (sb-kernel:%array-displaced-p object
))
577 (array-element-type object
)
578 (array-dimensions object
)))
580 (defun simple-cons-pair-p (object)
583 (defmethod inspected-description ((object cons
))
584 (if (simple-cons-pair-p object
)
586 (inspected-description-of-nontrivial-list object
)))
588 (defun cons-safe-length (object)
589 "Returns (VALUES LENGTH LIST-TYPE) where length is the number of
590 cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
591 (do ((length 1 (1+ length
))
592 (lst (cdr object
) (cdr lst
)))
593 ((or (not(consp lst
))
597 (values length
:normal
))
599 (values length
:dotted
))
601 (values length
:cyclic
))))
602 ;; nothing to do in body
605 (defun inspected-description-of-nontrivial-list (object)
606 (multiple-value-bind (length list-type
) (cons-safe-length object
)
607 (format nil
"a ~A list with ~D element~:*~P~A"
608 (string-downcase (symbol-name list-type
)) length
610 ((:dotted
:cyclic
) "+tail")
613 (defmethod inspected-description ((object double-float
))
614 (format nil
"double-float ~W" object
))
616 (defmethod inspected-description ((object single-float
))
617 (format nil
"single-float ~W" object
))
619 (defmethod inspected-description ((object fixnum
))
620 (format nil
"fixnum ~W~A" object
621 (if *skip-address-display
*
623 (format nil
" [#x~8,'0X]" object
624 (sb-kernel:get-lisp-obj-address object
)))))
626 (defmethod inspected-description ((object complex
))
627 (format nil
"complex number ~W" object
))
629 (defmethod inspected-description ((object simple-string
))
630 (format nil
"a simple-string (~W) ~W" (length object
) object
))
632 (defmethod inspected-description ((object bignum
))
633 (format nil
"bignum ~W" object
))
635 (defmethod inspected-description ((object ratio
))
636 (format nil
"ratio ~W" object
))
638 (defmethod inspected-description ((object character
))
639 (format nil
"character ~W char-code~A" object
(char-code object
)
640 (if *skip-address-display
*
642 (format nil
" [#x~8,'0X]" object
643 (sb-kernel:get-lisp-obj-address object
)))))
645 (defmethod inspected-description ((object t
))
646 (format nil
"a generic object ~W" object
))
648 (defmethod inspected-description ((object (eql *inspect-unbound-object-marker
*)))
654 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
655 ;;; (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
658 ;;; COMPONENTS are the component parts of OBJECT (whose
659 ;;; representation is determined by SEQ-TYPE). Except for the
660 ;;; SEQ-TYPE :named and :array, components is just the OBJECT itself
662 ;;; SEQ-TYPE determines what representation is used for components
664 ;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
665 ;;; If SEQ-TYPE is :dotted-list, then each element is just value,
666 ;;; but the last element must be retrieved by
667 ;;; (cdr (last components))
668 ;;; If SEQ-TYPE is :cylic-list, then each element is just value,
669 ;;; If SEQ-TYPE is :list, then each element is a value of an array
670 ;;; If SEQ-TYPE is :vector, then each element is a value of an vector
671 ;;; If SEQ-TYPE is :array, then each element is a value of an array
672 ;;; with rank >= 2. The
674 ;;; COUNT is the total number of components in the OBJECT
676 ;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
677 ;;; to hold the reverse-dimensions of the orignal array.
679 (declaim (inline parts-components
))
680 (defun parts-components (parts)
683 (declaim (inline parts-count
))
684 (defun parts-count (parts)
687 (declaim (inline parts-seq-type
))
688 (defun parts-seq-type (parts)
691 (declaim (inline parts-seq-hint
))
692 (defun parts-seq-hint (parts)
695 (defgeneric inspected-parts
(object)
698 (defmethod inspected-parts ((object symbol
))
700 (list (cons "NAME" (symbol-name object
))
701 (cons "PACKAGE" (symbol-package object
))
702 (cons "VALUE" (if (boundp object
)
703 (symbol-value object
)
704 *inspect-unbound-object-marker
*))
705 (cons "FUNCTION" (if (fboundp object
)
706 (symbol-function object
)
707 *inspect-unbound-object-marker
*))
708 (cons "PLIST" (symbol-plist object
)))))
709 (list components
(length components
) :named nil
)))
711 (defun inspected-structure-parts (object)
712 (let ((components-list '())
713 (info (sb-kernel:layout-info
(sb-kernel:layout-of object
))))
714 (when (sb-kernel::defstruct-description-p info
)
715 (dolist (dd-slot (sb-kernel:dd-slots info
) (nreverse components-list
))
716 (push (cons (sb-kernel:dsd-%name dd-slot
)
717 (funcall (sb-kernel:dsd-accessor-name dd-slot
) object
))
720 (defmethod inspected-parts ((object structure-object
))
721 (let ((components (inspected-structure-parts object
)))
722 (list components
(length components
) :named nil
)))
724 (defun inspected-standard-object-parts (object)
725 (let ((components nil
)
726 (class-slots (sb-pcl::class-slots
(class-of object
))))
727 (dolist (class-slot class-slots components
)
728 (let* ((slot-name (slot-value class-slot
'sb-pcl
::name
))
729 (slot-value (if (slot-boundp object slot-name
)
730 (slot-value object slot-name
)
731 *inspect-unbound-object-marker
*)))
732 (push (cons (symbol-name slot-name
) slot-value
) components
)))))
735 (defmethod inspected-parts ((object standard-object
))
736 (let ((components (inspected-standard-object-parts object
)))
737 (list components
(length components
) :named nil
)))
739 (defmethod inspected-parts ((object sb-kernel
:funcallable-instance
))
740 (let ((components (inspected-structure-parts object
)))
741 (list components
(length components
) :named nil
)))
743 (defmethod inspected-parts ((object function
))
744 (let* ((type (sb-kernel:widetag-of object
))
745 (object (if (= type sb-vm
:closure-header-widetag
)
746 (sb-kernel:%closure-fun object
)
748 (components (list (cons "arglist"
749 (sb-kernel:%simple-fun-arglist object
)))))
750 (list components
(length components
) :named nil
)))
752 (defmethod inspected-parts ((object vector
))
753 (list object
(length object
) :vector nil
))
755 (defmethod inspected-parts ((object array
))
756 (let ((size (array-total-size object
)))
757 (list (make-array size
:displaced-to object
)
760 (reverse (array-dimensions object
)))))
762 (defmethod inspected-parts ((object cons
))
763 (if (simple-cons-pair-p object
)
764 (inspected-parts-of-simple-cons object
)
765 (inspected-parts-of-nontrivial-list object
)))
767 (defun inspected-parts-of-simple-cons (object)
768 (let ((components (list (cons "car" (car object
))
769 (cons "cdr" (cdr object
)))))
770 (list components
2 :named nil
)))
772 (defun inspected-parts-of-nontrivial-list (object)
773 (multiple-value-bind (count list-type
) (cons-safe-length object
)
776 (list object count
:list nil
))
778 (list object
(1+ count
) :cyclic-list nil
))
780 ;; count tail element
781 (list object
(1+ count
) :dotted-list nil
)))))
783 (defmethod inspected-parts ((object complex
))
784 (let ((components (list (cons "real" (realpart object
))
785 (cons "imag" (imagpart object
)))))
786 (list components
(length components
) :named nil
)))
788 (defmethod inspected-parts ((object ratio
))
789 (let ((components (list (cons "numerator" (numerator object
))
790 (cons "denominator" (denominator object
)))))
791 (list components
(length components
) :named nil
)))
793 (defmethod inspected-parts ((object t
))
794 (list nil
0 nil nil
))
797 ;; FIXME - implement setting of component values
799 (defgeneric set-component-value
(object component-id value element
))
801 (defmethod set-component-value ((object cons
) id value element
)
802 (format nil
"Cons object does not support setting of component ~A" id
))
804 (defmethod set-component-value ((object array
) id value element
)
805 (format nil
"Array object does not support setting of component ~A" id
))
807 (defmethod set-component-value ((object symbol
) id value element
)
808 (format nil
"Symbol object does not support setting of component ~A" id
))
810 (defmethod set-component-value ((object structure-object
) id value element
)
811 (format nil
"Structure object does not support setting of component ~A" id
))
813 (defmethod set-component-value ((object standard-object
) id value element
)
814 (format nil
"Standard object does not support setting of component ~A" id
))
816 (defmethod set-component-value ((object t
) id value element
)
817 (format nil
"Object does not support setting of component ~A" id
))