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