-;;;; Inspector for sb-aclrepl
+/nick;;;; 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:
(cl:in-package #:sb-aclrepl)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +default-inspect-length+ 10))
+ (defconstant +default-inspect-length+ 20))
(defstruct inspect
;; stack of parents of inspected object
"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
(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))
+(defun inspector-fun (object input-stream output-stream)
+ (declare (ignore input-stream))
+ (let ((*current-inspect* nil)
+ (*inspect-raw* nil)
+ (*inspect-length* *inspect-length*)
+ (*skip-address-display* nil))
(setq object (eval object))
(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)))
- (redisplay output-stream))
-
- (setq sb-impl::*inspect-fun* #'inspector)
-
- (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))
- ((or (symbolp option)
- (integerp option))
- (istep-cmd-select-component option stream))
- (t
- (istep-cmd-set-stack option stream))))
+ (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 set-current-inspect (inspect)
+ (setq *current-inspect* inspect))
- (defun reset-stack ()
- (setf (inspect-object-stack *current-inspect*) nil)
- (setf (inspect-select-stack *current-inspect*) nil))
+(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 output-inspect-note (stream note &rest args)
+ (apply #'format stream note args)
+ (princ #\Newline stream))
- (defun stack ()
- (inspect-object-stack *current-inspect*))
+(defun stack ()
+ (inspect-object-stack *current-inspect*))
- (defun redisplay (stream)
- (display-current stream))
+(defun redisplay (stream &optional (skip 0))
+ (display-current stream *inspect-length* skip))
- ;;;
- ;;; istep command processing
- ;;;
-
- (defun istep-cmd-redisplay (stream)
- (redisplay stream))
+;;;
+;;; istep command processing
+;;;
- (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)
+(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)
- (setf (inspect-object-stack *current-inspect*) (list *))
- (setf (inspect-select-stack *current-inspect*) (list "(inspect *)"))
- (set-break-inspect *current-inspect*)
- (redisplay stream))
-
- (defun istep-cmd-inspect-new-form (form stream)
- (inspector (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 (element-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)
- (set-break-inspect *current-inspect*))
-
- (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))
- (let ((*inspect-skip* len))
- (redisplay stream))
- (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
+ (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
- (element-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)
+ (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)
- (cond
- ((integerp position)
- (let* ((value (element-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)
- (output-inspect-note
- stream "Enter a valid index (~:[0-~W~;0~])"
- (= (parts-count parts) 1)
- (1- (parts-count parts))))))))
- (no-object-msg stream)))
-
- (defun istep-cmd-set-stack (form stream)
- (reset-stack)
- (let ((object (eval form)))
- (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*)
- (redisplay stream))
-
- ;;;
- ;;; aclrepl-specific inspection display
- ;;;
-
- (defun no-object-msg (s)
- (output-inspect-note s "No object is being inspected"))
-
- (defun display-current (s)
- (if (stack)
- (let ((inspected (car (stack))))
- (setq cl:* inspected)
- (display-inspect inspected s *inspect-length* *inspect-skip*))
- (no-object-msg)))
-
- ) ;; end binding for multithreading
+ (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 display-inspect (object stream &optional length skip)
+(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)
- (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)
+ (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 (stringp (cdr label)) (char= (char (cdr label) 0) #\[)))
+ (and (consp label)
+ (stringp (cdr label))
+ (char= (char (cdr label) 0) #\[)))
(defun named-or-array-label-p (label)
- (consp label))
+ (and (consp label)
+ (not (hex32-label-p label))))
(defun display-labeled-element (element label stream)
(cond
(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)))))
;;;
;;; FUNCTIONS TO CONSIDER FOR EXPORT
;;; FIND-PART-ID
-;;; ELEMENT-AT
+;;; COMPONENT-AT
;;; ID-AT
;;; INSPECTED-ELEMENTS
;;; INSPECTED-DESCRIPTION
Returns (VALUES POSITION PARTS).
POSITION is NIL if the id is invalid or not found."
(let* ((parts (inspected-parts object))
- (name (when (symbolp id) (symbol-name id) id)))
+ (name (if (symbolp id) (symbol-name id) id)))
(values
- (if (numberp id)
- (when (< -1 id (parts-count parts)) id)
- (case (parts-seq-type parts)
- (:named
- (position name (the list (parts-components parts))
- :key #'car :test #'string-equal))
- (:improper-list
- (when (string-equal name "tail")
- (1- (parts-count parts))))))
+ (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 element-at (parts position)
+(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))))))
(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))
"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 may be a string, number, cons pair, :tail, or :ellipses.
+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."
element-count))
(defun set-element (elements labels parts to-index from-index)
- (set-element-values elements labels to-index (element-at parts 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)
"Helper function for inspected-elements. Conses the
position with the label if the label is a string."
(let ((id (id-at parts position)))
- (if (stringp id)
- (cons position id)
- id)))
+ (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."
"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
+ (case list-type
+ ((:dotted :cyclic) "+tail")
+ (t "")))))
+
+
+(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:base-char-widetag
+ (ash (char-code object)
+ sb-vm:n-widetag-bits))))
(defmethod inspected-description ((object t))
(format nil "a generic object ~W" object))
;;; 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. 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
;;;
(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 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 t) id value element)
(format nil "Object does not support setting of component ~A" id))
-
projects / sbcl.git / blobdiff