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