X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Finspect.lisp;h=8611d9d487a88d508cd6e202c50377d6cc834c4c;hb=644a1ff36dd578321fd0592aa47748e8af741542;hp=476b9eba405725c2cd98378bb2e26a5fce32c29e;hpb=35e4dd42b8cd765f88e5946b6aa0e7859b278399;p=sbcl.git diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 476b9eb..8611d9d 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -1,4 +1,4 @@ -/nick;;;; Inspector for sb-aclrepl +;;;; 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: @@ -12,7 +12,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (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 @@ -58,12 +59,10 @@ The commands are: (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)) (reset-stack object "(inspect ...)") (redisplay output-stream) @@ -328,24 +327,29 @@ The commands are: (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)))) + (write-string " at #x" stream) + (format stream (n-word-bits-hex-format) + (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 (hex-label-p label)))) + +(defun hex-label-p (label &optional width) (and (consp label) - (not (hex32-label-p label)))) + (case width + (32 (eq (cdr label) :hex32)) + (64 (eq (cdr label) :hex64)) + (t (or (eq (cdr label) :hex32) + (eq (cdr label) :hex64)))))) (defun display-labeled-element (element label stream) (cond @@ -361,8 +365,10 @@ The commands are: (car label) (format nil "~A " (cdr label)) (inspected-description element))) - ((hex32-label-p label) + ((hex-label-p label 32) (format stream "~4,' D-> #x~8,'0X" (car label) element)) + ((hex-label-p label 64) + (format stream "~4,' D-> #x~16,'0X" (car label) element)) (t (format stream "~4,' D-> ~A" label (inspected-description element))))) @@ -522,7 +528,9 @@ position with the label if the label is a string." ((stringp id) (cons position id)) ((eq (parts-seq-type parts) :bignum) - (cons position :hex32)) + (cons position (case sb-vm::n-word-bits + (32 :hex32) + (64 :hex64)))) (t id)))) @@ -599,7 +607,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) @@ -615,10 +623,15 @@ 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 n-word-bits-hex-format () + (case sb-vm::n-word-bits + (64 "~16,'0X") + (32 "~8,'0X") + (t "~X"))) (defun ref32-hexstr (obj &optional (offset 0)) (format nil "~8,'0X" (ref32 obj offset))) @@ -638,20 +651,22 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" 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))) + (let ((start (round (* 2 sb-vm::n-word-bits) 8))) + (description-maybe-internals "double-float ~W" (list object) + "[#~A ~A]" + (ref32-hexstr object (+ start 4)) + (ref32-hexstr object start)))) (defmethod inspected-description ((object single-float)) (description-maybe-internals "single-float ~W" (list object) "[#x~A]" - (ref32-hexstr object 4))) + (ref32-hexstr object (round sb-vm::n-word-bits 8)))) (defmethod inspected-description ((object fixnum)) - (description-maybe-internals "fixnum ~W" (list object) - "[#x~8,'0X]" - (ash object (1- sb-vm:n-lowtag-bits)))) + (description-maybe-internals + "fixnum ~W" (list object) + (concatenate 'string "[#x" (n-word-bits-hex-format) "]") + (ash object (1- sb-vm:n-lowtag-bits)))) (defmethod inspected-description ((object complex)) (format nil "complex number ~W" object)) @@ -660,19 +675,24 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (format nil "a simple-string (~W) ~W" (length object) object)) (defun bignum-words (bignum) - "Return the number of 32-bit words in a bignum" + "Return the number of words in a bignum" (ash - (logand (ref32 bignum) - (lognot sb-vm:widetag-mask)) + (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)))) + "Return the word at offset" + (case sb-vm::n-word-bits + (32 + (ref32 bignum (* 4 (1+ offset)))) + (64 + (let ((start (* 8 (1+ offset)))) + (+ (ref32 bignum start) + (ash (ref32 bignum (+ 4 start)) 32)))))) (defmethod inspected-description ((object bignum)) - (format nil "bignum ~W with ~D 32-bit word~:*~P" object - (bignum-words object))) + (format nil "bignum ~W with ~D ~A-bit word~P" object + (bignum-words object) sb-vm::n-word-bits (bignum-words object))) (defmethod inspected-description ((object ratio)) (format nil "ratio ~W" object)) @@ -680,12 +700,12 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (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)))) + (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)) @@ -771,7 +791,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defun inspected-standard-object-parts (object) (let ((components nil) (class-slots (sb-pcl::class-slots (class-of object)))) - (dolist (class-slot class-slots components) + (dolist (class-slot class-slots (nreverse components)) (let* ((slot-name (slot-value class-slot 'sb-pcl::name)) (slot-value (if (slot-boundp object slot-name) (slot-value object slot-name) @@ -784,7 +804,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))