src/code/inspect.lisp

   1 ;;;; the INSPECT function
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-INSPECT")
  13
  14 (file-comment
  15   "$Header$")
  16
  17 ;;; The inspector views LISP objects as being composed of parts. A
  18 ;;; list, for example, would be divided into its members, and a
  19 ;;; instance into its slots. These parts are stored in a list. The
  20 ;;; first two elements of this list are for bookkeeping. The first
  21 ;;; element is a preamble string that will be displayed before the
  22 ;;; object. The second element is a boolean value that indicates
  23 ;;; whether a label will be printed in front of a value, or just the
  24 ;;; value. Symbols and instances need to display both a slot name and
  25 ;;; a value, while lists, vectors, and atoms need only display a
  26 ;;; value. If the second member of a parts list is t, then the third
  27 ;;; and successive members must be an association list of slot names
  28 ;;; and values. When the second slot is nil, the third and successive
  29 ;;; slots must be the parts of an object.
  30
  31 ;;; *INSPECT-OBJECT-STACK* is an assoc list of objects to their parts.
  32 (defvar *inspect-object-stack* ())
  33
  34 (defparameter *inspect-length* 10)
  35
  36 #-sb-fluid (declaim (inline numbered-parts-p))
  37 (defun numbered-parts-p (parts)
  38   (second parts))
  39
  40 (defconstant parts-offset 2)
  41
  42 (defun nth-parts (parts n)
  43   (if (numbered-parts-p parts)
  44       (cdr (nth (+ n parts-offset) parts))
  45       (nth (+ n parts-offset) parts)))
  46
  47 (defun inspect (object)
  48   (unwind-protect
  49       (input-loop object (describe-parts object) *standard-output*)
  50     (setf *inspect-object-stack* nil)))
  51
  52 ;;; When *ILLEGAL-OBJECT-MARKER* occurs in a parts list, it indicates that that
  53 ;;; slot is unbound.
  54 (defvar *illegal-object-marker* (cons nil nil))
  55
  56 (defun input-loop (object parts s)
  57   (tty-display-object parts s)
  58   (loop
  59     (format s "~&> ")
  60     (force-output)
  61     (let ((command (read))
  62           ;; Use 2 less than length because first 2 elements are bookkeeping.
  63           (parts-len-2 (- (length parts) 2)))
  64       (typecase command
  65         (integer
  66          (cond ((< -1 command parts-len-2)
  67                 (cond ((eq (nth-parts parts command) *illegal-object-marker*)
  68                        (format s "~%That slot is unbound.~%"))
  69                       (t
  70                        (push (cons object parts) *inspect-object-stack*)
  71                        (setf object (nth-parts parts command))
  72                        (setf parts (describe-parts object))
  73                        (tty-display-object parts s))))
  74                (t
  75                 (if (= parts-len-2 0)
  76                     (format s "~%This object contains nothing to inspect.~%~%")
  77                     (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%"
  78                             (= parts-len-2 1) (1- parts-len-2))))))
  79         (symbol
  80          (case (find-symbol (symbol-name command) *keyword-package*)
  81            ((:q :e)
  82             (return object))
  83            (:u
  84             (cond (*inspect-object-stack*
  85                    (setf object (caar *inspect-object-stack*))
  86                    (setf parts (cdar *inspect-object-stack*))
  87                    (pop *inspect-object-stack*)
  88                    (tty-display-object parts s))
  89                   (t (format s "~%Bottom of Stack.~%"))))
  90            (:r
  91             (setf parts (describe-parts object))
  92             (tty-display-object parts s))
  93            (:d
  94             (tty-display-object parts s))
  95            ((:h :? :help)
  96             (show-help s))
  97            (t
  98             (do-inspect-eval command s))))
  99         (t
 100          (do-inspect-eval command s))))))
 101
 102 (defun do-inspect-eval (command stream)
 103   (let ((result-list (restart-case (multiple-value-list (eval command))
 104                        (nil () :report "Return to the inspector."
 105                           (format stream "~%returning to the inspector~%")
 106                           (return-from do-inspect-eval nil)))))
 107     (setf /// // // / / result-list)
 108     (setf +++ ++ ++ + + - - command)
 109     (setf *** ** ** * * (car /))
 110     (format stream "~&~{~S~%~}" /)))
 111
 112 (defun show-help (s)
 113   (terpri)
 114   (write-line "inspector help:" s)
 115   (write-line "  R           -  recompute current object." s)
 116   (write-line "  D           -  redisplay current object." s)
 117   (write-line "  U           -  Move upward through the object stack." s)
 118   (write-line "  Q, E        -  Quit inspector." s)
 119   (write-line "  ?, H, Help  -  Show this help." s))
 120
 121 (defun tty-display-object (parts stream)
 122   (format stream "~%~A" (car parts))
 123   (let ((numbered-parts-p (numbered-parts-p parts))
 124         (parts (cddr parts)))
 125     (do ((part parts (cdr part))
 126          (i 0 (1+ i)))
 127         ((endp part) nil)
 128       (if numbered-parts-p
 129           (format stream "~D. ~A: ~A~%" i (caar part)
 130                   (if (eq (cdar part) *illegal-object-marker*)
 131                       "unbound"
 132                       (cdar part)))
 133           (format stream "~D. ~A~%" i (car part))))))
 134 \f
 135 ;;;; DESCRIBE-PARTS
 136
 137 (defun describe-parts (object)
 138   (typecase object
 139     (symbol (describe-symbol-parts object))
 140     (instance (describe-instance-parts object :structure))
 141     (function
 142      (if (sb-kernel:funcallable-instance-p object)
 143          (describe-instance-parts object :funcallable-instance)
 144          (describe-function-parts object)))
 145     (vector (describe-vector-parts object))
 146     (array (describe-array-parts object))
 147     (cons (describe-cons-parts object))
 148     (t (describe-atomic-parts object))))
 149
 150 (defun describe-symbol-parts (object)
 151   (list (format nil "~S is a symbol.~%" object) t
 152         (cons "Value" (if (boundp object)
 153                           (symbol-value object)
 154                           *illegal-object-marker*))
 155         (cons "Function" (if (fboundp object)
 156                              (symbol-function object)
 157                              *illegal-object-marker*))
 158         (cons "Plist" (symbol-plist object))
 159         (cons "Package" (symbol-package object))))
 160
 161 (defun describe-instance-parts (object kind)
 162   (let ((info (layout-info (sb-kernel:layout-of object)))
 163         (parts-list ()))
 164     (push (format nil "~S is a ~(~A~).~%" object kind) parts-list)
 165     (push t parts-list)
 166     (when (sb-kernel::defstruct-description-p info)
 167       (dolist (dd-slot (dd-slots info) (nreverse parts-list))
 168         (push (cons (dsd-%name dd-slot)
 169                     (funcall (dsd-accessor dd-slot) object))
 170               parts-list)))))
 171
 172 (defun describe-function-parts (object)
 173   (let* ((type (sb-kernel:get-type object))
 174          (object (if (= type sb-vm:closure-header-type)
 175                      (sb-kernel:%closure-function object)
 176                      object)))
 177     (list (format nil "Function ~S.~@[~%Argument List: ~A~]." object
 178                   (sb-kernel:%function-arglist object)
 179                   ;; Defined-from stuff used to be here. Someone took
 180                   ;; it out. FIXME: We should make it easy to get
 181                   ;; to DESCRIBE from the inspector.
 182                   )
 183           t)))
 184
 185 (defun describe-vector-parts (object)
 186   (list* (format nil "The object is a ~:[~;displaced ~]vector of length ~D.~%"
 187                  (and (sb-impl::array-header-p object)
 188                       (sb-impl::%array-displaced-p object))
 189                  (length object))
 190          nil
 191          (coerce object 'list)))
 192
 193 (defun describe-cons-parts (object)
 194   (list* (format nil "The object is a LIST of length ~D.~%" (length object))
 195          nil
 196          object))
 197
 198 (defun index-string (index rev-dimensions)
 199   (if (null rev-dimensions)
 200       "[]"
 201       (let ((list nil))
 202         (dolist (dim rev-dimensions)
 203           (multiple-value-bind (q r) (floor index dim)
 204             (setq index q)
 205             (push r list)))
 206         (format nil "[~D~{,~D~}]" (car list) (cdr list)))))
 207
 208 (defun describe-array-parts (object)
 209   (let* ((length (min (array-total-size object) *inspect-length*))
 210          (reference-array (make-array length :displaced-to object))
 211          (dimensions (array-dimensions object))
 212          (parts ()))
 213     (push (format nil "The object is ~:[a displaced~;an~] array of ~A.~%~
 214                        Its dimensions are ~S.~%"
 215                   (array-element-type object)
 216                   (and (sb-impl::array-header-p object)
 217                        (sb-impl::%array-displaced-p object))
 218                   dimensions)
 219           parts)
 220     (push t parts)
 221     (dotimes (i length (nreverse parts))
 222       (push (cons (format nil "~A " (index-string i (reverse dimensions)))
 223                   (aref reference-array i))
 224             parts))))
 225
 226 (defun describe-atomic-parts (object)
 227   (list (format nil "The object is an atom.~%") nil object))