0.8.7.46:

[sbcl.git] / contrib / sb-aclrepl / inspect.lisp

diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp
index 22a4131..b09fc59 100644 (file)
--- a/contrib/sb-aclrepl/inspect.lisp
+++ b/contrib/sb-aclrepl/inspect.lisp
@@ -57,23 +57,20 @@ The commands are:
   (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
 
 
-(defun inspector (object input-stream output-stream)
-  (declare (ignore input-stream))
+(defun inspector-fun (object input-stream output-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))
     (reset-stack object "(inspect ...)")
     (redisplay output-stream)
     (let ((*input* input-stream)
          (*output* output-stream))
-      (catch 'inspect-quit
-       (sb-impl::repl :inspect t)))
-    (values)))
+      (repl :inspect t)))
+  (values))
 
-(setq sb-impl::*inspect-fun* #'inspector)
+(setq sb-impl::*inspect-fun* #'inspector-fun)
 
 (defun istep (args stream)
   (unless *current-inspect*
@@ -161,11 +158,11 @@ The commands are:
      (no-object-msg stream))))
 
 (defun istep-cmd-inspect-* (stream)
-  (reset-stack * "(inspect *")
+  (reset-stack * "(inspect *)")
   (redisplay stream))
 
 (defun istep-cmd-inspect-new-form (form stream)
-  (inspector (eval form) nil stream))
+  (inspector-fun (eval form) nil stream))
 
 (defun istep-cmd-select-parent-component (option stream)
   (if (stack)
@@ -203,7 +200,7 @@ The commands are:
 
 (defun istep-cmd-reset ()
   (reset-stack)
-  (throw 'inspect-quit nil))
+  (throw 'repl-catcher (values :inspect nil)))
 
 (defun istep-cmd-help (stream)
   (format stream *inspect-help*))
@@ -454,7 +451,7 @@ POSITION is NIL if the id is invalid or not found."
   "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."
@@ -600,7 +597,7 @@ position with the label if the label is a string."
 cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
     (do ((length 1 (1+ length))
         (lst (cdr object) (cdr lst)))
-       ((or (not(consp lst))
+       ((or (not (consp lst))
             (eq object lst))
         (cond
           ((null lst)
@@ -616,10 +613,9 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
   (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
+           (ecase list-type
              ((:dotted :cyclic) "+tail")
-             (t "")))))
-
+             (:normal "")))))
 
 (defun ref32-hexstr (obj &optional (offset 0))
   (format nil "~8,'0X" (ref32 obj offset)))
@@ -652,7 +648,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
 (defmethod inspected-description ((object fixnum))
   (description-maybe-internals "fixnum ~W" (list object)
                               "[#x~8,'0X]"
-                              (sb-kernel:get-lisp-obj-address object)))
+                              (ash object (1- sb-vm:n-lowtag-bits))))
 
 (defmethod inspected-description ((object complex))
   (format nil "complex number ~W" object))
@@ -679,10 +675,14 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
   (format nil "ratio ~W" object))
 
 (defmethod inspected-description ((object character))
-  (description-maybe-internals "character ~W char-code #x~4,'0X"
+  ;; 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]"
-                              (sb-kernel:get-lisp-obj-address object)))
+                              (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))
@@ -757,7 +757,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
        (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)))))
 
@@ -781,7 +781,11 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
     (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))