contrib/sb-aclrepl/inspect.lisp

   1 ;;;; Inspector for sb-aclrepl
   2 ;;;;
   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>.
   6 ;;;;
   7 ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
   8 ;;;; variable.
   9
  10 (cl:in-package :sb-aclrepl)
  11
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defconstant +default-inspect-length+ 10))
  14
  15 (defstruct inspect
  16   ;; stack of parents of inspected object
  17   object-stack
  18   ;;  a stack of indices of parent object components
  19   select-stack)
  20
  21 ;; FIXME - raw mode isn't currently used in object display
  22 (defparameter *current-inspect* nil
  23   "current inspect")
  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
  31 (defvar *inspect-help*
  32   ":istep takes between 0 to 3 arguments.
  33 The commands are:
  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
  43 :i -           inspect parent
  44 :i ^           inspect parent
  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
  52 ")
  53
  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-"))
  57
  58
  59 ;; Setup binding for multithreading
  60 (let ((*current-inspect* nil)
  61       (*inspect-raw* nil)
  62       (*inspect-length* +default-inspect-length+)
  63       (*inspect-skip* 0))
  64
  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*)
  70     (reset-stack)
  71     (setf (inspect-object-stack *current-inspect*) (list object))
  72     (setf (inspect-select-stack *current-inspect*)
  73           (list (format nil "(inspect ~S)" object)))
  74     (%inspect output-stream))
  75
  76
  77   (defun set-current-inspect (inspect)
  78     (setq *current-inspect* inspect))
  79
  80   (defun istep (arg-string output-stream)
  81     (%istep arg-string output-stream))
  82
  83   (setq sb-impl::*inspect-fun* #'inspector)
  84
  85   (defun reset-stack ()
  86     (setf (inspect-object-stack *current-inspect*) nil)
  87     (setf (inspect-select-stack *current-inspect*) nil))
  88
  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)))
  93            (option (car args))
  94            (option-read (when arg-string
  95                           (read-from-string arg-string)))
  96            (stack (inspect-object-stack *current-inspect*)))
  97       (cond
  98         ;; Redisplay
  99         ((or (string= "=" option)
 100              (zerop (length args)))
 101          (%inspect output-stream))
 102         ;; Select parent
 103         ((or (string= "-" option)
 104              (string= "^" option))
 105          (cond
 106            ((> (length stack) 1)
 107             (setf (inspect-object-stack *current-inspect*) (cdr stack))
 108             (setf (inspect-select-stack *current-inspect*)
 109                   (cdr (inspect-select-stack *current-inspect*)))
 110             (%inspect output-stream))
 111            (stack
 112             (format output-stream "Object has no parent.~%"))
 113            (t
 114             (%inspect output-stream))))
 115         ;; Select * to inspect
 116         ((string= "*" option)
 117          (reset-stack)
 118          (setf (inspect-object-stack *current-inspect*) (list *))
 119          (setf (inspect-select-stack *current-inspect*) (list "(inspect *)"))
 120          (set-break-inspect *current-inspect*)
 121          (%inspect output-stream))
 122         ;; Start new inspect level for eval'd form
 123         ((string= "+" option)
 124          (inspector (eval (read-from-string (second args))) nil output-stream))
 125         ;; Next or previous parent component
 126         ((or (string= "<" option)
 127              (string= ">" option))
 128          (if stack
 129              (if (eq (length stack) 1)
 130                  (format output-stream "Object does not have a parent")
 131                  (let ((parent (second stack))
 132                        (id (car (inspect-select-stack *current-inspect*))))
 133                    (multiple-value-bind (position parts)
 134                        (find-object-part-with-id parent id)
 135                      (let ((new-position (if (string= ">" option)
 136                                              (1+ position)
 137                                              (1- position))))
 138                        (if (< -1 new-position (parts-count parts))
 139                            (let* ((value (element-at parts new-position)))
 140                              (setf (car stack) value)
 141                              (setf (car (inspect-select-stack *current-inspect*))
 142                                    (if (integerp id)
 143                                        new-position
 144                                        (let ((label (label-at parts new-position)))
 145                                          (if (stringp label)
 146                                              (read-from-string label)
 147                                              label))))
 148                              (%inspect output-stream))
 149                        (format output-stream "Parent has no selectable component indexed by ~d"
 150                                    new-position))))))
 151              (%inspect output-stream)))
 152         ;; Set component to eval'd form
 153         ((string-equal "set" option)
 154          (if stack
 155              (let ((id (when (second args)
 156                          (read-from-string (second args)))))
 157                (multiple-value-bind (position parts)
 158                    (find-object-part-with-id (car stack) id)
 159                  (if parts
 160                      (if position
 161                          (let ((value-stirng (third args)))
 162                            (when value-stirng
 163                              (let ((new-value (eval (read-from-string (third args)))))
 164                                (let ((result
 165                                       (set-component-value (car stack)
 166                                                            id
 167                                                            new-value
 168                                                            (element-at parts position))))
 169                                  (typecase result
 170                                    (string
 171                                     (format output-stream result))
 172                                    (t
 173                                     (%inspect output-stream)))))))
 174                          (format output-stream
 175                                  "Object has no selectable component named by ~A" id))
 176                      (format output-stream
 177                              "Object has no selectable components"))))
 178              (%inspect output-stream)))
 179         ;; Set/reset raw display mode for components
 180         ((string-equal "raw" option)
 181          (when stack
 182            (when (and (second args)
 183                       (or (null (second args))
 184                           (eq (read-from-string (second args)) t)))
 185              (setq *inspect-raw* t))
 186            (%inspect output-stream)))
 187         ;; Reset stack
 188         ((string-equal "q" option)
 189          (reset-stack)
 190          (set-break-inspect *current-inspect*))
 191         ;; Display help
 192         ((string-equal "?" option)
 193          (format output-stream *inspect-help*))
 194         ;; Set number of components to skip
 195         ((string-equal "skip" option)
 196          (let ((len (read-from-string (second args))))
 197            (if (and (integerp len) (>= len 0))
 198                (let ((*inspect-skip* len))
 199                  (%inspect output-stream))
 200                (format output-stream "Skip missing or invalid~%"))))
 201         ;; Print stack tree
 202         ((string-equal "tree" option)
 203          (if stack
 204              (progn
 205                (format output-stream "The current object is:~%")
 206                (dotimes (i (length stack))
 207                  (format output-stream "~A, ~A~%"
 208                          (inspected-description (nth i stack))
 209                          (let ((select (nth i (inspect-select-stack *current-inspect*))))
 210                            (typecase select
 211                              (integer
 212                               (format nil "which is componenent number ~d of" select))
 213                              (symbol
 214                               (format nil "which is the ~a component of" select))
 215                              (string
 216                               (format nil "which was selected by ~S" select))
 217                              (t
 218                               (write-to-string select)))))))
 219              (%inspect output-stream)))
 220         ;; Set maximum number of components to print
 221         ((string-equal "print" option)
 222          (let ((len (read-from-string (second args))))
 223            (if (and (integerp len) (plusp len))
 224                (setq *inspect-length* len)
 225                (format output-stream "Cannot set print limit to ~A~%" len))))
 226         ;; Select numbered or named component
 227         ((or (symbolp option-read)
 228              (integerp option-read))
 229          (if stack
 230              (multiple-value-bind (position parts)
 231                  (find-object-part-with-id (car stack) option-read)
 232                (cond
 233                  ((integerp position)
 234                   (let* ((value (element-at parts position)))
 235                     (cond ((eq value *inspect-unbound-object-marker*)
 236                            (format output-stream "That slot is unbound~%"))
 237                           (t
 238                            (push value (inspect-object-stack *current-inspect*))
 239                            (push option-read (inspect-select-stack *current-inspect*))
 240                            (%inspect output-stream)))))
 241                  ((null parts)
 242                   (format output-stream "Object does not contain any subobjects~%"))
 243                  (t
 244                   (typecase option-read
 245                     (symbol
 246                      (format output-stream
 247                              "Object has no selectable component named ~A"
 248                              option))
 249                     (integer
 250                      (format output-stream
 251                              "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
 252                              option-read
 253                              (= (parts-count parts) 1)
 254                              (1- (parts-count parts))))))))
 255              (%inspect output-stream)))
 256         ;; Default is to select eval'd form
 257         (t
 258          (reset-stack)
 259          (let ((object (eval option-read)))
 260            (setf (inspect-object-stack *current-inspect*) (list object))
 261            (setf (inspect-select-stack *current-inspect*)
 262                  (list (format nil ":i ~S" object))))
 263          (set-break-inspect *current-inspect*)
 264          (%inspect output-stream))
 265         )))
 266
 267   (defun %inspect (s)
 268     (if (inspect-object-stack *current-inspect*)
 269         (let ((inspected (car (inspect-object-stack *current-inspect*))))
 270           (setq cl:* inspected)
 271           (display-inspected-parts inspected s))
 272         (format s "No object is being inspected")))
 273
 274
 275   (defun display-inspected-parts (object stream)
 276     (multiple-value-bind (elements labels count)
 277         (inspected-elements object *inspect-length* *inspect-skip*)
 278       (format stream "~&~A" (inspected-description object))
 279       (unless (or (characterp object) (typep object 'fixnum))
 280         (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
 281       (princ #\newline stream)
 282       (dotimes (i count)
 283         (let ((label (elt labels i))
 284               (element (elt elements i)))
 285           (cond
 286             ((eq label :ellipses)
 287              (format stream "~&   ...~%"))
 288             ((eq label :tail)
 289              (format stream "tail-> ~A~%" (inspected-description element)))
 290             ((consp label)
 291              (format stream
 292                      (if (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[))
 293                          ;; for arrays
 294                          "~4,' D ~A-> ~A~%"
 295                          ;; for named
 296                          "~4,' D ~16,1,1,'-A> ~A~%")
 297                      (car label)
 298                      (format nil "~A " (cdr label))
 299                      (if (eq element *inspect-unbound-object-marker*)
 300                          "..unbound.."
 301                          (inspected-description element))))
 302             (t
 303              (if (integerp label)
 304                  (format stream "~4,' D-> ~A~%" label (inspected-description element))
 305                  (format stream "~4A-> ~A~%" label (inspected-description element)))))))))
 306
 307   ) ;; end binding for multithreading
 308
 309
 310 ;;; THE BEGINNINGS OF AN INSPECTOR API
 311 ;;; which can be used to retrieve object descriptions as component values/labels and also
 312 ;;; process component length and skip selectors
 313 ;;;
 314 ;;; FUNCTIONS TO CONSIDER FOR EXPORT
 315 ;;;   FIND-OBJECT-PART-WITH-ID
 316 ;;;   ELEMENT-AT
 317 ;;;   LABEL-AT
 318 ;;;   INSPECTED-ELEMENTS
 319 ;;;   INSPECTED-DESCRIPTION
 320 ;;;
 321 ;;; will also need hooks
 322 ;;;    *inspect-start-inspection* (maybe. Would setup a window for a GUI inspector)
 323 ;;;    *inspect-prompt-fun*
 324 ;;;    *inspect-read-cmd*
 325 ;;;
 326 ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
 327 ;;; That'll depend if choose to have standardized inspector commands such that
 328 ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
 329 ;;; process and then call the *inspect-display* hook, or if the *inspect-read-cmd*
 330 ;;; will return an impl-dependent cmd that sbcl will send to the contributed
 331 ;;; inspector for processing and display.
 332
 333 (defun find-object-part-with-id (object id)
 334   "COMPONENT-ID can be an integer or a name of a id.
 335 Returns (VALUES POSITION PARTS).
 336 POSITION is NIL if the id is invalid or not found."
 337   (if object
 338       (let* ((parts (inspected-parts object))
 339              (seq-type (parts-seq-type parts))
 340              (count (parts-count parts))
 341              (components (parts-components parts)))
 342         (when (symbolp id)
 343           (setq id (symbol-name id)))
 344         (let ((position
 345                (cond ((and (eq seq-type :named)
 346                            (stringp id))
 347                       (position id (the list components) :key #'car
 348                                 :test #'string-equal))
 349                      ((and (eq seq-type :improper-list)
 350                            (stringp id)
 351                            (string-equal id "tail"))
 352                       (1- count))
 353                      ((numberp id)
 354                       (when (< -1 id count)
 355                         id)))))
 356           (values position parts)))
 357       (values nil nil)))
 358
 359
 360 (defun element-at (parts position)
 361   (let ((count (parts-count parts))
 362         (components (parts-components parts)))
 363     (when (< -1 position count)
 364       (case (parts-seq-type parts)
 365         (:improper-list
 366          (if (= position (1- count))
 367              (cdr (last components))
 368              (elt components position)))
 369         (:named
 370          (cdr (elt components position)))
 371         (:array
 372          (aref (the array components) position))
 373         (t
 374          (elt components position))))))
 375
 376 (defun label-at (parts position)
 377   (let ((count (parts-count parts)))
 378     (when (< -1 position count)
 379       (case (parts-seq-type parts)
 380         (:improper-list
 381          (if (= position (1- count))
 382              :tail
 383              position))
 384         (:array
 385          (array-index-string position parts))
 386         (:named
 387          (car (elt (parts-components parts) position)))
 388         (t
 389          position)))))
 390
 391 (defun label-at-maybe-with-index (parts position)
 392   "Helper function for inspected-elements. Conses the
 393 position with the label is the label is a string."
 394   (let ((label (label-at parts position)))
 395     (if (stringp label)
 396         (cons position label)
 397         label)))
 398
 399 (defun array-index-string (index parts)
 400   "Formats an array index in row major format."
 401   (let ((rev-dimensions (parts-seq-hint parts)))
 402     (if (null rev-dimensions)
 403         "[]"
 404         (let ((list nil))
 405           (dolist (dim rev-dimensions)
 406             (multiple-value-bind (q r) (floor index dim)
 407               (setq index q)
 408               (push r list)))
 409           (format nil "[~W~{,~W~}]" (car list) (cdr list))))))
 410
 411 (defun inspected-elements (object length skip)
 412   "Returns elements of an object that have been trimmed and labeled based on
 413 length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains
 414 COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number,
 415 :tail, or :ellipses. This function may return a COUNT of up to (+ 3 length) which would
 416 include an :ellipses at the beginning, :ellipses at the end, and the last element."
 417   (let* ((parts (inspected-parts object))
 418          (count (parts-count parts)))
 419     (unless skip (setq skip 0))
 420     (unless length (setq length count))
 421     (let* ((last (1- count))
 422            (last-req (min last (+ skip length -1))) ;; last requested element
 423            (total (min (- count skip) length)))
 424       (when (and (plusp total) (plusp skip)) ; starting ellipses
 425         (incf total))
 426       (when (< last-req last) ; last value
 427         (incf total)
 428         (when (< last-req (1- last)) ; ending ellipses
 429           (incf total)))
 430       (let ((index 0)
 431             (elements nil)
 432             (labels nil))
 433         (declare (type (or simple-vector null) elements labels))
 434         (when (plusp total)
 435           (setq elements (make-array total :adjustable nil :fill-pointer nil :initial-element nil))
 436           (setq labels (make-array total :adjustable nil :fill-pointer nil))
 437           (when (plusp skip)
 438             (setf (aref labels 0) :ellipses)
 439             (incf index))
 440           (do ((i 0 (1+ i)))
 441               ((> i (- last-req skip)))
 442             (setf (aref elements (+ i index)) (element-at parts (+ i skip)))
 443             (setf (aref labels (+ i index)) (label-at-maybe-with-index parts
 444                                              (+ i skip))))
 445
 446           (when (< last-req last) ; last value
 447             (setf (aref elements (- total 1)) (element-at parts last))
 448             (setf (aref labels (- total 1)) (label-at-maybe-with-index parts
 449                                                                        last))
 450             (when (< last-req (1- last)) ; ending ellipses or 2nd to last value
 451               (if (= last-req (- last 2))
 452                   (progn
 453                     (setf (aref elements (- total 2)) (element-at parts (1- last)))
 454                     (setf (aref labels (- total 2)) (label-at-maybe-with-index
 455                                                       parts (1- last))))
 456                   (setf (aref labels (- total 2)) :ellipses)))))
 457         (values elements labels total)))))
 458
 459
 460 \f
 461 ;;; INSPECTED-DESCRIPTION
 462 ;;;
 463 ;;; Accepts an object and returns
 464 ;;;   DESCRIPTION is a summary description of the destructured object,
 465 ;;;   e.g. "the object is a CONS".
 466
 467 (defgeneric inspected-description (object))
 468
 469 (defmethod inspected-description ((object symbol))
 470   (format nil "the symbol ~A" object))
 471
 472 (defmethod inspected-description ((object structure-object))
 473   (format nil "~W" (find-class (type-of object))))
 474
 475 (defmethod inspected-description ((object package))
 476   (format nil "the ~A package" (package-name object)))
 477
 478 (defmethod inspected-description ((object standard-object))
 479   (format nil "~W" (class-of object)))
 480
 481 (defmethod inspected-description ((object sb-kernel:funcallable-instance))
 482   (format nil "a funcallable-instance of type ~S" (type-of object)))
 483
 484 (defmethod inspected-description ((object function))
 485   (format nil "~S" object) nil)
 486
 487 (defmethod inspected-description ((object vector))
 488   (declare (vector object))
 489   (format nil "a ~:[~;displaced ~]vector (~W)"
 490           (and (sb-kernel:array-header-p object)
 491                (sb-kernel:%array-displaced-p object))
 492           (length object)))
 493
 494 (defmethod inspected-description ((object simple-vector))
 495   (declare (simple-vector object))
 496   (format nil "a simple ~A vector (~D)"
 497           (array-element-type object)
 498           (length object)))
 499
 500 (defmethod inspected-description ((object array))
 501   (declare (array object))
 502   (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
 503           (and (sb-kernel:array-header-p object)
 504                (sb-kernel:%array-displaced-p object))
 505           (array-element-type object)
 506           (array-dimensions object)))
 507
 508 (defun simple-cons-pair-p (object)
 509   (atom (cdr object)))
 510
 511 (defmethod inspected-description ((object cons))
 512   (if (simple-cons-pair-p object)
 513       "a cons cell"
 514       (inspected-description-of-nontrivial-list object)))
 515
 516 (defun dotted-safe-length (object)
 517   "Returns (VALUES LENGTH PROPER-P) where length is the number of cons cells"
 518     (do ((length 0 (1+ length))
 519          (lst object (cdr lst)))
 520         ((not (consp lst))
 521          (if (null lst)
 522              (values length t)
 523              (values length nil)))
 524       ;; nothing to do in body
 525       ))
 526
 527 (defun inspected-description-of-nontrivial-list (object)
 528   (multiple-value-bind (length proper-p) (dotted-safe-length object)
 529     (if proper-p
 530         (format nil "a proper list with ~D element~:*~P" length)
 531         (format nil "a dotted list with ~D element~:*~P + tail" length))))
 532
 533 (defmethod inspected-description ((object double-float))
 534   (format nil "double-float ~W" object))
 535
 536 (defmethod inspected-description ((object single-float))
 537   (format nil "single-float ~W" object))
 538
 539 (defmethod inspected-description ((object fixnum))
 540   (format nil "fixnum ~W" object))
 541
 542 (defmethod inspected-description ((object complex))
 543   (format nil "complex number ~W" object))
 544
 545 (defmethod inspected-description ((object simple-string))
 546   (format nil "a simple-string (~W) ~W" (length object) object))
 547
 548 (defmethod inspected-description ((object bignum))
 549   (format nil "bignum ~W" object))
 550
 551 (defmethod inspected-description ((object ratio))
 552   (format nil "ratio ~W" object))
 553
 554 (defmethod inspected-description ((object character))
 555   (format nil "character ~W char-code #x~X" object (char-code object)))
 556
 557 (defmethod inspected-description ((object t))
 558   (format nil "a generic object ~W" object))
 559
 560 \f
 561 ;;; INSPECTED-PARTS
 562 ;;;
 563 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
 564 ;;;   (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
 565 ;;; where..
 566 ;;;
 567 ;;;   COMPONENTS are the component parts of OBJECT (whose
 568 ;;;   representation is determined by SEQ-TYPE). Except for the
 569 ;;;   SEQ-TYPE :named and :array, components is just the OBJECT itself
 570 ;;;
 571 ;;;   SEQ-TYPE determines what representation is used for components
 572 ;;;   of COMPONENTS.
 573 ;;;      If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
 574 ;;;      If SEQ-TYPE is :improper-list, then each element is just value,
 575 ;;;        but the last element must be retrieved by
 576 ;;;        (cdr (last components))
 577 ;;;      If SEQ-TYPE is :list, then each element is a value of an array
 578 ;;;      If SEQ-TYPE is :vector, then each element is a value of an vector
 579 ;;;      If SEQ-TYPE is :array, then each element is a value of an array
 580 ;;;        with rank >= 2
 581 ;;;
 582 ;;;   COUNT is the total number of components in the OBJECT
 583 ;;;
 584 ;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array
 585 ;;; to hold the reverse-dimensions of the orignal array.
 586
 587 (declaim (inline parts-components))
 588 (defun parts-components (parts)
 589   (first parts))
 590
 591 (declaim (inline parts-count))
 592 (defun parts-count (parts)
 593   (second parts))
 594
 595 (declaim (inline parts-seq-type))
 596 (defun parts-seq-type (parts)
 597   (third parts))
 598
 599 (declaim (inline parts-seq-hint))
 600 (defun parts-seq-hint (parts)
 601   (fourth parts))
 602
 603 (defgeneric inspected-parts (object)
 604   )
 605
 606 (defmethod inspected-parts ((object symbol))
 607   (let ((components
 608          (list (cons "name" (symbol-name object))
 609                (cons "package" (symbol-package object))
 610                (cons "value" (if (boundp object)
 611                                  (symbol-value object)
 612                                  *inspect-unbound-object-marker*))
 613                (cons "function" (if (fboundp object)
 614                                     (symbol-function object)
 615                                     *inspect-unbound-object-marker*))
 616                (cons "plist" (symbol-plist object)))))
 617     (list components (length components) :named nil)))
 618
 619 (defun inspected-structure-parts (object)
 620   (let ((components-list '())
 621         (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
 622     (when (sb-kernel::defstruct-description-p info)
 623       (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
 624         (push (cons (sb-kernel:dsd-%name dd-slot)
 625                     (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
 626               components-list)))))
 627
 628 (defmethod inspected-parts ((object structure-object))
 629   (let ((components (inspected-structure-parts object)))
 630     (list components (length components) :named nil)))
 631
 632 (defun inspected-standard-object-parts (object)
 633   (let ((reversed-components nil)
 634         (class-slots (sb-pcl::class-slots (class-of object))))
 635     (dolist (class-slot class-slots (nreverse reversed-components))
 636       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
 637              (slot-value (if (slot-boundp object slot-name)
 638                                (slot-value object slot-name)
 639                                *inspect-unbound-object-marker*)))
 640         (push (cons slot-name slot-value) reversed-components)))))
 641
 642 (defmethod inspected-parts ((object standard-object))
 643   (let ((components (inspected-standard-object-parts object)))
 644     (list components (length components) :named nil)))
 645
 646 (defmethod inspected-parts ((object sb-kernel:funcallable-instance))
 647   (let ((components (inspected-structure-parts object)))
 648     (list components (length components) :named nil)))
 649
 650 (defmethod inspected-parts ((object function))
 651   (let* ((type (sb-kernel:widetag-of object))
 652          (object (if (= type sb-vm:closure-header-widetag)
 653                      (sb-kernel:%closure-fun object)
 654                      object))
 655          (components (list (cons "arglist"
 656                                (sb-kernel:%simple-fun-arglist object)))))
 657     (list components (length components) :named nil)))
 658
 659 (defmethod inspected-parts ((object vector))
 660   (list object (length object) :vector nil))
 661
 662 (defmethod inspected-parts ((object array))
 663   (let ((size (array-total-size object)))
 664     (list (make-array size :displaced-to object)
 665             size
 666             :array
 667             (reverse (array-dimensions object)))))
 668
 669 (defmethod inspected-parts ((object cons))
 670   (if (simple-cons-pair-p object)
 671       (inspected-parts-of-simple-cons object)
 672       (inspected-parts-of-nontrivial-list object)))
 673
 674 (defun inspected-parts-of-simple-cons (object)
 675   (let ((components (list (cons "car" (car object))
 676                         (cons "cdr" (cdr object)))))
 677     (list components 2 :named nil)))
 678
 679 (defun inspected-parts-of-nontrivial-list (object)
 680     (multiple-value-bind (count proper-p) (dotted-safe-length object)
 681       (if proper-p
 682           (list object count :list nil)
 683           ;; count tail element
 684           (list object (1+ count) :improper-list nil))))
 685
 686 (defmethod inspected-parts ((object complex))
 687   (let ((components (list (cons "real" (realpart object))
 688                         (cons "imag" (imagpart object)))))
 689     (list components (length components) :named nil)))
 690
 691 (defmethod inspected-parts ((object ratio))
 692   (let ((components (list (cons "numerator" (numerator object))
 693                         (cons "denominator" (denominator object)))))
 694     (list components (length components) :named nil)))
 695
 696 (defmethod inspected-parts ((object t))
 697   (list nil 0 nil nil))
 698
 699
 700 ;; FIXME - implement setting of component values
 701
 702 (defgeneric set-component-value (object component-id value element))
 703
 704 (defmethod set-component-value ((object cons) id value element)
 705   (format nil "Cons object does not support setting of component ~A" id))
 706
 707 (defmethod set-component-value ((object array) id value element)
 708   (format nil "Array object does not support setting of component ~A" id))
 709
 710 (defmethod set-component-value ((object symbol) id value element)
 711   (format nil "Symbol object does not support setting of component ~A" id))
 712
 713 (defmethod set-component-value ((object structure-object) id value element)
 714   (format nil "Structure object does not support setting of component ~A" id))
 715
 716 (defmethod set-component-value ((object standard-object) id value element)
 717   (format nil "Standard object does not support setting of component ~A" id))
 718
 719 (defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
 720   (format nil "Funcallable instance object does not support setting of component ~A" id))
 721
 722 (defmethod set-component-value ((object function) id value element)
 723   (format nil "Function object does not support setting of component ~A" id))
 724
 725 ;; whn believes it is unsafe to change components of this object
 726 (defmethod set-component-value ((object complex) id value element)
 727   (format nil "Object does not support setting of component ~A" id))
 728
 729 ;; whn believes it is unsafe to change components of this object
 730 (defmethod set-component-value ((object ratio) id value element)
 731   (format nil "Object does not support setting of component ~A" id))
 732
 733 (defmethod set-component-value ((object t) id value element)
 734   (format nil "Object does not support setting of component ~A" id))
 735