;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
;;;; variable.
-(cl:in-package :sb-aclrepl)
+(cl:in-package #:sb-aclrepl)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +default-inspect-length+ 10))
+ (defconstant +default-inspect-length+ 20))
-(defstruct inspect
+(defstruct (%inspect (:constructor make-inspect)
+ (:conc-name inspect-))
;; stack of parents of inspected object
object-stack
;; a stack of indices of parent object components
"Raw mode for object display.")
(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")
+(defparameter *skip-address-display* nil
+ "Skip displaying addresses of objects.")
(defvar *inspect-help*
":istep takes between 0 to 3 arguments.
: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 previous parent component
:i > inspect next parent component
:i set <index> <form> set indexed component to evalated form
-i set <name> <form> set named 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.
-(defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
-;; Setup binding for multithreading
-(let ((*current-inspect* nil)
- (*inspect-raw* nil)
- (*inspect-length* +default-inspect-length+)
- (*inspect-skip* 0))
-
- (defun inspector (object input-stream output-stream)
- (declare (ignore input-stream))
- (setq object (eval 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))
- (new-break :inspect *current-inspect*)
- (reset-stack)
- (setf (inspect-object-stack *current-inspect*) (list object))
- (setf (inspect-select-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 output-stream))
-
- (setq sb-impl::*inspect-fun* #'inspector)
-
- (defun reset-stack ()
- (setf (inspect-object-stack *current-inspect*) nil)
- (setf (inspect-select-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)))
- (stack (inspect-object-stack *current-inspect*)))
- (cond
- ;; Redisplay
- ((or (string= "=" option)
- (zerop (length args)))
- (%inspect output-stream))
- ;; Select parent
- ((or (string= "-" option)
- (string= "^" option))
- (cond
- ((> (length stack) 1)
- (setf (inspect-object-stack *current-inspect*) (cdr stack))
- (setf (inspect-select-stack *current-inspect*)
- (cdr (inspect-select-stack *current-inspect*)))
- (%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-select-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-select-stack *current-inspect*))))
- (multiple-value-bind (position parts)
- (find-object-part-with-id parent id)
- (let ((new-position (if (string= ">" option)
- (1+ position)
- (1- position))))
- (if (< -1 new-position (parts-count parts))
- (let* ((value (element-at parts new-position)))
- (setf (car stack) value)
- (setf (car (inspect-select-stack *current-inspect*))
- (if (integerp id)
- new-position
- (let ((label (label-at parts new-position)))
- (if (stringp label)
- (read-from-string label)
- label))))
- (%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 parts)
- (find-object-part-with-id (car stack) id)
- (if parts
- (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
- (element-at parts position))))
- (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-description (nth i stack))
- (let ((select (nth i (inspect-select-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 parts)
- (find-object-part-with-id (car stack) option-read)
- (cond
- ((integerp position)
- (let* ((value (element-at parts position)))
- (cond ((eq value *inspect-unbound-object-marker*)
- (format output-stream "That slot is unbound~%"))
+ (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
- (push value (inspect-object-stack *current-inspect*))
- (push option-read (inspect-select-stack *current-inspect*))
- (%inspect output-stream)))))
- ((null parts)
- (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
- (= (parts-count parts) 1)
- (1- (parts-count parts))))))))
- (%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-select-stack *current-inspect*)
- (list (format nil ":i ~S" object))))
- (set-break-inspect *current-inspect*)
- (%inspect output-stream))
- )))
-
- (defun %inspect (s)
- (if (inspect-object-stack *current-inspect*)
- (let ((inspected (car (inspect-object-stack *current-inspect*))))
- (setq cl:* inspected)
- (display-inspected-parts inspected s))
- (format s "No object is being inspected")))
-
-
- (defun display-inspected-parts (object stream)
- (multiple-value-bind (elements labels count)
- (inspected-elements object *inspect-length* *inspect-skip*)
- (format stream "~&~A" (inspected-description object))
- (unless (or (characterp object) (typep object 'fixnum))
- (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
- (princ #\newline stream)
- (dotimes (i count)
- (let ((label (elt labels i))
- (element (elt elements i)))
- (cond
- ((eq label :ellipses)
- (format stream "~& ...~%"))
- ((eq label :tail)
- (format stream "tail-> ~A~%" (inspected-description element)))
- ((consp label)
- (format stream
- (if (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[))
- ;; for arrays
- "~4,' D ~A-> ~A~%"
- ;; for named
- "~4,' D ~16,1,1,'-A> ~A~%")
- (car label)
- (format nil "~A " (cdr label))
- (if (eq element *inspect-unbound-object-marker*)
- "..unbound.."
- (inspected-description element))))
- (t
- (if (integerp label)
- (format stream "~4,' D-> ~A~%" label (inspected-description element))
- (format stream "~4A-> ~A~%" label (inspected-description element)))))))))
-
- ) ;; end binding for multithreading
+ (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))
+ (format stream " at #x~X" (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 hex32-label-p (label)
+ (and (consp label) (eq (cdr label) :hex32)))
+
+(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 (hex32-label-p label))))
+
+(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)))
+ ((hex32-label-p label)
+ (format stream "~4,' D-> #x~8,'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 component length and skip selectors
+;;; process print length and skip selectors
;;;
;;; FUNCTIONS TO CONSIDER FOR EXPORT
-;;; FIND-OBJECT-PART-WITH-ID
-;;; ELEMENT-AT
-;;; LABEL-AT
+;;; 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-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.
+;;; 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-object-part-with-id (object id)
+(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."
- (if object
- (let* ((parts (inspected-parts object))
- (seq-type (parts-seq-type parts))
- (count (parts-count parts))
- (components (parts-components parts)))
- (when (symbolp id)
- (setq id (symbol-name id)))
- (let ((position
- (cond ((and (eq seq-type :named)
- (stringp id))
- (position id (the list components) :key #'car
- :test #'string-equal))
- ((and (eq seq-type :improper-list)
- (stringp id)
- (string-equal id "tail"))
- (1- count))
- ((numberp id)
- (when (< -1 id count)
- id)))))
- (values position parts)))
- (values nil nil)))
-
-
-(defun element-at (parts position)
+ (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)
- (:improper-list
+ (: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 label-at (parts position)
+(defun id-at (parts position)
(let ((count (parts-count parts)))
(when (< -1 position count)
(case (parts-seq-type parts)
- (:improper-list
+ ((:dotted-list :cyclic-list)
(if (= position (1- count))
:tail
position))
(t
position)))))
-(defun label-at-maybe-with-index (parts position)
- (let ((label (label-at parts position)))
- (if (stringp label)
- (cons position label)
- label)))
+(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)
+ (last-part parts)) ; last value
+ (incf element-count)
+ (when (< (last-requested parts length skip)
+ (1- (last-part parts))) ; ending ellipses
+ (incf element-count)))
+ element-count))
+
+(defun set-element (elements labels parts to-index from-index)
+ (set-element-values elements labels to-index (component-at parts from-index)
+ (label-at parts from-index)))
+
+(defun set-element-values (elements labels index element label)
+ (setf (aref elements index) element)
+ (setf (aref labels index) label))
+
+(defun first-element-ellipses-p (parts skip)
+ (and (parts-count parts) (plusp skip)))
+
+(defun label-at (parts position)
+ "Helper function for inspected-elements. Conses the
+position with the label if the label is a string."
+ (let ((id (id-at parts position)))
+ (cond
+ ((stringp id)
+ (cons position id))
+ ((eq (parts-seq-type parts) :bignum)
+ (cons position :hex32))
+ (t
+ id))))
(defun array-index-string (index parts)
+ "Formats an array index in row major format."
(let ((rev-dimensions (parts-seq-hint parts)))
(if (null rev-dimensions)
"[]"
(push r list)))
(format nil "[~W~{,~W~}]" (car list) (cdr list))))))
-(defun inspected-elements (object length skip)
- "Returns elements of an object that have been trimmed and labeled based on
-length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains
-COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number,
-:tail, or :ellipses. This function may return a 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))
- (count (parts-count parts)))
- (unless skip (setq skip 0))
- (unless length (setq length count))
- (let* ((last (1- count))
- (last-req (min last (+ skip length -1))) ;; last requested element
- (total (min (- count skip) length)))
- (when (and (plusp total) (plusp skip)) ; starting ellipses
- (incf total))
- (when (< last-req last) ; last value
- (incf total)
- (when (< last-req (1- last)) ; ending ellipses
- (incf total)))
- (let ((index 0)
- (elements nil)
- (labels nil))
- (declare (type (or simple-vector null) elements labels))
- (when (plusp total)
- (setq elements (make-array total :adjustable nil :fill-pointer nil :initial-element nil))
- (setq labels (make-array total :adjustable nil :fill-pointer nil))
- (when (plusp skip)
- (setf (aref labels 0) :ellipses)
- (incf index))
- (do ((i 0 (1+ i)))
- ((> i (- last-req skip)))
- (setf (aref elements (+ i index)) (element-at parts (+ i skip)))
- (setf (aref labels (+ i index)) (label-at-maybe-with-index parts
- (+ i skip))))
-
- (when (< last-req last) ; last value
- (setf (aref elements (- total 1)) (element-at parts last))
- (setf (aref labels (- total 1)) (label-at-maybe-with-index parts
- last))
- (when (< last-req (1- last)) ; ending ellipses or 2nd to last value
- (if (= last-req (- last 2))
- (progn
- (setf (aref elements (- total 2)) (element-at parts (1- last)))
- (setf (aref labels (- total 2)) (label-at-maybe-with-index
- parts (1- last))))
- (setf (aref labels (- total 2)) :ellipses)))))
- (values elements labels total)))))
-
-
\f
;;; INSPECTED-DESCRIPTION
;;;
"a cons cell"
(inspected-description-of-nontrivial-list object)))
-(defun dotted-safe-length (object)
- "Returns (VALUES LENGTH PROPER-P) where length is the number of cons cells"
- (do ((length 0 (1+ length))
- (lst object (cdr lst)))
- ((not (consp lst))
- (if (null lst)
- (values length t)
- (values length nil)))
+(defun cons-safe-length (object)
+ "Returns (VALUES LENGTH LIST-TYPE) where length is the number of
+cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
+ (do ((length 1 (1+ length))
+ (lst (cdr object) (cdr lst)))
+ ((or (not (consp lst))
+ (eq object lst))
+ (cond
+ ((null lst)
+ (values length :normal))
+ ((atom lst)
+ (values length :dotted))
+ ((eq object lst)
+ (values length :cyclic))))
;; nothing to do in body
))
(defun inspected-description-of-nontrivial-list (object)
- (multiple-value-bind (length proper-p) (dotted-safe-length object)
- (if proper-p
- (format nil "a proper list with ~D element~:*~P" length)
- (format nil "a dotted list with ~D element~:*~P + tail" length))))
-
+ (multiple-value-bind (length list-type) (cons-safe-length object)
+ (format nil "a ~A list with ~D element~:*~P~A"
+ (string-downcase (symbol-name list-type)) length
+ (ecase list-type
+ ((:dotted :cyclic) "+tail")
+ (:normal "")))))
+
+(defun ref32-hexstr (obj &optional (offset 0))
+ (format nil "~8,'0X" (ref32 obj offset)))
+
+(defun ref32 (obj &optional (offset 0))
+ (sb-sys::without-gcing
+ (sb-sys:sap-ref-32
+ (sb-sys:int-sap
+ (logand (sb-kernel:get-lisp-obj-address obj) (lognot sb-vm:lowtag-mask)))
+ offset)))
+
+(defun description-maybe-internals (fmt objects internal-fmt &rest args)
+ (let ((base (apply #'format nil fmt objects)))
+ (if *skip-address-display*
+ base
+ (concatenate 'string
+ base " " (apply #'format nil internal-fmt args)))))
+
(defmethod inspected-description ((object double-float))
- (format nil "double-float ~W" object))
+ (description-maybe-internals "double-float ~W" (list object)
+ "[#~A ~A]"
+ (ref32-hexstr object 12)
+ (ref32-hexstr object 8)))
(defmethod inspected-description ((object single-float))
- (format nil "single-float ~W" object))
+ (description-maybe-internals "single-float ~W" (list object)
+ "[#x~A]"
+ (ref32-hexstr object 4)))
(defmethod inspected-description ((object fixnum))
- (format nil "fixnum ~W" object))
+ (description-maybe-internals "fixnum ~W" (list object)
+ "[#x~8,'0X]"
+ (ash object (1- sb-vm:n-lowtag-bits))))
(defmethod inspected-description ((object complex))
(format nil "complex number ~W" object))
(defmethod inspected-description ((object simple-string))
(format nil "a simple-string (~W) ~W" (length object) object))
+(defun bignum-words (bignum)
+ "Return the number of 32-bit words in a bignum"
+ (ash
+ (logand (ref32 bignum)
+ (lognot sb-vm:widetag-mask))
+ (- sb-vm:n-widetag-bits)))
+
+(defun bignum-component-at (bignum offset)
+ "Return the 32-bit word at 32-bit wide offset"
+ (ref32 bignum (* 4 (1+ offset))))
+
(defmethod inspected-description ((object bignum))
- (format nil "bignum ~W" object))
+ (format nil "bignum ~W with ~D 32-bit word~:*~P" object
+ (bignum-words object)))
(defmethod inspected-description ((object ratio))
(format nil "ratio ~W" object))
(defmethod inspected-description ((object character))
- (format nil "character ~W char-code #x~X" object (char-code object)))
+ ;; FIXME: This will need to change as and when we get more characters
+ ;; than just the 256 we have today.
+ (description-maybe-internals "character ~W char-code #x~2,'0X"
+ (list object (char-code object))
+ "[#x~8,'0X]"
+ (logior sb-vm:character-widetag
+ (ash (char-code object)
+ sb-vm:n-widetag-bits))))
(defmethod inspected-description ((object t))
(format nil "a generic object ~W" object))
+(defmethod inspected-description ((object (eql *inspect-unbound-object-marker*)))
+ "..unbound..")
+
\f
;;; INSPECTED-PARTS
;;;
;;; SEQ-TYPE determines what representation is used for components
;;; of COMPONENTS.
;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
-;;; If SEQ-TYPE is :improper-list, then each element is just value,
+;;; If SEQ-TYPE is :dotted-list, then each element is just value,
;;; but the last element must be retrieved by
;;; (cdr (last components))
+;;; If SEQ-TYPE is :cylic-list, then each element is just value,
;;; If SEQ-TYPE is :list, then each element is a value of an array
;;; If SEQ-TYPE is :vector, then each element is a value of an vector
;;; If SEQ-TYPE is :array, then each element is a value of an array
-;;; with rank >= 2
+;;; with rank >= 2. The
+;;; If SEQ-TYPE is :bignum, then object is just a bignum and not a
+;;; a sequence
;;;
;;; COUNT is the total number of components in the OBJECT
;;;
-;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array
+;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
;;; to hold the reverse-dimensions of the orignal array.
(declaim (inline parts-components))
(defmethod inspected-parts ((object symbol))
(let ((components
- (list (cons "name" (symbol-name object))
- (cons "package" (symbol-package object))
- (cons "value" (if (boundp object)
+ (list (cons "NAME" (symbol-name object))
+ (cons "PACKAGE" (symbol-package object))
+ (cons "VALUE" (if (boundp object)
(symbol-value object)
*inspect-unbound-object-marker*))
- (cons "function" (if (fboundp object)
+ (cons "FUNCTION" (if (fboundp object)
(symbol-function object)
*inspect-unbound-object-marker*))
- (cons "plist" (symbol-plist object)))))
+ (cons "PLIST" (symbol-plist object)))))
(list components (length components) :named nil)))
(defun inspected-structure-parts (object)
(info (sb-kernel:layout-info (sb-kernel:layout-of object))))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
- (push (cons (sb-kernel:dsd-%name dd-slot)
+ (push (cons (string (sb-kernel:dsd-name dd-slot))
(funcall (sb-kernel:dsd-accessor-name dd-slot) object))
components-list)))))
(list components (length components) :named nil)))
(defun inspected-standard-object-parts (object)
- (let ((reversed-components nil)
+ (let ((components nil)
(class-slots (sb-pcl::class-slots (class-of object))))
- (dolist (class-slot class-slots (nreverse reversed-components))
+ (dolist (class-slot class-slots components)
(let* ((slot-name (slot-value class-slot 'sb-pcl::name))
(slot-value (if (slot-boundp object slot-name)
- (slot-value object slot-name)
- *inspect-unbound-object-marker*)))
- (push (cons slot-name slot-value) reversed-components)))))
+ (slot-value object slot-name)
+ *inspect-unbound-object-marker*)))
+ (push (cons (symbol-name slot-name) slot-value) components)))))
+
(defmethod inspected-parts ((object standard-object))
(let ((components (inspected-standard-object-parts object)))
(list components (length components) :named nil)))
(defmethod inspected-parts ((object sb-kernel:funcallable-instance))
- (let ((components (inspected-structure-parts object)))
+ (let ((components (inspected-standard-object-parts object)))
+ (list components (length components) :named nil)))
+
+(defmethod inspected-parts ((object condition))
+ (let ((components (inspected-standard-object-parts object)))
(list components (length components) :named nil)))
(defmethod inspected-parts ((object function))
(list components 2 :named nil)))
(defun inspected-parts-of-nontrivial-list (object)
- (multiple-value-bind (count proper-p) (dotted-safe-length object)
- (if proper-p
- (list object count :list nil)
- ;; count tail element
- (list object (1+ count) :improper-list nil))))
+ (multiple-value-bind (count list-type) (cons-safe-length object)
+ (case list-type
+ (:normal
+ (list object count :list nil))
+ (:cyclic
+ (list object (1+ count) :cyclic-list nil))
+ (:dotted
+ ;; count tail element
+ (list object (1+ count) :dotted-list nil)))))
(defmethod inspected-parts ((object complex))
(let ((components (list (cons "real" (realpart object))
(cons "denominator" (denominator object)))))
(list components (length components) :named nil)))
+(defmethod inspected-parts ((object bignum))
+ (list object (bignum-words object) :bignum nil))
+
(defmethod inspected-parts ((object t))
(list nil 0 nil nil))
(defmethod set-component-value ((object standard-object) id value element)
(format nil "Standard object does not support setting of component ~A" id))
-(defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
- (format nil "Funcallable instance object does not support setting of component ~A" id))
-
-(defmethod set-component-value ((object function) id value element)
- (format nil "Function object does not support setting of component ~A" id))
-
-;; whn believes it is unsafe to change components of this object
-(defmethod set-component-value ((object complex) id value element)
- (format nil "Object does not support setting of component ~A" id))
-
-;; whn believes it is unsafe to change components of this object
-(defmethod set-component-value ((object ratio) id value element)
- (format nil "Object does not support setting of component ~A" id))
-
(defmethod set-component-value ((object t) id value element)
(format nil "Object does not support setting of component ~A" id))
-
projects / sbcl.git / blobdiff