X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Finspect.lisp;h=80ea6d9f03f1411f19c4d6b1cdbff860b5cc01c6;hb=63817d29028c8551cda23f432a3328acd7fdd62f;hp=adc4d0b0b4febff9f943fe73f312a4567bc681f2;hpb=976505f5476932372cae826a7bc5f3c94a09fa98;p=sbcl.git

diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp
index adc4d0b..80ea6d9 100644
--- a/contrib/sb-aclrepl/inspect.lisp
+++ b/contrib/sb-aclrepl/inspect.lisp
@@ -7,27 +7,30 @@
 ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
 ;;;; variable.
 
-(cl:in-package :sb-aclrepl)
+(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+ 20))
 
-(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 (:constructor make-inspect)
+		     (:conc-name inspect-))
+  ;; stack of parents of inspected object
+  object-stack 
+  ;;  a stack of indices of parent object components
+  select-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 *skip-address-display* nil
+  "Skip displaying addresses of objects.")
 
 (defvar *inspect-help*
-":istep takes between 0 to 3 arguments.
+  ":istep takes between 0 to 3 arguments.
 The commands are:
 :i             redisplay current object
 :i =           redisplay current object
@@ -35,6 +38,7 @@ The commands are:
 :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
@@ -43,7 +47,6 @@ The commands are:
 :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
@@ -51,513 +54,797 @@ The commands are:
 
 ;;; 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-"))
-
-
-;; Setup binding for multithreading
-(let ((*inspect-stack* nil)
-      (*parent-select-stack* nil)
-      (*inspect-length* 10)
-      (*inspect-raw* nil)
-      (*inspected* nil))
-  
-(defun inspector (object input-stream output-stream)
-  (declare (ignore input-stream))
-  (setq object (eval object))
-  (reset-stack)
-  (setq *inspect-stack* (list object))
-  (setq *parent-select-stack* (list "(inspect ...)"))
-  (%inspect output-stream))
-
- 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-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))
+    (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))
 
