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