;;;; Inspector for sb-aclrepl ;;;; ;;;; The documentation, which may or may not apply in its entirety at ;;;; any given time, for this functionality is on the ACL website: ;;;;   <http://www.franz.com/support/documentation/6.2/doc/inspector.htm>. ;;;; ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP* ;;;; variable. (cl:in-package #:sb-aclrepl) (eval-when (:compile-toplevel :load-toplevel :execute)   (defconstant +default-inspect-length+ 20)) (defstruct (%inspect (:constructor make-inspect)                      (:conc-name inspect-))   ;; stack of parents of inspected object  object-stack   ;;  a stack of indices of parent object components  select-stack) ;; FIXME - raw mode isn't currently used in object display (defparameter *current-inspect* nil   "current inspect") (defparameter *inspect-raw* nil   "Raw mode for object display.") (defparameter *inspect-length* +default-inspect-length+   "maximum number of components to print") (defparameter *skip-address-display* nil   "Skip displaying addresses of objects.") (defvar *inspect-help*   ":istep takes between 0 to 3 arguments. The commands are: :i             redisplay current object :i =           redisplay current object :i nil         redisplay current object :i ?           display this help :i *           inspect the current * value :i + <form>    inspect the (eval form) :i slot <name> inspect component of object, even if name is an istep cmd :i <index>     inspect the numbered component of object :i <name>      inspect the named component of object :i <form>      evaluation and inspect form :i -           inspect parent :i ^           inspect parent :i <           inspect previous parent component :i >           inspect next parent component :i set <index> <form> set indexed component to evalated form :i print <max> set the maximum number of components to print :i skip <n>    skip a number of components when printing :i tree        print inspect stack ") ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it ;;; indicates that that a slot is unbound. (eval-when (:compile-toplevel :load-toplevel :execute)   (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))) (defun inspector-fun (object input-stream output-stream)   (let ((*current-inspect* nil)         (*inspect-raw* nil)         (*inspect-length* *inspect-length*)         (*skip-address-display* nil))     (setq *current-inspect* (make-inspect))     (reset-stack object "(inspect ...)")     (redisplay output-stream)     (let ((*input* input-stream)           (*output* output-stream))       (repl :inspect t)))   (values)) (setq sb-impl::*inspect-fun* #'inspector-fun) (defun istep (args stream)   (unless *current-inspect*     (setq *current-inspect* (make-inspect)))   (istep-dispatch args                   (first args)                   (when (first args) (read-from-string (first args)))                   stream)) (defun istep-dispatch (args option-string option stream)   (cond     ((or (string= "=" option-string) (zerop (length args)))      (istep-cmd-redisplay stream))     ((or (string= "-" option-string) (string= "^" option-string))      (istep-cmd-parent stream))     ((string= "*" option-string)      (istep-cmd-inspect-* stream))     ((string= "+" option-string)      (istep-cmd-inspect-new-form (read-from-string (second args)) stream))     ((or (string= "<" option-string)          (string= ">" option-string))      (istep-cmd-select-parent-component option-string stream))     ((string-equal "set" option-string)      (istep-cmd-set (second args) (third args) stream))     ((string-equal "raw" option-string)      (istep-cmd-set-raw (second args) stream))     ((string-equal "q" option-string)      (istep-cmd-reset))     ((string-equal "?" option-string)      (istep-cmd-help stream))     ((string-equal "skip" option-string)      (istep-cmd-skip (second args) stream))     ((string-equal "tree" option-string)      (istep-cmd-tree stream))     ((string-equal "print" option-string)      (istep-cmd-print (second args) stream))     ((string-equal "slot" option-string)      (istep-cmd-select-component (read-from-string (second args)) stream))     ((or (symbolp option)          (integerp option))      (istep-cmd-select-component option stream))     (t      (istep-cmd-set-stack option stream)))) (defun set-current-inspect (inspect)   (setq *current-inspect* inspect)) (defun reset-stack (&optional object label)   (cond     ((null label)      (setf (inspect-object-stack *current-inspect*) nil)      (setf (inspect-select-stack *current-inspect*) nil))     (t      (setf (inspect-object-stack *current-inspect*) (list object))      (setf (inspect-select-stack *current-inspect*) (list label))))) (defun output-inspect-note (stream note &rest args)   (apply #'format stream note args)   (princ #\Newline stream)) (defun stack ()   (inspect-object-stack *current-inspect*)) (defun redisplay (stream &optional (skip 0))   (display-current stream *inspect-length* skip)) ;;; ;;; istep command processing ;;; (defun istep-cmd-redisplay (stream)   (redisplay stream)) (defun istep-cmd-parent (stream)   (cond     ((> (length (inspect-object-stack *current-inspect*)) 1)      (setf (inspect-object-stack *current-inspect*)            (cdr (inspect-object-stack *current-inspect*)))      (setf (inspect-select-stack *current-inspect*)            (cdr (inspect-select-stack *current-inspect*)))      (redisplay stream))     ((stack)        (output-inspect-note stream "Object has no parent"))     (t      (no-object-msg stream)))) (defun istep-cmd-inspect-* (stream)   (reset-stack * "(inspect *)")   (redisplay stream)) (defun istep-cmd-inspect-new-form (form stream)   (inspector-fun (eval form) nil stream)) (defun istep-cmd-select-parent-component (option stream)   (if (stack)       (if (eql (length (stack)) 1)           (output-inspect-note stream "Object does not have a parent")           (let ((parent (second (stack)))                 (id (car (inspect-select-stack *current-inspect*))))             (multiple-value-bind (position parts)                 (find-part-id parent id)               (let ((new-position (if (string= ">" option)                                       (1+ position)                                       (1- position))))                 (if (< -1 new-position (parts-count parts))                     (let* ((value (component-at parts new-position)))                       (setf (car (inspect-object-stack *current-inspect*))                             value)                       (setf (car (inspect-select-stack *current-inspect*))                             (id-at parts new-position))                       (redisplay stream))                     (output-inspect-note stream                                          "Parent has no selectable component indexed by ~d"                                          new-position))))))       (no-object-msg stream))) (defun istep-cmd-set-raw (option-string stream)   (when (inspect-object-stack *current-inspect*)     (cond       ((null option-string)        (setq *inspect-raw* t))       ((eq (read-from-string option-string) t)        (setq *inspect-raw* t))       ((eq (read-from-string option-string) nil)        (setq *inspect-raw* nil)))     (redisplay stream))) (defun istep-cmd-reset ()   (reset-stack)   (throw 'repl-catcher (values :inspect nil))) (defun istep-cmd-help (stream)   (format stream *inspect-help*)) (defun istep-cmd-skip (option-string stream)   (if option-string       (let ((len (read-from-string option-string)))         (if (and (integerp len) (>= len 0))             (redisplay stream len)             (output-inspect-note stream "Skip length invalid")))       (output-inspect-note stream "Skip length missing"))) (defun istep-cmd-print (option-string stream)   (if option-string       (let ((len (read-from-string option-string)))         (if (and (integerp len) (plusp len))             (setq *inspect-length* len)             (output-inspect-note stream "Cannot set print limit to ~A~%" len)))       (output-inspect-note stream "Print length missing"))) (defun select-description (select)   (typecase select     (integer      (format nil "which is componenent number ~d of" select))     (symbol      (format nil "which is the ~a component of" select))     (string      (format nil "which was selected by ~A" select))     (t      (write-to-string select)))) (defun istep-cmd-tree (stream)   (let ((stack (inspect-object-stack *current-inspect*)))     (if stack         (progn           (output-inspect-note stream "The current object is:")           (dotimes (i (length stack))             (output-inspect-note                stream "~A, ~A"                (inspected-description (nth i stack))                (select-description                 (nth i (inspect-select-stack *current-inspect*))))))         (no-object-msg stream)))) (defun istep-cmd-set (id-string value-string stream)   (if (stack)       (let ((id (when id-string (read-from-string id-string))))         (multiple-value-bind (position parts)             (find-part-id (car (stack)) id)           (if parts               (if position                   (when value-string                     (let ((new-value (eval (read-from-string value-string))))                       (let ((result (set-component-value (car (stack))                                                          id                                                          new-value                                                          (component-at                                                           parts position))))                         (typecase result                           (string                            (output-inspect-note stream result))                           (t                            (redisplay stream))))))                   (output-inspect-note                    stream                    "Object has no selectable component named by ~A" id))               (output-inspect-note stream                                    "Object has no selectable components"))))       (no-object-msg stream))) (defun istep-cmd-select-component (id stream)   (if (stack)       (multiple-value-bind (position parts)           (find-part-id (car (stack)) id)         (cond           ((integerp position)            (let* ((value (component-at parts position)))              (cond ((eq value *inspect-unbound-object-marker*)                     (output-inspect-note stream "That slot is unbound"))                    (t                     (push value (inspect-object-stack *current-inspect*))                     (push id (inspect-select-stack *current-inspect*))                     (redisplay stream)))))           ((null parts)            (output-inspect-note stream "Object does not contain any subobjects"))           (t            (typecase id              (symbol               (output-inspect-note                stream "Object has no selectable component named ~A"                id))              (integer               (output-inspect-note                stream "Object has no selectable component indexed by ~d"                id))))))       (no-object-msg stream))) (defun istep-cmd-set-stack (form stream)   (reset-stack (eval form) ":i ...")   (redisplay stream)) (defun no-object-msg (s)   (output-inspect-note s "No object is being inspected")) (defun display-current (s length skip)   (if (stack)       (let ((inspected (car (stack))))         (setq cl:* inspected)         (display-inspect inspected s length skip))       (no-object-msg s))) ;;; ;;; aclrepl-specific inspection display ;;; (defun display-inspect (object stream &optional length (skip 0))   (multiple-value-bind (elements labels count)       (inspected-elements object length skip)     (fresh-line stream)     (format stream "~A" (inspected-description object))     (unless (or *skip-address-display*                 (eq object *inspect-unbound-object-marker*)                 (characterp object) (typep object 'fixnum))       (write-string " at #x" stream)       (format stream (n-word-bits-hex-format)               (logand (sb-kernel:get-lisp-obj-address object)                       (lognot sb-vm:lowtag-mask))))     (dotimes (i count)       (fresh-line stream)       (display-labeled-element (elt elements i) (elt labels i) stream)))) (defun array-label-p (label)   (and (consp label)        (stringp (cdr label))        (char= (char (cdr label) 0) #\[))) (defun named-or-array-label-p (label)   (and (consp label) (not (hex-label-p label)))) (defun hex-label-p (label &optional width)   (and (consp label)        (case width              (32 (eq (cdr label) :hex32))              (64 (eq (cdr label) :hex64))              (t (or (eq (cdr label) :hex32)                     (eq (cdr label) :hex64)))))) (defun display-labeled-element (element label stream)   (cond     ((eq label :ellipses)      (format stream "   ..."))     ((eq label :tail)      (format stream "tail-> ~A" (inspected-description element)))     ((named-or-array-label-p label)      (format stream              (if (array-label-p label)                  "~4,' D ~A-> ~A"                  "~4,' D ~16,1,1,'-A> ~A")              (car label)              (format nil "~A " (cdr label))              (inspected-description element)))     ((hex-label-p label 32)      (format stream "~4,' D-> #x~8,'0X" (car label) element))     ((hex-label-p label 64)      (format stream "~4,' D-> #x~16,'0X" (car label) element))     (t      (format stream "~4,' D-> ~A" label (inspected-description element))))) ;;; THE BEGINNINGS OF AN INSPECTOR API ;;; which can be used to retrieve object descriptions as component values/labels and also ;;; process print length and skip selectors ;;; ;;; FUNCTIONS TO CONSIDER FOR EXPORT ;;;   FIND-PART-ID ;;;   COMPONENT-AT ;;;   ID-AT ;;;   INSPECTED-ELEMENTS ;;;   INSPECTED-DESCRIPTION ;;; ;;; will also need hooks ;;;    *inspect-start-inspection* ;;;       (maybe. Would setup a window for a GUI inspector) ;;;    *inspect-prompt-fun* ;;;    *inspect-read-cmd* ;;; ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook ;;; That'll depend if choose to have standardized inspector commands such that ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will ;;; process and then call the *inspect-display* hook, or if the ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will ;;; send to the contributed inspector for processing and display. (defun find-part-id (object id)   "COMPONENT-ID can be an integer or a name of a id. Returns (VALUES POSITION PARTS). POSITION is NIL if the id is invalid or not found."   (let* ((parts (inspected-parts object))          (name (if (symbolp id) (symbol-name id) id)))     (values      (cond        ((and (numberp id)              (< -1 id (parts-count parts))              (not (eq (parts-seq-type parts) :bignum)))         id)        (t         (case (parts-seq-type parts)           (:named            (position name (the list (parts-components parts))                      :key #'car :test #'string-equal))           ((:dotted-list :cyclic-list)            (when (string-equal name "tail")              (1- (parts-count parts)))))))      parts))) (defun component-at (parts position)   (let ((count (parts-count parts))         (components (parts-components parts)))     (when (< -1 position count)       (case (parts-seq-type parts)         (:dotted-list          (if (= position (1- count))              (cdr (last components))              (elt components position)))         (:cyclic-list          (if (= position (1- count))              components              (elt components position)))         (:named          (cdr (elt components position)))         (:array          (aref (the array components) position))         (:bignum          (bignum-component-at components position))         (t          (elt components position)))))) (defun id-at (parts position)   (let ((count (parts-count parts)))     (when (< -1 position count)       (case (parts-seq-type parts)         ((:dotted-list :cyclic-list)          (if (= position (1- count))              :tail              position))         (:array          (array-index-string position parts))         (:named          (car (elt (parts-components parts) position)))         (t          position))))) (defun inspected-elements (object &optional length (skip 0))   "Returns elements of an object that have been trimmed and labeled based on length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT) where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items. LABELS elements may be a string, number, cons pair, :tail, or :ellipses. This function may return an ELEMENT-COUNT of up to (+ 3 length) which would include an :ellipses at the beginning, :ellipses at the end, and the last element."   (let* ((parts (inspected-parts object))          (print-length (if length length (parts-count parts)))          (last-part (last-part parts))          (last-requested (last-requested parts print-length skip))          (element-count (compute-elements-count parts print-length skip))          (first-to (if (first-element-ellipses-p parts skip) 1 0))          (elements (when (plusp element-count) (make-array element-count)))          (labels (when (plusp element-count) (make-array element-count))))     (when (plusp element-count)       ;; possible first ellipses      (when (first-element-ellipses-p parts skip)         (set-element-values elements labels 0 nil :ellipses))       ;; main elements      (do* ((i 0 (1+ i)))            ((> i (- last-requested skip)))         (set-element elements labels parts (+ i first-to) (+ i skip)))       ;; last parts value if needed      (when (< last-requested last-part)         (set-element elements labels parts (- element-count 1) last-part))       ;; ending ellipses or next to last parts value if needed      (when (< last-requested (1- last-part))         (if (= last-requested (- last-part 2))             (set-element elements labels parts (- element-count 2) (1- last-part))             (set-element-values elements labels (- element-count 2) nil :ellipses))))     (values elements labels element-count))) (defun last-requested (parts print skip)   (min (1- (parts-count parts)) (+ skip print -1))) (defun last-part (parts)   (1- (parts-count parts))) (defun compute-elements-count (parts length skip)   "Compute the number of elements in parts given the print length and skip."   (let ((element-count (min (parts-count parts) length                             (max 0 (- (parts-count parts) skip)))))     (when (and (plusp (parts-count parts)) (plusp skip)) ; starting ellipses      (incf element-count))     (when (< (last-requested parts length skip)           &