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