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   (let ((label (label-at parts position)))
 393     (if (stringp label)
 394         (cons position label)
 395         label)))
 396
 397 (defun array-index-string (index parts)
 398   (let ((rev-dimensions (parts-seq-hint parts)))
 399     (if (null rev-dimensions)
 400         "[]"
 401         (let ((list nil))
 402           (dolist (dim rev-dimensions)
 403             (multiple-value-bind (q r) (floor index dim)
 404               (setq index q)
 405               (push r list)))
 406           (format nil "[~W~{,~W~}]" (car list) (cdr list))))))
 407
 408 (defun inspected-elements (object length skip)
 409   "Returns elements of an object that have been trimmed and labeled based on
 410 length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains
 411 COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number,
 412 :tail, or :ellipses. This function may return a COUNT of up to (+ 3 length) which would
 413 include an :ellipses at the beginning, :ellipses at the end, and the last element."
 414   (let* ((parts (inspected-parts object))
 415          (count (parts-count parts)))
 416     (unless skip (setq skip 0))
 417     (unless length (setq length count))
 418     (let* ((last (1- count))
 419            (last-req (min last (+ skip length -1))) ;; last requested element
 420            (total (min (- count skip) length)))
 421       (when (and (plusp total) (plusp skip)) ; starting ellipses
 422         (incf total))
 423       (when (< last-req last) ; last value
 424         (incf total)
 425         (when (< last-req (1- last)) ; ending ellipses
 426           (incf total)))
 427       (let ((index 0)
 428             (elements nil)
 429             (labels nil))
 430         (declare (type (or simple-vector null) elements labels))
 431         (when (plusp total)
 432           (setq elements (make-array total :adjustable nil :fill-pointer nil :initial-element nil))
 433           (setq labels (make-array total :adjustable nil :fill-pointer nil))
 434           (when (plusp skip)
 435             (setf (aref labels 0) :ellipses)
 436             (incf index))
 437           (do ((i 0 (1+ i)))
 438               ((> i (- last-req skip)))
 439             (setf (aref elements (+ i index)) (element-at parts (+ i skip)))
 440             (setf (aref labels (+ i index)) (label-at-maybe-with-index parts
 441                                              (+ i skip))))
 442
 443           (when (< last-req last) ; last value
 444             (setf (aref elements (- total 1)) (element-at parts last))
 445             (setf (aref labels (- total 1)) (label-at-maybe-with-index parts
 446                                                                        last))
 447             (when (< last-req (1- last)) ; ending ellipses or 2nd to last value
 448               (if (= last-req (- last 2))
 449                   (progn
 450                     (setf (aref elements (- total 2)) (element-at parts (1- last)))
 451                     (setf (aref labels (- total 2)) (label-at-maybe-with-index
 452                                                       parts (1- last))))
 453                   (setf (aref labels (- total 2)) :ellipses)))))
 454         (values elements labels total)))))
 455
 456
 457 \f
 458 ;;; INSPECTED-DESCRIPTION
 459 ;;;
 460 ;;; Accepts an object and returns
 461 ;;;   DESCRIPTION is a summary description of the destructured object,
 462 ;;;   e.g. "the object is a CONS".
 463
 464 (defgeneric inspected-description (object))
 465
 466 (defmethod inspected-description ((object symbol))
 467   (format nil "the symbol ~A" object))
 468
 469 (defmethod inspected-description ((object structure-object))
 470   (format nil "~W" (find-class (type-of object))))
 471
 472 (defmethod inspected-description ((object package))
 473   (format nil "the ~A package" (package-name object)))
 474
 475 (defmethod inspected-description ((object standard-object))
 476   (format nil "~W" (class-of object)))
 477
 478 (defmethod inspected-description ((object sb-kernel:funcallable-instance))
 479   (format nil "a funcallable-instance of type ~S" (type-of object)))
 480
 481 (defmethod inspected-description ((object function))
 482   (format nil "~S" object) nil)
 483
 484 (defmethod inspected-description ((object vector))
 485   (declare (vector object))
 486   (format nil "a ~:[~;displaced ~]vector (~W)"
 487           (and (sb-kernel:array-header-p object)
 488                (sb-kernel:%array-displaced-p object))
 489           (length object)))
 490
 491 (defmethod inspected-description ((object simple-vector))
 492   (declare (simple-vector object))
 493   (format nil "a simple ~A vector (~D)"
 494           (array-element-type object)
 495           (length object)))
 496
 497 (defmethod inspected-description ((object array))
 498   (declare (array object))
 499   (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
 500           (and (sb-kernel:array-header-p object)
 501                (sb-kernel:%array-displaced-p object))
 502           (array-element-type object)
 503           (array-dimensions object)))
 504
 505 (defun simple-cons-pair-p (object)
 506   (atom (cdr object)))
 507
 508 (defmethod inspected-description ((object cons))
 509   (if (simple-cons-pair-p object)
 510       "a cons cell"
 511       (inspected-description-of-nontrivial-list object)))
 512
 513 (defun dotted-safe-length (object)
 514   "Returns (VALUES LENGTH PROPER-P) where length is the number of cons cells"
 515     (do ((length 0 (1+ length))
 516          (lst object (cdr lst)))
 517         ((not (consp lst))
 518          (if (null lst)
 519              (values length t)
 520              (values length nil)))
 521       ;; nothing to do in body
 522       ))
 523
 524 (defun inspected-description-of-nontrivial-list (object)
 525   (multiple-value-bind (length proper-p) (dotted-safe-length object)
 526     (if proper-p
 527         (format nil "a proper list with ~D element~:*~P" length)
 528         (format nil "a dotted list with ~D element~:*~P + tail" length))))
 529
 530 (defmethod inspected-description ((object double-float))
 531   (format nil "double-float ~W" object))
 532
 533 (defmethod inspected-description ((object single-float))
 534   (format nil "single-float ~W" object))
 535
 536 (defmethod inspected-description ((object fixnum))
 537   (format nil "fixnum ~W" object))
 538
 539 (defmethod inspected-description ((object complex))
 540   (format nil "complex number ~W" object))
 541
 542 (defmethod inspected-description ((object simple-string))
 543   (format nil "a simple-string (~W) ~W" (length object) object))
 544
 545 (defmethod inspected-description ((object bignum))
 546   (format nil "bignum ~W" object))
 547
 548 (defmethod inspected-description ((object ratio))
 549   (format nil "ratio ~W" object))
 550
 551 (defmethod inspected-description ((object character))
 552   (format nil "character ~W char-code #x~X" object (char-code object)))
 553
 554 (defmethod inspected-description ((object t))
 555   (format nil "a generic object ~W" object))
 556
 557 \f
 558 ;;; INSPECTED-PARTS
 559 ;;;
 560 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
 561 ;;;   (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
 562 ;;; where..
 563 ;;;
 564 ;;;   COMPONENTS are the component parts of OBJECT (whose
 565 ;;;   representation is determined by SEQ-TYPE). Except for the
 566 ;;;   SEQ-TYPE :named and :array, components is just the OBJECT itself
 567 ;;;
 568 ;;;   SEQ-TYPE determines what representation is used for components
 569 ;;;   of COMPONENTS.
 570 ;;;      If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
 571 ;;;      If SEQ-TYPE is :improper-list, then each element is just value,
 572 ;;;        but the last element must be retrieved by
 573 ;;;        (cdr (last components))
 574 ;;;      If SEQ-TYPE is :list, then each element is a value of an array
 575 ;;;      If SEQ-TYPE is :vector, then each element is a value of an vector
 576 ;;;      If SEQ-TYPE is :array, then each element is a value of an array
 577 ;;;        with rank >= 2
 578 ;;;
 579 ;;;   COUNT is the total number of components in the OBJECT
 580 ;;;
 581 ;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array
 582 ;;; to hold the reverse-dimensions of the orignal array.
 583
 584 (declaim (inline parts-components))
 585 (defun parts-components (parts)
 586   (first parts))
 587
 588 (declaim (inline parts-count))
 589 (defun parts-count (parts)
 590   (second parts))
 591
 592 (declaim (inline parts-seq-type))
 593 (defun parts-seq-type (parts)
 594   (third parts))
 595
 596 (declaim (inline parts-seq-hint))
 597 (defun parts-seq-hint (parts)
 598   (fourth parts))
 599
 600 (defgeneric inspected-parts (object)
 601   )
 602
 603 (defmethod inspected-parts ((object symbol))
 604   (let ((components
 605          (list (cons "name" (symbol-name object))
 606                (cons "package" (symbol-package object))
 607                (cons "value" (if (boundp object)
 608                                  (symbol-value object)
 609                                  *inspect-unbound-object-marker*))
 610                (cons "function" (if (fboundp object)
 611                                     (symbol-function object)
 612                                     *inspect-unbound-object-marker*))
 613                (cons "plist" (symbol-plist object)))))
 614     (list components (length components) :named nil)))
 615
 616 (defun inspected-structure-parts (object)
 617   (let ((components-list '())
 618         (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
 619     (when (sb-kernel::defstruct-description-p info)
 620       (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
 621         (push (cons (sb-kernel:dsd-%name dd-slot)
 622                     (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
 623               components-list)))))
 624
 625 (defmethod inspected-parts ((object structure-object))
 626   (let ((components (inspected-structure-parts object)))
 627     (list components (length components) :named nil)))
 628
 629 (defun inspected-standard-object-parts (object)
 630   (let ((reversed-components nil)
 631         (class-slots (sb-pcl::class-slots (class-of object))))
 632     (dolist (class-slot class-slots (nreverse reversed-components))
 633       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
 634              (slot-value (if (slot-boundp object slot-name)
 635                                (slot-value object slot-name)
 636                                *inspect-unbound-object-marker*)))
 637         (push (cons slot-name slot-value) reversed-components)))))
 638
 639 (defmethod inspected-parts ((object standard-object))
 640   (let ((components (inspected-standard-object-parts object)))
 641     (list components (length components) :named nil)))
 642
 643 (defmethod inspected-parts ((object sb-kernel:funcallable-instance))
 644   (let ((components (inspected-structure-parts object)))
 645     (list components (length components) :named nil)))
 646
 647 (defmethod inspected-parts ((object function))
 648   (let* ((type (sb-kernel:widetag-of object))
 649          (object (if (= type sb-vm:closure-header-widetag)
 650                      (sb-kernel:%closure-fun object)
 651                      object))
 652          (components (list (cons "arglist"
 653                                (sb-kernel:%simple-fun-arglist object)))))
 654     (list components (length components) :named nil)))
 655
 656 (defmethod inspected-parts ((object vector))
 657   (list object (length object) :vector nil))
 658
 659 (defmethod inspected-parts ((object array))
 660   (let ((size (array-total-size object)))
 661     (list (make-array size :displaced-to object)
 662             size
 663             :array
 664             (reverse (array-dimensions object)))))
 665
 666 (defmethod inspected-parts ((object cons))
 667   (if (simple-cons-pair-p object)
 668       (inspected-parts-of-simple-cons object)
 669       (inspected-parts-of-nontrivial-list object)))
 670
 671 (defun inspected-parts-of-simple-cons (object)
 672   (let ((components (list (cons "car" (car object))
 673                         (cons "cdr" (cdr object)))))
 674     (list components 2 :named nil)))
 675
 676 (defun inspected-parts-of-nontrivial-list (object)
 677     (multiple-value-bind (count proper-p) (dotted-safe-length object)
 678       (if proper-p
 679           (list object count :list nil)
 680           ;; count tail element
 681           (list object (1+ count) :improper-list nil))))
 682
 683 (defmethod inspected-parts ((object complex))
 684   (let ((components (list (cons "real" (realpart object))
 685                         (cons "imag" (imagpart object)))))
 686     (list components (length components) :named nil)))
 687
 688 (defmethod inspected-parts ((object ratio))
 689   (let ((components (list (cons "numerator" (numerator object))
 690                         (cons "denominator" (denominator object)))))
 691     (list components (length components) :named nil)))
 692
 693 (defmethod inspected-parts ((object t))
 694   (list nil 0 nil nil))
 695
 696
 697 ;; FIXME - implement setting of component values
 698
 699 (defgeneric set-component-value (object component-id value element))
 700
 701 (defmethod set-component-value ((object cons) id value element)
 702   (format nil "Cons object does not support setting of component ~A" id))
 703
 704 (defmethod set-component-value ((object array) id value element)
 705   (format nil "Array object does not support setting of component ~A" id))
 706
 707 (defmethod set-component-value ((object symbol) id value element)
 708   (format nil "Symbol object does not support setting of component ~A" id))
 709
 710 (defmethod set-component-value ((object structure-object) id value element)
 711   (format nil "Structure object does not support setting of component ~A" id))
 712
 713 (defmethod set-component-value ((object standard-object) id value element)
 714   (format nil "Standard object does not support setting of component ~A" id))
 715
 716 (defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
 717   (format nil "Funcallable instance object does not support setting of component ~A" id))
 718
 719 (defmethod set-component-value ((object function) id value element)
 720   (format nil "Function object does not support setting of component ~A" id))
 721
 722 ;; whn believes it is unsafe to change components of this object
 723 (defmethod set-component-value ((object complex) id value element)
 724   (format nil "Object does not support setting of component ~A" id))
 725
 726 ;; whn believes it is unsafe to change components of this object
 727 (defmethod set-component-value ((object ratio) id value element)
 728   (format nil "Object does not support setting of component ~A" id))
 729
 730 (defmethod set-component-value ((object t) id value element)
 731   (format nil "Object does not support setting of component ~A" id))
 732