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 (defstruct inspect
  13   ;; stack of parents of inspected object
  14   object-stack
  15   ;;  a stack of indices of parent object components
  16   parent-stack
  17   ;; number of components to display
  18   (length 10))
  19
  20 ;; FIXME - raw mode isn't currently used in object display
  21 (defparameter *current-inspect* nil
  22   "current inspect")
  23 (defparameter *inspect-raw* nil
  24   "Raw mode for object display.")
  25
  26 (defvar *inspect-help*
  27 ":istep takes between 0 to 3 arguments.
  28 The commands are:
  29 :i             redisplay current object
  30 :i =           redisplay current object
  31 :i nil         redisplay current object
  32 :i ?           display this help
  33 :i *           inspect the current * value
  34 :i + <form>    inspect the (eval form)
  35 :i <index>     inspect the numbered component of object
  36 :i <name>      inspect the named component of object
  37 :i <form>      evaluation and inspect form
  38 :i -           inspect parent
  39 :i ^           inspect parent
  40 :i <           inspect previous parent component
  41 :i >           inspect next parent component
  42 :i set <index> <form> set indexed component to evalated form
  43 :i set <name> <form>  set named component to evalated form
  44 :i print <max> set the maximum number of components to print
  45 :i skip <n>    skip a number of components when printing
  46 :i tree        print inspect stack
  47 ")
  48
  49 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
  50 ;;; indicates that that a slot is unbound.
  51 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
  52
  53
  54 ;; Setup binding for multithreading
  55 (let ((*current-inspect* nil)
  56       (*inspect-raw* nil))
  57
  58 (defun inspector (object input-stream output-stream)
  59   (declare (ignore input-stream))
  60   (setq object (eval object))
  61   (setq *current-inspect* (make-inspect))
  62   (new-break :inspect *current-inspect*)
  63   (reset-stack)
  64   (setf (inspect-object-stack *current-inspect*) (list object))
  65   (setf (inspect-parent-stack *current-inspect*) (list "(inspect ...)"))
  66   (%inspect output-stream))
  67
  68
  69 (defun set-current-inspect (inspect)
  70   (setq *current-inspect* inspect))
  71
  72 (defun istep (arg-string output-stream)
  73   (%istep arg-string (string-to-list-skip-spaces arg-string) output-stream))
  74
  75 (setq sb-impl::*inspect-fun* #'inspector)
  76
  77 (defun reset-stack ()
  78   (setf (inspect-object-stack *current-inspect*) nil)
  79   (setf (inspect-parent-stack *current-inspect*) nil))
  80
  81 (defun %istep (arg-string args output-stream)
  82   (unless *current-inspect*
  83     (setq *current-inspect* (make-inspect)))
  84   (let* ((option (car args))
  85          (option-read (when arg-string
  86                         (read-from-string arg-string)))
  87          (stack (inspect-object-stack *current-inspect*)))
  88     (cond
  89       ;; Redisplay
  90       ((or (string= "=" option)
  91            (zerop (length args)))
  92        (%inspect output-stream))
  93       ;; Select parent
  94       ((or (string= "-" option)
  95            (string= "^" option))
  96        (cond
  97          ((> (length stack) 1)
  98           (pop stack)
  99           (%inspect output-stream))
 100          (stack
 101           (format output-stream "Object has no parent.~%"))
 102          (t
 103           (%inspect output-stream))))
 104       ;; Select * to inspect
 105       ((string= "*" option)
 106        (reset-stack)
 107        (setf (inspect-object-stack *current-inspect*) (list *))
 108        (setf (inspect-parent-stack *current-inspect*) (list "(inspect ...)"))
 109        (set-break-inspect *current-inspect*)
 110        (%inspect output-stream))
 111       ;; Start new inspect level for eval'd form
 112       ((string= "+" option)
 113        (inspector (eval (read-from-string (second args))) nil output-stream))
 114       ;; Next or previous parent component
 115       ((or (string= "<" option)
 116            (string= ">" option))
 117        (if stack
 118            (if (eq (length stack) 1)
 119                (format output-stream "Object does not have a parent")
 120                (let ((parent (second stack))
 121                      (id (car (inspect-parent-stack *current-inspect*))))
 122                  (multiple-value-bind (position list-type elements)
 123                      (find-object-component parent id)
 124                    (declare (list elements)
 125                             (ignore list-type))
 126                    (let ((new-position (if (string= ">" option)
 127                                            (1+ position)
 128                                            (1- position))))
 129                      (if (< -1 new-position (length elements))
 130                          (let ((new-object (elt elements new-position)))
 131                            (setf (car stack) new-object)
 132                            (setf (car (inspect-parent-stack *current-inspect*))
 133                                  (if (integerp id)
 134                                      new-position
 135                                      (read-from-string
 136                                       (car (nth new-position elements)))))
 137                            (%inspect output-stream))
 138                          (format output-stream "Parent has no selectable component indexed by ~d"
 139                                  new-position))))))
 140            (%inspect output-stream)))
 141       ;; Set component to eval'd form
 142       ((string-equal "set" option)
 143        (if stack
 144            (let ((id (when (second args)
 145                          (read-from-string (second args)))))
 146              (multiple-value-bind (position list-type elements)
 147                  (find-object-component (car stack) id)
 148                (declare (ignore list-type))
 149                (if elements
 150                    (if position
 151                        (let ((value-stirng (third args)))
 152                          (when value-stirng
 153                            (let ((new-value (eval (read-from-string (third args)))))
 154                              (let ((result
 155                                     (set-component-value (car stack)
 156                                                          id
 157                                                          new-value
 158                                                          (nth position elements))))
 159                                (typecase result
 160                                  (string
 161                                   (format output-stream result))
 162                                  (t
 163                                   (%inspect output-stream)))))))
 164                        (format output-stream
 165                                "Object has no selectable component named by ~A" id))
 166                    (format output-stream
 167                            "Object has no selectable components"))))
 168              (%inspect output-stream)))
 169       ;; Set/reset raw display mode for components
 170       ((string-equal "raw" option)
 171        (when stack
 172          (when (and (second args)
 173                     (or (null (second args))
 174                         (eq (read-from-string (second args)) t)))
 175            (setq *inspect-raw* t))
 176          (%inspect output-stream)))
 177       ;; Reset stack
 178       ((string-equal "q" option)
 179        (reset-stack)
 180        (set-break-inspect *current-inspect*))
 181       ;; Display help
 182       ((string-equal "?" option)
 183        (format output-stream *inspect-help*))
 184       ;; Set number of components to skip
 185       ((string-equal "skip" option)
 186        (let ((len (read-from-string (second args))))
 187          (if (and (integerp len) (>= len 0))
 188              (%inspect output-stream len)
 189              (format output-stream "Skip missing or invalid~%"))))
 190       ;; Print stack tree
 191       ((string-equal "tree" option)
 192        (if stack
 193            (progn
 194              (format output-stream "The current object is:~%")
 195              (dotimes (i (length stack))
 196                (format output-stream "~A, ~A~%"
 197                        (inspected-parts (nth i stack) :description t)
 198                        (let ((select (nth i (inspect-parent-stack *current-inspect*))))
 199                          (typecase select
 200                            (integer
 201                             (format nil "which is componenent number ~d of" select))
 202                            (symbol
 203                             (format nil "which is the ~a component of" select))
 204                            (string
 205                             (format nil "which was selected by ~S" select))
 206                            (t
 207                             (write-to-string select)))))))
 208            (%inspect output-stream)))
 209       ;; Set maximum number of components to print
 210       ((string-equal "print" option)
 211        (let ((len (read-from-string (second args))))
 212          (if (and (integerp len) (plusp len))
 213              (setf (inspect-length *current-inspect*) len)
 214              (format output-stream "Cannot set print limit to ~A~%" len))))
 215       ;; Select numbered or named component
 216       ((or (symbolp option-read)
 217            (integerp option-read))
 218        (if stack
 219            (multiple-value-bind (position list-type elements)
 220                (find-object-component (car stack) option-read)
 221              (cond
 222                ((integerp position)
 223                 (let* ((element (elt elements position))
 224                        (value (if (eq list-type :named) (cdr element) element)))
 225                   (cond ((eq value *inspect-unbound-object-marker*)
 226                          (format output-stream "That slot is unbound~%"))
 227                         (t
 228                          (push value stack)
 229                          (push option-read (inspect-parent-stack *current-inspect*))
 230                          (%inspect output-stream)))))
 231                ((null elements)
 232                 (format output-stream "Object does not contain any subobjects~%"))
 233                (t
 234                 (typecase option-read
 235                   (symbol
 236                    (format output-stream
 237                            "Object has no selectable component named ~A"
 238                            option))
 239                   (integer
 240                    (format output-stream
 241                            "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
 242                            option-read
 243                            (= (length elements) 1)
 244                            (1- (length elements))))))))
 245            (%inspect output-stream)))
 246       ;; Default is to select eval'd form
 247       (t
 248        (reset-stack)
 249        (setf (inspect-object-stack *current-inspect*) (list (eval option-read)))
 250        (setf (inspect-parent-stack *current-inspect*) (list ":i <form>"))
 251        (set-break-inspect *current-inspect*)
 252        (%inspect output-stream))
 253       )))
 254
 255 (defun find-object-component (object id)
 256   "COMPONENT-ID can be an integer or a name of a id.
 257 Returns POSITION LIST-TYPE ELEMENTS
 258 POSITION is NIL if the id is invalid or not found."
 259   (if object
 260       (multiple-value-bind (description list-type elements)
 261           (inspected-parts object)
 262         (declare (ignore description)
 263                  (list elements))
 264         (when (symbolp id)
 265           (setq id (symbol-name id)))
 266         (let ((position
 267                (cond ((and (eq list-type :named)
 268                            (stringp id))
 269                       (position id elements :key #'car :test #'string-equal))
 270                      ((numberp id)
 271                       (when (< -1 id (length elements))
 272                         id)))))
 273           (values position list-type elements)))
 274       (values nil nil nil)))
 275
 276
 277 (defun %inspect (s &optional (skip 0))
 278   (if (inspect-object-stack *current-inspect*)
 279       (let ((inspected (car (inspect-object-stack *current-inspect*))))
 280         (setq cl:* inspected)
 281         (multiple-value-bind (description list-type elements)
 282             (inspected-parts inspected)
 283           (display-inspected-parts inspected description
 284                                    list-type elements s skip)))
 285       (format s "No object is being inspected")))
 286
 287
 288 (defun display-inspected-parts (object description list-type elements stream &optional (skip 0))
 289   (format stream "~&~A" description)
 290   (unless (or (characterp object) (typep object 'fixnum))
 291     (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
 292   (princ #\newline stream)
 293   (when elements
 294     (do* ((index skip (1+ index))
 295           (nelem (length elements))
 296           (max (min (1- nelem) (+ skip (inspect-length *current-inspect*))))
 297           (suspension (when (plusp (- nelem max))
 298                         (- nelem max)))
 299           (count (if (typep elements 'sequence)
 300                      (length elements)
 301                      0))
 302           (element))
 303          ((> index max))
 304       (declare (ignore suspension)) ;; FIXME - not yet implemented
 305       (setq element (elt elements index))
 306       (cond
 307         ((eq list-type :index-with-tail)
 308          (if (eql index (- count 1))
 309            (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
 310            (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
 311         ((eq list-type :named)
 312          (destructuring-bind (name . value) element
 313            (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A "  name)
 314                  (if (eq value *inspect-unbound-object-marker*)
 315                      "..unbound.."
 316                      (inspected-parts value :description t)))))
 317         (t
 318          (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))))
 319
 320 ) ;; end binding for multithreading
 321
 322
 323 \f
 324 ;;; INSPECTED-PARTS
 325 ;;;
 326 ;;; Destructure an object for inspection, returning either
 327 ;;;   DESCRIPTION
 328 ;;; if description keyword is T, otherwise returns
 329 ;;;   (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
 330 ;;; where..
 331 ;;;
 332 ;;;   DESCRIPTION is a summary description of the destructured object,
 333 ;;;   e.g. "the object is a CONS.~%".
 334 ;;;
 335 ;;;   LIST-TYPE determines what representation is used for elements
 336 ;;;   of ELEMENTS.
 337 ;;;      If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
 338 ;;;      If LIST-TYPE is :index-with-tail, then each element is just value,
 339 ;;;        but the last element is label as "tail"
 340 ;;;      If LIST-TYPE is :long, then each element is just value,
 341 ;;;        and suspension points ('...) are shown before the last element.
 342 ;;;      Otherwise, each element is just VALUE.
 343 ;;;
 344 ;;;   ELEMENTS is a list of the component parts of OBJECT (whose
 345 ;;;   representation is determined by LIST-TYPE).
 346 ;;;
 347 ;;; (LIST-TYPE is useful because symbols and instances
 348 ;;; need to display both a slot name and a value, while lists and
 349 ;;; vectors need only display a value.)
 350
 351 (defgeneric inspected-parts (object &key description))
 352
 353 (defmethod inspected-parts ((object symbol) &key description)
 354   (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
 355     (if description
 356         desc
 357         (values desc :named
 358                 (list (cons "name" (symbol-name object))
 359                       (cons "package" (symbol-package object))
 360                       (cons "value" (if (boundp object)
 361                                         (symbol-value object)
 362                                         *inspect-unbound-object-marker*))
 363                       (cons "function" (if (fboundp object)
 364                                            (symbol-function object)
 365                                            *inspect-unbound-object-marker*))
 366                       (cons "plist" (symbol-plist object)))))))
 367
 368 (defun inspected-structure-elements (object)
 369   (let ((parts-list '())
 370         (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
 371     (when (sb-kernel::defstruct-description-p info)
 372       (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse parts-list))
 373         (push (cons (sb-kernel:dsd-%name dd-slot)
 374                     (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
 375               parts-list)))))
 376
 377 (defmethod inspected-parts ((object structure-object) &key description)
 378   (let ((desc (format nil "~W" (find-class (type-of object)))))
 379     (if description
 380         desc
 381         (values desc :named (inspected-structure-elements object)))))
 382
 383 (defmethod inspected-parts ((object package) &key description)
 384   (let ((desc (format nil "the ~A package" (package-name object))))
 385     (if description
 386         desc
 387         (values desc :named (inspected-structure-elements object)))))
 388
 389 (defun inspected-standard-object-elements (object)
 390   (let ((reversed-elements nil)
 391         (class-slots (sb-pcl::class-slots (class-of object))))
 392     (dolist (class-slot class-slots (nreverse reversed-elements))
 393       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
 394              (slot-value (if (slot-boundp object slot-name)
 395                              (slot-value object slot-name)
 396                              *inspect-unbound-object-marker*)))
 397         (push (cons slot-name slot-value) reversed-elements)))))
 398
 399 (defmethod inspected-parts ((object standard-object) &key description)
 400   (let ((desc (format nil "~W" (class-of object))))
 401     (if description
 402         desc
 403         (values desc :named
 404                 (inspected-standard-object-elements object)))))
 405
 406 (defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
 407   (let ((desc (format nil "a funcallable-instance of type ~S"
 408                       (type-of object))))
 409     (if description
 410         desc
 411         (values desc :named
 412                 (inspected-structure-elements object)))))
 413
 414 (defmethod inspected-parts ((object function) &key description)
 415   (let* ((type (sb-kernel:widetag-of object))
 416          (object (if (= type sb-vm:closure-header-widetag)
 417                      (sb-kernel:%closure-fun object)
 418                      object))
 419          (desc (format nil "~S" object)))
 420     (if description
 421         desc
 422         (values desc :named
 423                 (list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
 424
 425 (defmethod inspected-parts ((object vector) &key description)
 426   (let ((desc  (format nil
 427                   "a ~:[~;displaced ~]vector (~W)"
 428                   (and (sb-kernel:array-header-p object)
 429                        (sb-kernel:%array-displaced-p object))
 430                   (length object)
 431                   (sb-kernel:get-lisp-obj-address object))))
 432     (if description
 433         desc
 434         (values desc nil object))))
 435
 436 (defun inspected-index-string (index rev-dimensions)
 437   (if (null rev-dimensions)
 438       "[]"
 439       (let ((list nil))
 440         (dolist (dim rev-dimensions)
 441           (multiple-value-bind (q r) (floor index dim)
 442             (setq index q)
 443             (push r list)))
 444         (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
 445
 446 (defmethod inspected-parts ((object simple-vector) &key description)
 447   (let ((desc (format nil "a simple ~A vector (~D)"
 448                       (array-element-type object)
 449                       (length object))))
 450     (if description
 451         desc
 452         (values desc nil object))))
 453
 454 (defmethod inspected-parts ((object array) &key description)
 455   (declare (array object))
 456   (let* ((length (array-total-size object))
 457          (reference-array (make-array length :displaced-to object))
 458          (dimensions (array-dimensions object))
 459          (reversed-elements nil)
 460          (desc (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
 461                        (and (sb-kernel:array-header-p object)
 462                             (sb-kernel:%array-displaced-p object))
 463                        (array-element-type object)
 464                        dimensions)))
 465     (if description
 466         desc
 467         (progn
 468           (dotimes (i length)
 469             (push (cons (format nil "~A "
 470                                 (inspected-index-string i (reverse dimensions)))
 471                         (aref reference-array i))
 472                   reversed-elements))
 473           (values desc :named (nreverse reversed-elements))))))
 474
 475 (defmethod inspected-parts ((object cons) &key description)
 476   (if (or (consp (cdr object)) (null (cdr object)))
 477       (inspected-parts-of-nontrivial-list object description)
 478       (inspected-parts-of-simple-cons object description)))
 479
 480 (defun inspected-parts-of-simple-cons (object description)
 481   (let ((desc (format nil "a cons pair")))
 482     (if description
 483         desc
 484         (values desc :named
 485                 (list (cons "car" (car object))
 486                       (cons "cdr" (cdr object)))))))
 487
 488 (defun inspected-parts-of-nontrivial-list (object description)
 489   (let ((length 0)
 490         (in-list object)
 491         (reversed-elements nil))
 492     (flet ((done (description-format list-type)
 493              (let ((desc (format nil description-format length length)))
 494                (return-from inspected-parts-of-nontrivial-list
 495                  (if description
 496                      desc
 497                      (values desc list-type (nreverse reversed-elements)))))))
 498       (loop
 499        (cond ((null in-list)
 500               (done "a proper list with ~D element~P" nil))
 501              ((consp in-list)
 502               (push (pop in-list) reversed-elements)
 503               (incf length))
 504              (t
 505               (push in-list reversed-elements)
 506               (done "a improper list with ~D element~P" :index-with-tail)))))))
 507
 508 (defmethod inspected-parts ((object simple-string) &key description)
 509   (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
 510     (if description
 511         desc
 512         (values desc nil object))))
 513
 514 (defmethod inspected-parts ((object double-float) &key description)
 515   (let ((desc (format nil "double-float ~W" object)))
 516     (if description
 517         desc
 518         (values desc nil nil))))
 519
 520 (defmethod inspected-parts ((object single-float) &key description)
 521   (let ((desc (format nil "single-float ~W" object)))
 522     (if description
 523         desc
 524         (values desc nil nil))))
 525
 526 (defmethod inspected-parts ((object fixnum) &key description)
 527   (let ((desc (format nil "fixnum ~W" object)))
 528     (if description
 529         desc
 530         (values desc nil nil))))
 531
 532 (defmethod inspected-parts ((object complex) &key description)
 533   (let ((desc (format nil "complex number ~W" object)))
 534     (if description
 535         desc
 536         (values desc :named
 537                 (list (cons "real" (realpart object))
 538                       (cons "imag" (imagpart object)))))))
 539
 540 (defmethod inspected-parts ((object bignum) &key description)
 541   (let ((desc (format nil "bignum ~W" object)))
 542     (if description
 543         desc
 544         (values desc nil nil))))
 545
 546 (defmethod inspected-parts ((object ratio) &key description)
 547   (let ((desc (format nil "ratio ~W" object)))
 548     (if description
 549         desc
 550         (values desc :named
 551                 (list (cons "numerator" (numerator object))
 552                       (cons "denominator" (denominator object)))))))
 553
 554 (defmethod inspected-parts ((object character) &key description)
 555   (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
 556     (if description
 557         desc
 558         (values desc nil nil))))
 559
 560 (defmethod inspected-parts ((object t) &key description)
 561   (let ((desc (format nil "a generic object ~W" object)))
 562     (if description
 563         desc
 564         (values desc nil nil))))
 565
 566 ;; FIXME - implement setting of component values
 567
 568 (defgeneric set-component-value (object component-id value element))
 569
 570 (defmethod set-component-value ((object cons) id value element)
 571   (format nil "Cons object does not support setting of component ~A" id))
 572
 573 (defmethod set-component-value ((object array) id value element)
 574   (format nil "Array object does not support setting of component ~A" id))
 575
 576 (defmethod set-component-value ((object symbol) id value element)
 577   (format nil "Symbol object does not support setting of component ~A" id))
 578
 579 (defmethod set-component-value ((object structure-object) id value element)
 580   (format nil "Structure object does not support setting of component ~A" id))
 581
 582 (defmethod set-component-value ((object standard-object) id value element)
 583   (format nil "Standard object does not support setting of component ~A" id))
 584
 585 (defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
 586   (format nil "Funcallable instance object does not support setting of component ~A" id))
 587
 588 (defmethod set-component-value ((object function) id value element)
 589   (format nil "Function object does not support setting of component ~A" id))
 590
 591 ;; whn believes it is unsafe to change components of this object
 592 (defmethod set-component-value ((object complex) id value element)
 593   (format nil "Object does not support setting of component ~A" id))
 594
 595 ;; whn believes it is unsafe to change components of this object
 596 (defmethod set-component-value ((object ratio) id value element)
 597   (format nil "Object does not support setting of component ~A" id))
 598
 599 (defmethod set-component-value ((object t) id value element)
 600   (format nil "Object does not support setting of component ~A" id))
 601