X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Finspect.lisp;h=8ded127506ace37969fa4b3dd524ea001a27306a;hb=dd0e7aad8215b548fdb1e402affdc0caad95b621;hp=cef37b10c0f4baf267aa37ce09b8a8dddc6ea1ac;hpb=0b50ec4bd716d2bf3aecb0931c4ced8255c3d542;p=sbcl.git diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index cef37b1..8ded127 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -7,26 +7,27 @@ ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP* ;;;; variable. -(cl:in-package :sb-aclrepl) +(cl:in-package #:sb-aclrepl) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-inspect-length+ 10)) + (defconstant +default-inspect-length+ 20)) -(defstruct inspect +(defstruct (%inspect (:constructor make-inspect) + (:conc-name inspect-)) ;; stack of parents of inspected object - object-stack + 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") + "current inspect") (defparameter *inspect-raw* nil "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") + "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. @@ -37,6 +38,7 @@ The commands are: :i ? display this help :i * inspect the current * value :i +
inspect the (eval form) +:i slot inspect component of object, even if name is an istep cmd :i inspect the numbered component of object :i inspect the named component of object :i evaluation and inspect form @@ -45,7 +47,6 @@ The commands are: :i < inspect previous parent component :i > inspect next parent component :i set set indexed component to evalated form -i set set named component to evalated form :i print set the maximum number of components to print :i skip skip a number of components when printing :i tree print inspect stack @@ -53,409 +54,498 @@ i set set named component to evalated form ;;; 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 ((*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)) - (setq object (eval object)) +(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)) - (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))) - (%inspect output-stream)) - - - (defun set-current-inspect (inspect) - (setq *current-inspect* inspect)) - - (defun istep (arg-string output-stream) - (%istep arg-string output-stream)) - - (setq sb-impl::*inspect-fun* #'inspector) - - (defun reset-stack () - (setf (inspect-object-stack *current-inspect*) nil) - (setf (inspect-select-stack *current-inspect*) nil)) - - (defun %istep (arg-string output-stream) - (unless *current-inspect* - (setq *current-inspect* (make-inspect))) - (let* ((args (when arg-string (string-to-list-skip-spaces arg-string))) - (option (car args)) - (option-read (when arg-string - (read-from-string arg-string))) - (stack (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 stack) 1) - (setf (inspect-object-stack *current-inspect*) (cdr stack)) - (setf (inspect-select-stack *current-inspect*) - (cdr (inspect-select-stack *current-inspect*))) - (%inspect output-stream)) - (stack - (format output-stream "Object has no parent.~%")) - (t - (%inspect output-stream)))) - ;; Select * to inspect - ((string= "*" option) - (reset-stack) - (setf (inspect-object-stack *current-inspect*) (list *)) - (setf (inspect-select-stack *current-inspect*) (list "(inspect *)")) - (set-break-inspect *current-inspect*) - (%inspect output-stream)) - ;; Start new inspect level for eval'd form - ((string= "+" option) - (inspector (eval (read-from-string (second args))) nil output-stream)) - ;; Next or previous parent component - ((or (string= "<" option) - (string= ">" option)) - (if stack - (if (eq (length stack) 1) - (format output-stream "Object does not have a parent") - (let ((parent (second stack)) - (id (car (inspect-select-stack *current-inspect*)))) - (multiple-value-bind (position parts) - (find-object-part-with-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 stack) value) - (setf (car (inspect-select-stack *current-inspect*)) - (if (integerp id) - new-position - (let ((label (label-at parts new-position))) - (if (stringp label) - (read-from-string label) - label)))) - (%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 stack - (let ((id (when (second args) - (read-from-string (second args))))) - (multiple-value-bind (position parts) - (find-object-part-with-id (car stack) id) - (if parts - (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 stack) - id - new-value - (element-at parts position)))) - (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 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) - (set-break-inspect *current-inspect*)) - ;; 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)) - (let ((*inspect-skip* len)) - (%inspect output-stream)) - (format output-stream "Skip missing or invalid~%")))) - ;; Print stack tree - ((string-equal "tree" option) - (if stack - (progn - (format output-stream "The current object is:~%") - (dotimes (i (length stack)) - (format output-stream "~A, ~A~%" - (inspected-description (nth i stack)) - (let ((select (nth i (inspect-select-stack *current-inspect*)))) - (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 stack - (multiple-value-bind (position parts) - (find-object-part-with-id (car stack) option-read) - (cond - ((integerp position) - (let* ((value (element-at parts position))) - (cond ((eq value *inspect-unbound-object-marker*) - (format output-stream "That slot is unbound~%")) - (t - (push value (inspect-object-stack *current-inspect*)) - (push option-read (inspect-select-stack *current-inspect*)) - (%inspect output-stream))))) - ((null parts) - (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 - (= (parts-count parts) 1) - (1- (parts-count parts)))))))) - (%inspect output-stream))) - ;; Default is to select eval'd form - (t - (reset-stack) - (let ((object (eval option-read))) - (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*) - (%inspect output-stream)) - ))) - - (defun %inspect (s) - (if (inspect-object-stack *current-inspect*) - (let ((inspected (car (inspect-object-stack *current-inspect*)))) - (setq cl:* inspected) - (display-inspected-parts inspected s)) - (format s "No object is being inspected"))) - - - (defun display-inspected-parts (object stream) - (multiple-value-bind (elements labels count) - (inspected-elements object *inspect-length* *inspect-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) - (dotimes (i count) - (let ((label (elt labels i)) - (element (elt elements i))) - (cond - ((eq label :ellipses) - (format stream "~& ...~%")) - ((eq label :tail) - (format stream "tail-> ~A~%" (inspected-description element))) - ((consp label) - (format stream - (if (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[)) - ;; for arrays - "~4,' D ~A-> ~A~%" - ;; for named - "~4,' D ~16,1,1,'-A> ~A~%") - (car label) - (format nil "~A " (cdr label)) - (if (eq element *inspect-unbound-object-marker*) - "..unbound.." - (inspected-description element)))) - (t - (if (integerp label) - (format stream "~4,' D-> ~A~%" label (inspected-description element)) - (format stream "~4A-> ~A~%" label (inspected-description element))))))))) - - ) ;; end binding for multithreading + (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)) + +;;; +;;; istep command processing +;;; + +(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 + ((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 + (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))) + + +;;; +;;; 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*) + (and (= sb-vm::n-word-bits 64) (typep object 'single-float)) + (characterp object) (typep object 'fixnum)) + (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 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) + (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 + ((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))) + ((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))))) ;;; THE BEGINNINGS OF AN INSPECTOR API ;;; which can be used to retrieve object descriptions as component values/labels and also -;;; process component length and skip selectors +;;; process print length and skip selectors ;;; ;;; FUNCTIONS TO CONSIDER FOR EXPORT -;;; FIND-OBJECT-PART-WITH-ID -;;; ELEMENT-AT -;;; LABEL-AT +;;; 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-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. +;;; 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-object-part-with-id (object id) +(defun find-part-id (object id) "COMPONENT-ID can be an integer or a name of a id. Returns (VALUES POSITION PARTS). POSITION is NIL if the id is invalid or not found." - (if object - (let* ((parts (inspected-parts object)) - (seq-type (parts-seq-type parts)) - (count (parts-count parts)) - (components (parts-components parts))) - (when (symbolp id) - (setq id (symbol-name id))) - (let ((position - (cond ((and (eq seq-type :named) - (stringp id)) - (position id (the list components) :key #'car - :test #'string-equal)) - ((and (eq seq-type :improper-list) - (stringp id) - (string-equal id "tail")) - (1- count)) - ((numberp id) - (when (< -1 id count) - id))))) - (values position parts))) - (values nil nil))) - - -(defun element-at (parts position) + (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))) + (components (parts-components parts))) (when (< -1 position count) (case (parts-seq-type parts) - (:improper-list - (if (= position (1- count)) - (cdr (last components)) - (elt components position))) - (:named - (cdr (elt components position))) - (:array - (aref (the array components) position)) - (t - (elt components position)))))) - -(defun label-at (parts position) + (: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) - (:improper-list - (if (= position (1- count)) - :tail - position)) - (:array - (array-index-string position parts)) - (:named - (car (elt (parts-components parts) position))) - (t - position))))) - -(defun label-at-maybe-with-index (parts position) + ((:dotted-list :cyclic-list) + (if (= position (1- count)) + :tail + position)) + (:array + (array-index-string position parts)) + (:named + (car (elt (parts-components parts) position))) + (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 is the label is a string." - (let ((label (label-at parts position))) - (if (stringp label) - (cons position label) - label))) +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 (case sb-vm::n-word-bits + (32 :hex32) + (64 :hex64)))) + (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)))))) - -(defun inspected-elements (object length skip) - "Returns elements of an object that have been trimmed and labeled based on -length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains -COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number, -:tail, or :ellipses. This function may return a 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)) - (count (parts-count parts))) - (unless skip (setq skip 0)) - (unless length (setq length count)) - (let* ((last (1- count)) - (last-req (min last (+ skip length -1))) ;; last requested element - (total (min (- count skip) length))) - (when (and (plusp total) (plusp skip)) ; starting ellipses - (incf total)) - (when (< last-req last) ; last value - (incf total) - (when (< last-req (1- last)) ; ending ellipses - (incf total))) - (let ((index 0) - (elements nil) - (labels nil)) - (declare (type (or simple-vector null) elements labels)) - (when (plusp total) - (setq elements (make-array total :adjustable nil :fill-pointer nil :initial-element nil)) - (setq labels (make-array total :adjustable nil :fill-pointer nil)) - (when (plusp skip) - (setf (aref labels 0) :ellipses) - (incf index)) - (do ((i 0 (1+ i))) - ((> i (- last-req skip))) - (setf (aref elements (+ i index)) (element-at parts (+ i skip))) - (setf (aref labels (+ i index)) (label-at-maybe-with-index parts - (+ i skip)))) - - (when (< last-req last) ; last value - (setf (aref elements (- total 1)) (element-at parts last)) - (setf (aref labels (- total 1)) (label-at-maybe-with-index parts - last)) - (when (< last-req (1- last)) ; ending ellipses or 2nd to last value - (if (= last-req (- last 2)) - (progn - (setf (aref elements (- total 2)) (element-at parts (1- last))) - (setf (aref labels (- total 2)) (label-at-maybe-with-index - parts (1- last)))) - (setf (aref labels (- total 2)) :ellipses))))) - (values elements labels total))))) - + "[]" + (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 @@ -478,32 +568,29 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (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))) + (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))) + (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))) + (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))) @@ -513,31 +600,78 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen "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 + (ecase list-type + ((:dotted :cyclic) "+tail") + (: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))) + +(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)) + (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)) - (format nil "single-float ~W" object)) + (ecase sb-vm::n-word-bits + (32 + (description-maybe-internals "single-float ~W" (list object) + "[#x~A]" + (ref32-hexstr object (round sb-vm::n-word-bits 8)))) + (64 + ;; on 64-bit platform, single-floats are not boxed + (description-maybe-internals "single-float ~W" (list object) + "[#x~8,'0X]" + (sb-kernel:get-lisp-obj-address object))))) (defmethod inspected-description ((object fixnum)) - (format nil "fixnum ~W" object)) + (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)) @@ -545,18 +679,45 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defmethod inspected-description ((object simple-string)) (format nil "a simple-string (~W) ~W" (length object) object)) +(defun bignum-words (bignum) + "Return the number of 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 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" 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)) (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: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 ;;; @@ -571,17 +732,20 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen ;;; 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 +;;; 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 ;;; -;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array +;;; 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)) @@ -600,60 +764,65 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defun parts-seq-hint (parts) (fourth parts)) -(defgeneric inspected-parts (object) - ) +;;; FIXME: Most of this should be refactored to share the code +;;; with the vanilla inspector. Also, we should check what the +;;; Slime inspector does, and provide a an interface for it to +;;; use that would propagate any SBCL inspector improvements +;;; automagically to Slime. -- ns 2005-02-20 +(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 (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)))) + (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) - (funcall (sb-kernel:dsd-accessor-name dd-slot) object)) - 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 ((reversed-components nil) - (class-slots (sb-pcl::class-slots (class-of object)))) - (dolist (class-slot class-slots (nreverse reversed-components)) + (let ((components nil) + (class-slots (sb-pcl::class-slots (class-of object)))) + (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) - *inspect-unbound-object-marker*))) - (push (cons slot-name slot-value) reversed-components))))) + (slot-value (if (slot-boundp object slot-name) + (slot-value object slot-name) + *inspect-unbound-object-marker*))) + (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-structure-parts object))) +(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)) - (components (list (cons "arglist" - (sb-kernel:%simple-fun-arglist object))))) + (object (if (= type sb-vm:closure-header-widetag) + (sb-kernel:%closure-fun object) + object)) + (components (list (cons "arglist" + (sb-kernel:%simple-fun-arglist object))))) (list components (length components) :named nil))) (defmethod inspected-parts ((object vector)) @@ -661,10 +830,12 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defmethod inspected-parts ((object array)) (let ((size (array-total-size object))) - (list (make-array size :displaced-to object) - size - :array - (reverse (array-dimensions object))))) + (list (make-array size + :element-type (array-element-type object) + :displaced-to object) + size + :array + (reverse (array-dimensions object))))) (defmethod inspected-parts ((object cons)) (if (simple-cons-pair-p object) @@ -673,26 +844,33 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defun inspected-parts-of-simple-cons (object) (let ((components (list (cons "car" (car object)) - (cons "cdr" (cdr object))))) + (cons "cdr" (cdr object))))) (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 "imag" (imagpart 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))))) + (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)) @@ -716,20 +894,5 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (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)) -