src/code/inspect.lisp

   1 ;;;; the CL: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-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
  13
  14 (defparameter *inspect-length* 10)
  15
  16 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
  17 ;;; indicates that that a slot is unbound.
  18 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
  19
  20 (defun inspect (object)
  21   (catch 'quit-inspect
  22     (%inspect object *standard-output*))
  23   (values))
  24
  25 (defvar *inspected*)
  26 (setf (documentation '*inspected* 'variable)
  27       "the value currently being inspected in CL:INSPECT")
  28
  29 (defvar *help-for-inspect*
  30   "
  31 help for INSPECT:
  32   Q, E        -  Quit the inspector.
  33   <integer>   -  Inspect the numbered slot.
  34   R           -  Redisplay current inspected object.
  35   U           -  Move upward/backward to previous inspected object.
  36   ?, H, Help  -  Show this help.
  37   <other>     -  Evaluate the input as an expression.
  38 Within the inspector, the special variable SB-EXT:*INSPECTED* is bound
  39 to the current inspected object, so that it can be referred to in
  40 evaluated expressions.
  41 ")
  42
  43 (defun %inspect (*inspected* s)
  44   (named-let redisplay () ; "LAMBDA, the ultimate GOTO":-|
  45     (multiple-value-bind (description named-p elements)
  46         (inspected-parts *inspected*)
  47       (tty-display-inspected-parts description named-p elements s)
  48       (named-let reread ()
  49         (format s "~&> ")
  50         (force-output)
  51         (let (;; KMP idiom, using stream itself as EOF value
  52               (command (read *standard-input* nil *standard-input*)))
  53           (typecase command
  54             (stream ; i.e. EOF
  55              ;; currently-undocumented feature: EOF is handled as Q.
  56              ;; If there's ever consensus that this is *the* right
  57              ;; thing to do (as opposed to e.g. handling it as U), we
  58              ;; could document it. Meanwhile, it seems more Unix-y to
  59              ;; do this than to signal an error.
  60              (/show0 "THROWing QUIT-INSPECT for EOF")
  61              (throw 'quit-inspect nil))
  62             (integer
  63              (let ((elements-length (length elements)))
  64                (cond ((< -1 command elements-length)
  65                       (let* ((element (nth command elements))
  66                              (value (if named-p (cdr element) element)))
  67                         (cond ((eq value *inspect-unbound-object-marker*)
  68                                (format s "~%That slot is unbound.~%")
  69                                (return-from %inspect (reread)))
  70                               (t
  71                                (%inspect value s)
  72                                ;; If we ever return, then we should be
  73                                ;; looking at *INSPECTED* again.
  74                                (return-from %inspect (redisplay))))))
  75                      ((zerop elements-length)
  76                       (format s "~%The object contains nothing to inspect.~%")
  77                       (return-from %inspect (reread)))
  78                      (t
  79                       (format s "~%Enter a valid index (~:[0-~W~;0~]).~%"
  80                               (= elements-length 1) (1- elements-length))
  81                       (return-from %inspect (reread))))))
  82             (symbol
  83              (case (find-symbol (symbol-name command) *keyword-package*)
  84                ((:q :e)
  85                 (/show0 "THROWing QUIT-INSPECT for :Q or :E")
  86                 (throw 'quit-inspect nil))
  87                (:u
  88                 (return-from %inspect))
  89                (:r
  90                 (return-from %inspect (redisplay)))
  91                ((:h :? :help)
  92                 (write-string *help-for-inspect* s)
  93                 (return-from %inspect (reread)))
  94                (t
  95                 (eval-for-inspect command s)
  96                 (return-from %inspect (reread)))))
  97             (t
  98              (eval-for-inspect command s)
  99              (return-from %inspect (reread)))))))))
 100
 101 (defun eval-for-inspect (command stream)
 102   (let ((result-list (restart-case (multiple-value-list (eval command))
 103                        (nil () :report "Return to the inspector."
 104                           (format stream "~%returning to the inspector~%")
 105                           (return-from eval-for-inspect nil)))))
 106     ;; FIXME: Much of this interactive-EVAL logic is shared with
 107     ;; the main REPL EVAL and with the debugger EVAL. The code should
 108     ;; be shared explicitly.
 109     (setf /// // // / / result-list)
 110     (setf +++ ++ ++ + + - - command)
 111     (setf *** ** ** * * (car /))
 112     (format stream "~&~{~S~%~}" /)))
 113
 114 (defun tty-display-inspected-parts (description named-p elements stream)
 115   (format stream "~%~A" description)
 116   (let ((index 0))
 117     (dolist (element elements)
 118       (if named-p
 119           (destructuring-bind (name . value) element
 120             (format stream "~W. ~A: ~W~%" index name
 121                     (if (eq value *inspect-unbound-object-marker*)
 122                         "unbound"
 123                         value)))
 124           (format stream "~W. ~W~%" index element))
 125       (incf index))))
 126 \f
 127 ;;;; INSPECTED-PARTS
 128
 129 ;;; Destructure an object for inspection, returning
 130 ;;;   (VALUES DESCRIPTION NAMED-P ELEMENTS),
 131 ;;; where..
 132 ;;;
 133 ;;;   DESCRIPTION is a summary description of the destructured object,
 134 ;;;   e.g. "The object is a CONS.~%".
 135 ;;;
 136 ;;;   NAMED-P determines what representation is used for elements
 137 ;;;   of ELEMENTS. If NAMED-P is true, then each element is
 138 ;;;   (CONS NAME VALUE); otherwise each element is just VALUE.
 139 ;;;
 140 ;;;   ELEMENTS is a list of the component parts of OBJECT (whose
 141 ;;;   representation is determined by NAMED-P).
 142 ;;;
 143 ;;; (The NAMED-P dichotomy is useful because symbols and instances
 144 ;;; need to display both a slot name and a value, while lists and
 145 ;;; vectors need only display a value.)
 146 (defgeneric inspected-parts (object))
 147
 148 (defmethod inspected-parts ((object symbol))
 149   (values (format nil "The object is a SYMBOL.~%" object)
 150           t
 151           (list (cons "Name" (symbol-name object))
 152                 (cons "Package" (symbol-package object))
 153                 (cons "Value" (if (boundp object)
 154                                   (symbol-value object)
 155                                   *inspect-unbound-object-marker*))
 156                 (cons "Function" (if (fboundp object)
 157                                      (symbol-function object)
 158                                      *inspect-unbound-object-marker*))
 159                 (cons "Plist" (symbol-plist object)))))
 160
 161 (defun inspected-structure-elements (object)
 162   (let ((parts-list '())
 163         (info (layout-info (sb-kernel:layout-of object))))
 164     (when (sb-kernel::defstruct-description-p info)
 165       (dolist (dd-slot (dd-slots info) (nreverse parts-list))
 166         (push (cons (dsd-%name dd-slot)
 167                     (funcall (dsd-accessor-name dd-slot) object))
 168               parts-list)))))
 169
 170 (defmethod inspected-parts ((object structure-object))
 171   (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%"
 172                   (type-of object))
 173           t
 174           (inspected-structure-elements object)))
 175
 176 (defun inspected-standard-object-elements (object)
 177   (let ((reversed-elements nil)
 178         (class-slots (sb-pcl::class-slots (class-of object))))
 179     (dolist (class-slot class-slots (nreverse reversed-elements))
 180       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
 181              (slot-value (if (slot-boundp object slot-name)
 182                              (slot-value object slot-name)
 183                              *inspect-unbound-object-marker*)))
 184         (push (cons slot-name slot-value) reversed-elements)))))
 185
 186 (defmethod inspected-parts ((object standard-object))
 187   (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%"
 188                   (type-of object))
 189           t
 190           (inspected-standard-object-elements object)))
 191
 192 (defmethod inspected-parts ((object funcallable-instance))
 193   (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%"
 194                   (type-of object))
 195           t
 196           (inspected-structure-elements object)))
 197
 198 (defmethod inspected-parts ((object function))
 199   (let* ((type (sb-kernel:widetag-of object))
 200          (object (if (= type sb-vm:closure-header-widetag)
 201                      (sb-kernel:%closure-fun object)
 202                      object)))
 203     (values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object
 204                     (sb-kernel:%simple-fun-arglist object)
 205                     ;; Defined-from stuff used to be here. Someone took
 206                     ;; it out. FIXME: We should make it easy to get
 207                     ;; to DESCRIBE from the inspector.
 208                     )
 209             t
 210             nil)))
 211
 212 (defmethod inspected-parts ((object vector))
 213   (values (format nil
 214                   "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%"
 215                   (and (array-header-p object)
 216                        (%array-displaced-p object))
 217                   (length object))
 218           nil
 219           ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what
 220           ;; does *INSPECT-LENGTH* mean?
 221           (coerce object 'list)))
 222
 223 (defun inspected-index-string (index rev-dimensions)
 224   (if (null rev-dimensions)
 225       "[]"
 226       (let ((list nil))
 227         (dolist (dim rev-dimensions)
 228           (multiple-value-bind (q r) (floor index dim)
 229             (setq index q)
 230             (push r list)))
 231         (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
 232
 233 (defmethod inspected-parts ((object array))
 234   (let* ((length (min (array-total-size object) *inspect-length*))
 235          (reference-array (make-array length :displaced-to object))
 236          (dimensions (array-dimensions object))
 237          (reversed-elements nil))
 238     ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what does
 239     ;; *INSPECT-LENGTH* mean?
 240     (dotimes (i length)
 241       (push (cons (format nil
 242                           "~A "
 243                           (inspected-index-string i (reverse dimensions)))
 244                   (aref reference-array i))
 245             reversed-elements))
 246     (values (format nil "The object is ~:[a displaced~;an~] ARRAY of ~A.~%~
 247                          Its dimensions are ~S.~%"
 248                     (array-element-type object)
 249                     (and (array-header-p object)
 250                          (%array-displaced-p object))
 251                     dimensions)
 252             t
 253             (nreverse reversed-elements))))
 254
 255 (defmethod inspected-parts ((object cons))
 256   (if (consp (cdr object))
 257       (inspected-parts-of-nontrivial-list object)
 258       (inspected-parts-of-simple-cons object)))
 259
 260 (defun inspected-parts-of-simple-cons (object)
 261   (values "The object is a CONS.
 262 "
 263           t
 264           (list (cons 'car (car object))
 265                 (cons 'cdr (cdr object)))))
 266
 267 (defun inspected-parts-of-nontrivial-list (object)
 268   (let ((length 0)
 269         (in-list object)
 270         (reversed-elements nil))
 271     (flet ((done (description-format)
 272              (return-from inspected-parts-of-nontrivial-list
 273                (values (format nil description-format length)
 274                        t
 275                        (nreverse reversed-elements)))))
 276       (loop
 277        (cond ((null in-list)
 278               (done "The object is a proper list of length ~S.~%"))
 279              ((>= length *inspect-length*)
 280               (push (cons 'rest in-list) reversed-elements)
 281               (done "The object is a long list (more than ~S elements).~%"))
 282              ((consp in-list)
 283               (push (cons length (pop in-list)) reversed-elements)
 284               (incf length))
 285              (t
 286               (push (cons 'rest in-list) reversed-elements)
 287               (done "The object is an improper list of length ~S.~%")))))))
 288
 289 (defmethod inspected-parts ((object t))
 290   (values (format nil "The object is an ATOM:~%  ~W~%" object) nil nil))