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