-(defun istep (arg-string output-stream)
-  (%istep arg-string (string-to-list-skip-spaces arg-string) output-stream))
-
-(setq sb-impl::*inspect-fun* #'inspector)
-
-(defun reset-stack ()
-  (setq *inspect-stack* nil)
-  (setq *parent-select-stack* nil)
-  (makunbound '*inspected*))
+;;;
+;;; istep command processing
+;;;
 
-(defun %istep (arg-string args output-stream)
-  (let* ((option (car args))
-	 (option-read (when arg-string
-			(read-from-string arg-string))))
+(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
-      ;; Redisplay
-      ((or (string= "=" option)
-	   (zerop (length args)))
-       (%inspect output-stream))
-      ;; Select parent
-      ((or (string= "-" option)
-	   (string= "^" option))
-       (cond
-	 ((> (length *inspect-stack*) 1)
-	  (pop *inspect-stack*)
-	  (%inspect output-stream))
-	 (*inspect-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 ...)"))
-       (%inspect output-stream))
-      ;; Start new inspect level for eval'd form
-      ((string= "+" option)
-       (inspector (eval (second args)) nil output-stream))
-      ;; Next or previous parent component
-      ((or (string= "<" option)
-	   (string= ">" option))
-       (if *inspect-stack*
-	   (if (eq (length *inspect-stack*) 1)
-	       (format output-stream "Object does not have a parent")
-	       (let ((parent (second *inspect-stack*))
-		     (id (car *parent-select-stack*)))
-		 (multiple-value-bind (position list-type elements)
-		     (find-object-component parent id)
-		   (declare (list elements)
-			    (ignore list-type))
-		   (let ((new-position (if (string= ">" option)
-					   (1+ position)
-					   (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*)
-				 (if (integerp id)
-				     new-position
-				     (read-from-string
-				      (car (nth new-position elements)))))
-			   (%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 *inspect-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)
-	       (declare (ignore list-type))
-	       (if elements
-		   (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 *inspect-stack*)
+      ((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
-							 (nth position elements))))
-			       (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 *inspect-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))
-      ;; 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))
-	     (%inspect output-stream len)
-	     (format output-stream "Skip missing or invalid~%"))))
-      ;; Print stack tree
-      ((string-equal "tree" option)
-       (if *inspect-stack*
-	   (progn
-	     (format output-stream "The current object is:~%")
-	     (dotimes (i (length *inspect-stack*))
-	       (format output-stream "~A, ~A~%"
-		       (inspected-parts (nth i *inspect-stack*) :description t)
-		       (let ((select (nth i *parent-select-stack*)))
-			 (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 *inspect-stack*
-	   (multiple-value-bind (position list-type elements)
-	       (find-object-component (car *inspect-stack*) option-read)
-	     (cond
-	       ((integerp position)
-		(let* ((element (elt elements position))
-		       (value (if (eq list-type :named) (cdr element) element)))
-		  (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*)
-			 (%inspect output-stream)))))
-	       ((null elements)
-		(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
-			   (= (length elements) 1)
-			   (1- (length elements))))))))
-	   (%inspect output-stream)))
-      ;; Default is to select eval'd form
-      (t
-       (reset-stack)
-       (setq *inspect-stack* (list (eval option-read)))
-       (setq *parent-select-stack* (list ":i <form>"))
-       (%inspect output-stream))
-      )))
+							 (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 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)))
 
-(defun find-object-component (object id)
+
+;;;
+;;; 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 print length and skip selectors
+;;;
+;;; FUNCTIONS TO CONSIDER FOR EXPORT
+;;;   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-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.
+
+(defun find-part-id (object id)
   "COMPONENT-ID can be an integer or a name of a id.
-Returns POSITION LIST-TYPE ELEMENTS
+Returns (VALUES POSITION PARTS).
 POSITION is NIL if the id is invalid or not found."
-  (if object
-      (multiple-value-bind (description list-type elements)
-	  (inspected-parts object)
-	(declare (ignore description)
-		 (list elements))
-	(when (symbolp id)
-	  (setq id (symbol-name id)))
-	(let ((position
-	       (cond ((and (eq list-type :named)
-			   (stringp id))
-		      (position id elements :key #'car :test #'string-equal))
-		     ((numberp id)
-		      (when (< -1 id (length elements))
-			id)))))
-	  (values position list-type elements)))
-      (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)))
-      (format s "No object is being inspected")))
-
-
-(defun display-inspected-parts (object description list-type elements stream &optional (skip 0))
-  (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)))))
+  (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)
+	(: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 id-at (parts position)
+  (let ((count (parts-count parts)))
+    (when (< -1 position count)
+      (case (parts-seq-type parts)
+	((:dotted-list :cyclic-list)
+	 (if (= position (1- count))
+	     :tail
+	     position))
+	(:array
+	 (array-index-string position parts))
+	(:named
+	 (car (elt (parts-components parts) position)))
 	(t
-	 (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))))
+	 position)))))
+
+(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)
+	"[]"
+	(let ((list nil))
+	  (dolist (dim rev-dimensions)
+	    (multiple-value-bind (q r) (floor index dim)
+	      (setq index q)
+	      (push r list)))
+	  (format nil "[~W~{,~W~}]" (car list) (cdr list))))))
+
+
+;;; INSPECTED-DESCRIPTION
+;;;
+;;; Accepts an object and returns
+;;;   DESCRIPTION is a summary description of the destructured object,
+;;;   e.g. "the object is a CONS".
+
+(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)))
 
