- ;; Redisplay
- ((or (string= "=" option)
- (zerop (length args)))
- (%inspect output-stream))
- ;; Select parent
- ((or (string= "-" option)
- (string= "^" option))
- (cond
- ((> (length stack) 1)
- (pop stack)
- (%inspect output-stream))
- (stack
- (format output-stream "Object has no parent.~%"))
- (t
- (%inspect output-stream))))
- ;; Select * to inspect
- ((string= "*" option)
- (reset-stack)
- (setf (inspect-object-stack *current-inspect*) (list *))
- (setf (inspect-parent-stack *current-inspect*) (list "(inspect ...)"))
- (set-break-inspect *current-inspect*)
- (%inspect output-stream))
- ;; Start new inspect level for eval'd form
- ((string= "+" option)
- (inspector (eval (read-from-string (second args))) nil output-stream))
- ;; Next or previous parent component
- ((or (string= "<" option)
- (string= ">" option))
- (if stack
- (if (eq (length stack) 1)
- (format output-stream "Object does not have a parent")
- (let ((parent (second stack))
- (id (car (inspect-parent-stack *current-inspect*))))
- (multiple-value-bind (position list-type elements)
- (find-object-component parent id)
- (declare (list elements)
- (ignore list-type))
- (let ((new-position (if (string= ">" option)
- (1+ position)
- (1- position))))
- (if (< -1 new-position (length elements))
- (let ((new-object (elt elements new-position)))
- (setf (car stack) new-object)
- (setf (car (inspect-parent-stack *current-inspect*))
- (if (integerp id)
- new-position
- (read-from-string
- (car (nth new-position elements)))))
- (%inspect output-stream))
- (format output-stream "Parent has no selectable component indexed by ~d"
- new-position))))))
- (%inspect output-stream)))
- ;; Set component to eval'd form
- ((string-equal "set" option)
- (if stack
- (let ((id (when (second args)
- (read-from-string (second args)))))
- (multiple-value-bind (position list-type elements)
- (find-object-component (car stack) id)
- (declare (ignore list-type))
- (if elements
- (if position
- (let ((value-stirng (third args)))
- (when value-stirng
- (let ((new-value (eval (read-from-string (third args)))))
- (let ((result
- (set-component-value (car stack)
- id
- new-value
- (nth position elements))))
- (typecase result
- (string
- (format output-stream result))
- (t
- (%inspect output-stream)))))))
- (format output-stream
- "Object has no selectable component named by ~A" id))
- (format output-stream
- "Object has no selectable components"))))
- (%inspect output-stream)))
- ;; Set/reset raw display mode for components
- ((string-equal "raw" option)
- (when stack
- (when (and (second args)
- (or (null (second args))
- (eq (read-from-string (second args)) t)))
- (setq *inspect-raw* t))
- (%inspect output-stream)))
- ;; Reset stack
- ((string-equal "q" option)
- (reset-stack)
- (set-break-inspect *current-inspect*))
- ;; Display help
- ((string-equal "?" option)
- (format output-stream *inspect-help*))
- ;; Set number of components to skip
- ((string-equal "skip" option)
- (let ((len (read-from-string (second args))))
- (if (and (integerp len) (>= len 0))
- (let ((*inspect-skip* len))
- (%inspect output-stream))
- (format output-stream "Skip missing or invalid~%"))))
- ;; Print stack tree
- ((string-equal "tree" option)
- (if stack
- (progn
- (format output-stream "The current object is:~%")
- (dotimes (i (length stack))
- (format output-stream "~A, ~A~%"
- (inspected-parts (nth i stack) :description t)
- (let ((select (nth i (inspect-parent-stack *current-inspect*))))
- (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 ~S" select))
- (t
- (write-to-string select)))))))
- (%inspect output-stream)))
- ;; Set maximum number of components to print
- ((string-equal "print" option)
- (let ((len (read-from-string (second args))))
- (if (and (integerp len) (plusp len))
- (setq *inspect-length* len)
- (format output-stream "Cannot set print limit to ~A~%" len))))
- ;; Select numbered or named component
- ((or (symbolp option-read)
- (integerp option-read))
- (if stack
- (multiple-value-bind (position list-type elements)
- (find-object-component (car stack) option-read)
- (cond
- ((integerp position)
- (let* ((element (elt elements position))
- (value (if (eq list-type :named) (cdr element) element)))
- (cond ((eq value *inspect-unbound-object-marker*)
- (format output-stream "That slot is unbound~%"))
- (t
- (push value (inspect-object-stack *current-inspect*))
- (push option-read (inspect-parent-stack *current-inspect*))
- (%inspect output-stream)))))
- ((null elements)
- (format output-stream "Object does not contain any subobjects~%"))
- (t
- (typecase option-read
- (symbol
- (format output-stream
- "Object has no selectable component named ~A"
- option))
- (integer
- (format output-stream
- "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
- option-read
- (= (length elements) 1)
- (1- (length elements))))))))
- (%inspect output-stream)))
- ;; Default is to select eval'd form
- (t
- (reset-stack)
- (let ((object (eval option-read)))
- (setf (inspect-object-stack *current-inspect*) (list object))
- (setf (inspect-parent-stack *current-inspect*)
- (list (format nil ":i ~S" object))))
- (set-break-inspect *current-inspect*)
- (%inspect output-stream))
- )))
-
-(defun find-object-component (object id)
+ ((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*)
+ (and (= sb-vm::n-word-bits 64) (typep object 'single-float))
+ (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)