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