-) ;; end binding for multithreading
+(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: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..")
 
 
 ;;; INSPECTED-PARTS
 ;;;
-;;; Destructure an object for inspection, returning either
-;;;   DESCRIPTION
-;;; if description keyword is T, otherwise returns
-;;;   (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
+;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
+;;;   (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
 ;;; where..
 ;;;
-;;;   DESCRIPTION is a summary description of the destructured object,
-;;;   e.g. "the object is a CONS.~%".
+;;;   COMPONENTS are the component parts of OBJECT (whose
+;;;   representation is determined by SEQ-TYPE). Except for the
+;;;   SEQ-TYPE :named and :array, components is just the OBJECT itself
 ;;;
-;;;   LIST-TYPE determines what representation is used for elements
-;;;   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"
-;;;      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.
+;;;   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 :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 
 ;;;
-;;;   ELEMENTS is a list of the component parts of OBJECT (whose
-;;;   representation is determined by LIST-TYPE).
+;;;   COUNT is the total number of components in the OBJECT
 ;;;
-;;; (LIST-TYPE is useful because symbols and instances
-;;; need to display both a slot name and a value, while lists and
-;;; vectors need only display a value.)
-
-(defgeneric inspected-parts (object &key description))
-
-(defmethod inspected-parts ((object symbol) &key description)
-  (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
-    (if description
-	desc
-	(values desc :named
-		(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)
-					   (symbol-function object)
-					   *inspect-unbound-object-marker*))
-		      (cons "plist" (symbol-plist object)))))))
-    
-(defun inspected-structure-elements (object)
-  (let ((parts-list '())
-        (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
+;;; 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))
+(defun parts-components (parts)
+  (first parts))
+
+(declaim (inline parts-count))
+(defun parts-count (parts)
+  (second parts))
+
+(declaim (inline parts-seq-type))
+(defun parts-seq-type (parts)
+  (third parts))
+
+(declaim (inline parts-seq-hint))
+(defun parts-seq-hint (parts)
+  (fourth parts))
+
+(defgeneric inspected-parts (object)
+  )
+
+(defmethod inspected-parts ((object symbol))
+  (let ((components
+	 (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)
+				    (symbol-function object)
+				    *inspect-unbound-object-marker*))
+	       (cons "PLIST" (symbol-plist object)))))
+    (list components (length components) :named nil)))
+
+(defun inspected-structure-parts (object)
+  (let ((components-list '())
+	(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 parts-list))
-        (push (cons (sb-kernel:dsd-%name dd-slot)
-                    (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
-              parts-list)))))
-
-(defmethod inspected-parts ((object structure-object) &key description)
-  (let ((desc (format nil "~W" (find-class (type-of object)))))
-    (if description
-	desc
-	(values desc :named (inspected-structure-elements object)))))
-
-(defmethod inspected-parts ((object package) &key description)
-  (let ((desc (format nil "the ~A package" (package-name object))))
-    (if description
-	desc
-	(values desc :named (inspected-structure-elements object)))))
-
-(defun inspected-standard-object-elements (object)
-  (let ((reversed-elements nil)
+      (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
+	(push (cons (string (sb-kernel:dsd-name dd-slot))
+		    (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
+	      components-list)))))
+
+(defmethod inspected-parts ((object structure-object))
+  (let ((components (inspected-structure-parts object)))
+    (list components (length components) :named nil)))
+
+(defun inspected-standard-object-parts (object)
+  (let ((components nil)
 	(class-slots (sb-pcl::class-slots (class-of object))))
-    (dolist (class-slot class-slots (nreverse reversed-elements))
+    (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-elements)))))
-
-(defmethod inspected-parts ((object standard-object) &key description)
-  (let ((desc (format nil "~W" (class-of object))))
-    (if description
-	desc
-	(values desc :named
-		(inspected-standard-object-elements object)))))
-
-(defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
-  (let ((desc (format nil "a funcallable-instance of type ~S"
-		      (type-of object))))
-    (if description
-	desc
-	(values desc :named
-		(inspected-structure-elements object)))))
-
-(defmethod inspected-parts ((object function) &key description)
+	(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-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))
   (let* ((type (sb-kernel:widetag-of object))
 	 (object (if (= type sb-vm:closure-header-widetag)
 		     (sb-kernel:%closure-fun object)
 		     object))
-	 (desc (format nil "~S" object)))
-    (if description
-	desc
-	(values desc :named
-		(list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
-
-(defmethod inspected-parts ((object vector) &key description)
-  (let ((desc  (format nil
-		  "a ~:[~;displaced ~]vector (~W)"
-		  (and (sb-kernel:array-header-p object)
-		       (sb-kernel:%array-displaced-p object))
-		  (length object)
-		  (sb-kernel:get-lisp-obj-address object))))
-    (if description
-	desc
-	(values desc nil object))))
-
-(defun inspected-index-string (index rev-dimensions)
-  (if (null rev-dimensions)
-      "[]"
-      (let ((list nil))
-	(dolist (dim rev-dimensions)
-	  (multiple-value-bind (q r) (floor index dim)
-	    (setq index q)
- 	    (push r list)))
-	(format nil "[~W~{,~W~}]" (car list) (cdr list)))))
-
-(defmethod inspected-parts ((object simple-vector) &key description)
-  (let ((desc (format nil "a simple ~A vector (~D)"
-		      (array-element-type object)
-		      (length object))))
-    (if description
-	desc
-	(values desc nil object))))
-
-(defmethod inspected-parts ((object array) &key description)
-  (declare (array object))
-  (let* ((length (array-total-size object))
-	 (reference-array (make-array length :displaced-to object))
-	 (dimensions (array-dimensions object))
-	 (reversed-elements nil)
-	 (desc (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)
-		       dimensions)))
-    (if description
-	desc
-	(progn
-	  (dotimes (i length)
-	    (push (cons (format nil "~A "
-				(inspected-index-string i (reverse dimensions)))
-			(aref reference-array i))
-		  reversed-elements))
-	  (values desc :named (nreverse reversed-elements))))))
-
-(defmethod inspected-parts ((object cons) &key description)
-  (if (or (consp (cdr object)) (null (cdr object)))
-      (inspected-parts-of-nontrivial-list object description)
-      (inspected-parts-of-simple-cons object description)))
-
-(defun inspected-parts-of-simple-cons (object description)
-  (let ((desc (format nil "a cons pair")))
-    (if description
-	desc
-	(values desc :named
-		(list (cons "car" (car object))
-		      (cons "cdr" (cdr object)))))))
-
-(defun inspected-parts-of-nontrivial-list (object description)
-  (let ((length 0)
-	(in-list object)
-	(reversed-elements nil))
-    (flet ((done (description-format list-type)
-	     (let ((desc (format nil description-format length length)))
-	       (return-from inspected-parts-of-nontrivial-list
-		 (if description
-		     desc
-		     (values desc list-type (nreverse reversed-elements)))))))
-      (loop
-       (cond ((null in-list)
-	      (done "a proper list with ~D element~P" nil))
-	     ((consp in-list)
-	      (push (pop in-list) reversed-elements)
-	      (incf length))
-	     (t
-	      (push in-list reversed-elements)
-	      (done "a improper list with ~D element~P" :index-with-tail)))))))
-
-(defmethod inspected-parts ((object simple-string) &key description)
-  (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
-    (if description
-	desc
-	(values desc nil object))))
-
-(defmethod inspected-parts ((object double-float) &key description)
-  (let ((desc (format nil "double-float ~W" object)))
-    (if description
-	desc
-	(values desc nil nil))))
-
-(defmethod inspected-parts ((object single-float) &key description)
-  (let ((desc (format nil "single-float ~W" object)))
-    (if description
-	desc
-	(values desc nil nil))))
-
-(defmethod inspected-parts ((object fixnum) &key description)
-  (let ((desc (format nil "fixnum ~W" object)))
-    (if description
-	desc
-	(values desc nil nil))))
-
-(defmethod inspected-parts ((object complex) &key description)
-  (let ((desc (format nil "complex number ~W" object)))
-    (if description
-	desc
-	(values desc :named
-		(list (cons "real" (realpart object))
-		      (cons "imag" (imagpart object)))))))
-
-(defmethod inspected-parts ((object bignum) &key description)
-  (let ((desc (format nil "bignum ~W" object)))
-    (if description
-	desc
-	(values desc nil nil))))
-
-(defmethod inspected-parts ((object ratio) &key description)
-  (let ((desc (format nil "ratio ~W" object)))
-    (if description
-	desc
-	(values desc :named
-		(list (cons "numerator" (numerator object))
-		      (cons "denominator" (denominator object)))))))
-
-(defmethod inspected-parts ((object character) &key description)
-  (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
-    (if description
-	desc
-	(values desc nil nil))))
-
-(defmethod inspected-parts ((object t) &key description)
-  (let ((desc (format nil "a generic object ~W" object)))
-    (if description
-	desc
-	(values desc nil nil))))
+	 (components (list (cons "arglist"
+			       (sb-kernel:%simple-fun-arglist object)))))
+    (list components (length components) :named nil)))
+
+(defmethod inspected-parts ((object vector))
+  (list object (length object) :vector nil))
+
+(defmethod inspected-parts ((object array))
+  (let ((size (array-total-size object)))
+    (list (make-array size :displaced-to object)
+	    size
+	    :array
+	    (reverse (array-dimensions object)))))
+
+(defmethod inspected-parts ((object cons))
+  (if (simple-cons-pair-p object)
+      (inspected-parts-of-simple-cons object)
+      (inspected-parts-of-nontrivial-list object)))
+
+(defun inspected-parts-of-simple-cons (object)
+  (let ((components (list (cons "car" (car object))
+			(cons "cdr" (cdr object)))))
+    (list components 2 :named nil)))
+
+(defun inspected-parts-of-nontrivial-list (object)
+    (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 "imag" (imagpart object)))))
+    (list components (length components) :named nil)))
+
+(defmethod inspected-parts ((object ratio))
+  (let ((components (list (cons "numerator" (numerator 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))
+
 
 ;; FIXME - implement setting of component values
 
@@ -578,20 +865,5 @@ POSITION is NIL if the id is invalid or not found."
 (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))
-