- (unwind-protect
- (input-loop object (describe-parts object) *standard-output*)
- (setf *inspect-object-stack* nil)))
-
-;;; When *ILLEGAL-OBJECT-MARKER* occurs in a parts list, it indicates
-;;; that that slot is unbound.
-(defvar *illegal-object-marker* (cons nil nil))
-
-(defun input-loop (object parts s)
- (tty-display-object parts s)
- (loop
- (format s "~&> ")
- (force-output)
- (let ((command (read))
- ;; Use 2 less than the length because the first 2 elements
- ;; are bookkeeping.
- (parts-len-2 (- (length parts) 2)))
- (typecase command
- (integer
- (cond ((< -1 command parts-len-2)
- (cond ((eq (nth-parts parts command) *illegal-object-marker*)
- (format s "~%That slot is unbound.~%"))
- (t
- (push (cons object parts) *inspect-object-stack*)
- (setf object (nth-parts parts command))
- (setf parts (describe-parts object))
- (tty-display-object parts s))))
- (t
- (if (= parts-len-2 0)
- (format s "~%This object contains nothing to inspect.~%~%")
- (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%"
- (= parts-len-2 1) (1- parts-len-2))))))
- (symbol
- (case (find-symbol (symbol-name command) *keyword-package*)
- ((:q :e)
- (return object))
- (:u
- (cond (*inspect-object-stack*
- (setf object (caar *inspect-object-stack*))
- (setf parts (cdar *inspect-object-stack*))
- (pop *inspect-object-stack*)
- (tty-display-object parts s))
- (t (format s "~%Bottom of Stack.~%"))))
- (:r
- (setf parts (describe-parts object))
- (tty-display-object parts s))
- (:d
- (tty-display-object parts s))
- ((:h :? :help)
- (show-help s))
- (t
- (do-inspect-eval command s))))
- (t
- (do-inspect-eval command s))))))
-
-(defun do-inspect-eval (command stream)
- (let ((result-list (restart-case (multiple-value-list (eval command))
- (nil () :report "Return to the inspector."
- (format stream "~%returning to the inspector~%")
- (return-from do-inspect-eval nil)))))
- (setf /// // // / / result-list)
- (setf +++ ++ ++ + + - - command)
- (setf *** ** ** * * (car /))
- (format stream "~&~{~S~%~}" /)))
-
-(defun show-help (s)
- (terpri)
- (write-line "inspector help:" s)
- (write-line " R - recompute current object." s)
- (write-line " D - redisplay current object." s)
- (write-line " U - Move upward through the object stack." s)
- (write-line " Q, E - Quit inspector." s)
- (write-line " ?, H, Help - Show this help." s))
-
-(defun tty-display-object (parts stream)
- (format stream "~%~A" (car parts))
- (let ((numbered-parts-p (numbered-parts-p parts))
- (parts (cddr parts)))
- (do ((part parts (cdr part))
- (i 0 (1+ i)))
- ((endp part) nil)
- (if numbered-parts-p
- (format stream "~D. ~A: ~A~%" i (caar part)
- (if (eq (cdar part) *illegal-object-marker*)
- "unbound"
- (cdar part)))
- (format stream "~D. ~A~%" i (car part))))))
+ (funcall *inspect-fun* object *standard-input* *standard-output*))
+
+(defvar *help-for-inspect*
+ "
+help for INSPECT:
+ Q, E - Quit the inspector.
+ <integer> - Inspect the numbered slot.
+ R - Redisplay current inspected object.
+ U - Move upward/backward to previous inspected object.
+ ?, H, Help - Show this help.
+ <other> - Evaluate the input as an expression.
+Within the inspector, the special variable SB-EXT:*INSPECTED* is bound
+to the current inspected object, so that it can be referred to in
+evaluated expressions.
+")
+
+(defun %inspect (*inspected* s)
+ (named-let redisplay () ; "LAMBDA, the ultimate GOTO":-|
+ (multiple-value-bind (description named-p elements)
+ (inspected-parts *inspected*)
+ (tty-display-inspected-parts description named-p elements s)
+ (named-let reread ()
+ (format s "~&> ")
+ (force-output)
+ (let* (;; newly-consed object for hermetic protection against
+ ;; mischievous input like #.*EOF-OBJECT*:
+ (eof (cons *eof-object* nil))
+ (command (read *standard-input* nil eof)))
+ (when (eq command eof)
+ ;; currently-undocumented feature: EOF is handled as Q.
+ ;; If there's ever consensus that this is *the* right
+ ;; thing to do (as opposed to e.g. handling it as U), we
+ ;; could document it. Meanwhile, it seems more Unix-y to
+ ;; do this than to signal an error.
+ (/show0 "THROWing QUIT-INSPECT for EOF")
+ (throw 'quit-inspect nil))
+ (typecase command
+ (integer
+ (let ((elements-length (length elements)))
+ (cond ((< -1 command elements-length)
+ (let* ((element (nth command elements))
+ (value (if named-p (cdr element) element)))
+ (cond ((eq value *inspect-unbound-object-marker*)
+ (format s "~%That slot is unbound.~%")
+ (return-from %inspect (reread)))
+ (t
+ (%inspect value s)
+ ;; If we ever return, then we should be
+ ;; looking at *INSPECTED* again.
+ (return-from %inspect (redisplay))))))
+ ((zerop elements-length)
+ (format s "~%The object contains nothing to inspect.~%")
+ (return-from %inspect (reread)))
+ (t
+ (format s "~%Enter a valid index (~:[0-~W~;0~]).~%"
+ (= elements-length 1) (1- elements-length))
+ (return-from %inspect (reread))))))
+ (symbol
+ (case (find-symbol (symbol-name command) *keyword-package*)
+ ((:q :e)
+ (/show0 "THROWing QUIT-INSPECT for :Q or :E")
+ (throw 'quit-inspect nil))
+ (:u
+ (return-from %inspect))
+ (:r
+ (return-from %inspect (redisplay)))
+ ((:h :? :help)
+ (write-string *help-for-inspect* s)
+ (return-from %inspect (reread)))
+ (t
+ (eval-for-inspect command s)
+ (return-from %inspect (reread)))))
+ (t
+ (eval-for-inspect command s)
+ (return-from %inspect (reread)))))))))
+
+(defun eval-for-inspect (command stream)
+ (let ((result-list (restart-case
+ (multiple-value-list (interactive-eval command))
+ (nil () :report "Return to the inspector."
+ (format stream "~%returning to the inspector~%")
+ (return-from eval-for-inspect nil)))))
+ (format stream "~&~{~S~%~}" result-list)))
+
+(defun tty-display-inspected-parts (description named-p elements stream)
+ (format stream "~%~A" description)
+ (let ((index 0))
+ (dolist (element elements)
+ (if named-p
+ (destructuring-bind (name . value) element
+ (format stream "~W. ~A: ~W~%" index name
+ (if (eq value *inspect-unbound-object-marker*)
+ "unbound"
+ value)))
+ (format stream "~W. ~W~%" index element))
+ (incf index))))