+(defgeneric inspected-description (object))
+
+(defmethod inspected-description ((object symbol))
+ (format nil "the symbol ~A" object))
+
+(defmethod inspected-description ((object structure-object))
+ (format nil "~W" (find-class (type-of object))))
+
+(defmethod inspected-description ((object package))
+ (format nil "the ~A package" (package-name object)))
+
+(defmethod inspected-description ((object standard-object))
+ (format nil "~W" (class-of object)))
+
+(defmethod inspected-description ((object sb-kernel:funcallable-instance))
+ (format nil "a funcallable-instance of type ~S" (type-of object)))
+
+(defmethod inspected-description ((object function))
+ (format nil "~S" object) nil)
+
+(defmethod inspected-description ((object vector))
+ (declare (vector object))
+ (format nil "a ~:[~;displaced ~]vector (~W)"
+ (and (sb-kernel:array-header-p object)
+ (sb-kernel:%array-displaced-p object))
+ (length object)))
+
+(defmethod inspected-description ((object simple-vector))
+ (declare (simple-vector object))
+ (format nil "a simple ~A vector (~D)"
+ (array-element-type object)
+ (length object)))
+
+(defmethod inspected-description ((object array))
+ (declare (array object))
+ (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
+ (and (sb-kernel:array-header-p object)
+ (sb-kernel:%array-displaced-p object))
+ (array-element-type object)
+ (array-dimensions object)))
+
+(defun simple-cons-pair-p (object)
+ (atom (cdr object)))
+
+(defmethod inspected-description ((object cons))
+ (if (simple-cons-pair-p object)
+ "a cons cell"
+ (inspected-description-of-nontrivial-list object)))
+
+(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 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))
+ (description-maybe-internals "double-float ~W" (list object)
+ "[#~A ~A]"
+ (ref32-hexstr object 12)
+ (ref32-hexstr object 8)))
+
+(defmethod inspected-description ((object single-float))
+ (description-maybe-internals "single-float ~W" (list object)
+ "[#x~A]"
+ (ref32-hexstr object 4)))
+
+(defmethod inspected-description ((object fixnum))
+ (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 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))
+ ;; 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))
+
+(defmethod inspected-description ((object (eql *inspect-unbound-object-marker*)))
+ "..unbound..")