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