(cl:in-package :sb-aclrepl)
-(defparameter *inspect-stack* nil
- "Stack of the hierarchy of an inspected object.")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +default-inspect-length+ 10))
-(defparameter *parent-select-stack* nil
- "a stack of the indices of parent object components that brought us to the current object.")
-
-(defparameter *inspect-length* 10
- "Number of components to display.")
+(defstruct inspect
+ ;; stack of parents of inspected object
+ object-stack
+ ;; a stack of indices of parent object components
+ parent-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.")
-
-(defvar *inspected*)
-(setf (documentation '*inspected* 'variable)
- "the value currently being inspected by CL:INSPECT")
+(defparameter *inspect-length* +default-inspect-length+
+ "maximum number of components to print")
+(defparameter *inspect-skip* 0
+ "number of initial components to skip when displaying an object")
(defvar *inspect-help*
":istep takes between 0 to 3 arguments.
;; Setup binding for multithreading
-(let ((*inspect-stack* nil)
- (*parent-select-stack* nil)
- (*inspect-length* 10)
+(let ((*current-inspect* nil)
(*inspect-raw* nil)
- (*inspected* nil))
+ (*inspect-length* +default-inspect-length+)
+ (*inspect-skip* 0))
(defun inspector (object input-stream output-stream)
(declare (ignore input-stream))
(setq object (eval object))
+ (setq *current-inspect* (make-inspect))
+ (new-break :inspect *current-inspect*)
(reset-stack)
- (setq *inspect-stack* (list object))
- (setq *parent-select-stack* (list "(inspect ...)"))
+ (setf (inspect-object-stack *current-inspect*) (list object))
+ (setf (inspect-parent-stack *current-inspect*)
+ (list (format nil "(inspect ~S)" object)))
(%inspect output-stream))
+(defun set-current-inspect (inspect)
+ (setq *current-inspect* inspect))
(defun istep (arg-string output-stream)
- (%istep arg-string (string-to-list-skip-spaces arg-string) output-stream))
+ (%istep arg-string output-stream))
(setq sb-impl::*inspect-fun* #'inspector)
(defun reset-stack ()
- (setq *inspect-stack* nil)
- (setq *parent-select-stack* nil)
- (makunbound '*inspected*))
-
-(defun %istep (arg-string args output-stream)
- (let* ((option (car args))
+ (setf (inspect-object-stack *current-inspect*) nil)
+ (setf (inspect-parent-stack *current-inspect*) nil))
+
+(defun %istep (arg-string output-stream)
+ (unless *current-inspect*
+ (setq *current-inspect* (make-inspect)))
+ (let* ((args (when arg-string (string-to-list-skip-spaces arg-string)))
+ (option (car args))
(option-read (when arg-string
- (read-from-string arg-string))))
+ (read-from-string arg-string)))
+ (stack (inspect-object-stack *current-inspect*)))
(cond
;; Redisplay
((or (string= "=" option)
((or (string= "-" option)
(string= "^" option))
(cond
- ((> (length *inspect-stack*) 1)
- (pop *inspect-stack*)
+ ((> (length stack) 1)
+ (pop stack)
(%inspect output-stream))
- (*inspect-stack*
- (format output-stream "Object has no parent.~%"))
+ (stack
+ (format output-stream "Object has no parent.~%"))
(t
(%inspect output-stream))))
;; Select * to inspect
((string= "*" option)
(reset-stack)
- (setq *inspect-stack* (list *))
- (setq *parent-select-stack* (list "(inspect ...)"))
+ (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 (second args)) nil output-stream))
+ (inspector (eval (read-from-string (second args))) nil output-stream))
;; Next or previous parent component
((or (string= "<" option)
(string= ">" option))
- (if *inspect-stack*
- (if (eq (length *inspect-stack*) 1)
+ (if stack
+ (if (eq (length stack) 1)
(format output-stream "Object does not have a parent")
- (let ((parent (second *inspect-stack*))
- (id (car *parent-select-stack*)))
+ (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)
(1- position))))
(if (< -1 new-position (length elements))
(let ((new-object (elt elements new-position)))
- (setf (car *inspect-stack*) new-object)
- (setf (car *parent-select-stack*)
+ (setf (car stack) new-object)
+ (setf (car (inspect-parent-stack *current-inspect*))
(if (integerp id)
new-position
(read-from-string
(%inspect output-stream)))
;; Set component to eval'd form
((string-equal "set" option)
- (if *inspect-stack*
+ (if stack
(let ((id (when (second args)
(read-from-string (second args)))))
(multiple-value-bind (position list-type elements)
- (find-object-component (car *inspect-stack*) id)
+ (find-object-component (car stack) id)
(declare (ignore list-type))
(if elements
(if position
(when value-stirng
(let ((new-value (eval (read-from-string (third args)))))
(let ((result
- (set-component-value (car *inspect-stack*)
+ (set-component-value (car stack)
id
new-value
(nth position elements))))
(%inspect output-stream)))
;; Set/reset raw display mode for components
((string-equal "raw" option)
- (when *inspect-stack*
+ (when stack
(when (and (second args)
(or (null (second args))
(eq (read-from-string (second args)) t)))
(%inspect output-stream)))
;; Reset stack
((string-equal "q" option)
- (reset-stack))
+ (reset-stack)
+ (set-break-inspect *current-inspect*))
;; Display help
((string-equal "?" option)
(format output-stream *inspect-help*))
((string-equal "skip" option)
(let ((len (read-from-string (second args))))
(if (and (integerp len) (>= len 0))
- (%inspect output-stream len)
+ (let ((*inspect-skip* len))
+ (%inspect output-stream))
(format output-stream "Skip missing or invalid~%"))))
;; Print stack tree
((string-equal "tree" option)
- (if *inspect-stack*
+ (if stack
(progn
(format output-stream "The current object is:~%")
- (dotimes (i (length *inspect-stack*))
+ (dotimes (i (length stack))
(format output-stream "~A, ~A~%"
- (inspected-parts (nth i *inspect-stack*) :description t)
- (let ((select (nth i *parent-select-stack*)))
+ (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))
;; Select numbered or named component
((or (symbolp option-read)
(integerp option-read))
- (if *inspect-stack*
+ (if stack
(multiple-value-bind (position list-type elements)
- (find-object-component (car *inspect-stack*) option-read)
+ (find-object-component (car stack) option-read)
(cond
((integerp position)
(let* ((element (elt elements position))
(cond ((eq value *inspect-unbound-object-marker*)
(format output-stream "That slot is unbound~%"))
(t
- (push value *inspect-stack*)
- (push option-read *parent-select-stack*)
+ (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~%"))
;; Default is to select eval'd form
(t
(reset-stack)
- (setq *inspect-stack* (list (eval option-read)))
- (setq *parent-select-stack* (list ":i <form>"))
+ (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))
)))
(values nil nil nil)))
-(defun %inspect (s &optional (skip 0))
- (if *inspect-stack*
- (progn
- (setq *inspected* (car *inspect-stack*))
- (setq cl:* *inspected*)
- (multiple-value-bind (description list-type elements) (inspected-parts *inspected*)
- (display-inspected-parts *inspected* description list-type elements s skip)))
+(defun %inspect (s)
+ (if (inspect-object-stack *current-inspect*)
+ (let ((inspected (car (inspect-object-stack *current-inspect*))))
+ (setq cl:* inspected)
+ (multiple-value-bind (description list-type elements)
+ (inspected-parts inspected)
+ (display-inspected-parts inspected description list-type elements s)))
(format s "No object is being inspected")))
-(defun display-inspected-parts (object description list-type elements stream &optional (skip 0))
+(defun current-length ()
+ "returns the current LENGTH for component display"
+ *inspect-length*)
+
+(defun current-skip ()
+ "returns the current SKIP for component display"
+ *inspect-skip*)
+
+
+(defun display-inspected-parts (object description list-type elements stream)
(format stream "~&~A" description)
(unless (or (characterp object) (typep object 'fixnum))
(format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
(princ #\newline stream)
(when elements
- (do* ((index skip (1+ index))
- (nelem (length elements))
- (max (min (1- nelem) (+ skip *inspect-length*)))
- (suspension (when (plusp (- nelem max))
- (- nelem max)))
- (count (if (typep elements 'sequence)
- (length elements)
- 0))
- (element))
- ((> index max))
- (declare (ignore suspension)) ;; FIXME - not yet implemented
- (setq element (elt elements index))
- (cond
- ((eq list-type :index-with-tail)
- (if (eql index (- count 1))
- (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
- (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
- ((eq list-type :named)
- (destructuring-bind (name . value) element
- (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A " name)
- (if (eq value *inspect-unbound-object-marker*)
- "..unbound.."
- (inspected-parts value :description t)))))
- (t
- (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))))
+ (let* ((n-elem (length elements))
+ (last (1- n-elem))
+ (max (min last (+ *inspect-skip* *inspect-length*))))
+ (do* ((index *inspect-skip* (1+ index))
+ (count (if (typep elements 'sequence)
+ (length elements)
+ 0))
+ (element))
+ ((> index max))
+ (setq element (elt elements index))
+ (cond
+ ((eq list-type :index-with-tail)
+ (if (eql index (- count 1))
+ (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
+ (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
+ ((eq list-type :named)
+ (destructuring-bind (name . value) element
+ (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A " name)
+ (if (eq value *inspect-unbound-object-marker*)
+ "..unbound.."
+ (inspected-parts value :description t)))))
+ (t
+ (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))
+ (when (< (+ *inspect-skip* *inspect-length*) last)
+ (format stream "~& ...~%~4,' D ~A~%" last (elt elements last))))
+ ))
) ;; end binding for multithreading
\f
;;; INSPECTED-PARTS
;;;
+;;; 20030408 - Reworked by KMR to take a :DESCRIPTION keyword
+;;; and to return LIST-TYPE rather than NAMED-P
+;;;
;;; Destructure an object for inspection, returning either
;;; DESCRIPTION
;;; if description keyword is T, otherwise returns
;;; of ELEMENTS.
;;; If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
;;; If LIST-TYPE is :index-with-tail, then each element is just value,
-;;; but the last element is label as "tail"
+;;; but the last element is labelled as "tail"
;;; If LIST-TYPE is :long, then each element is just value,
;;; and suspension points ('...) are shown before the last element.
;;; Otherwise, each element is just VALUE.
(list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
(defmethod inspected-parts ((object vector) &key description)
+ (declare (vector object))
(let ((desc (format nil
"a ~:[~;displaced ~]vector (~W)"
(and (sb-kernel:array-header-p object)
(format nil "[~W~{,~W~}]" (car list) (cdr list)))))
(defmethod inspected-parts ((object simple-vector) &key description)
+ (declare (simple-vector object))
(let ((desc (format nil "a simple ~A vector (~D)"
(array-element-type object)
(length object))))
(sb-kernel:%array-displaced-p object))
(array-element-type object)
dimensions)))
+ (declare (array reference-array))
(if description
desc
(progn
projects / sbcl.git / blobdiff