X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Finspect.lisp;h=852e1b35383ea343f7b9977d708cee2e8169a114;hb=1de341cf0652fb0eb8354f64d95acb0899811173;hp=200202a14d31b9545e406f63dc422fb57f3866dd;hpb=83c1b8bca82fc165b01332ef9e5c031c64d758d8;p=sbcl.git diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 200202a..852e1b3 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -9,22 +9,24 @@ (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+ 10)) -(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 + ;; stack of parents of inspected object + object-stack + ;; a stack of indices of parent object components + parent-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 *inspect-skip* 0 + "number of initial components to skip when displaying an object") (defvar *inspect-help* ":istep takes between 0 to 3 arguments. @@ -55,36 +57,43 @@ The commands are: ;; Setup binding for multithreading -(let ((*inspect-stack* nil) - (*parent-select-stack* nil) - (*inspect-length* 10) +(let ((*current-inspect* nil) (*inspect-raw* nil) - (*inspected* nil)) + (*inspect-length* +default-inspect-length+) + (*inspect-skip* 0)) (defun inspector (object input-stream output-stream) (declare (ignore input-stream)) (setq object (eval object)) + (setq *current-inspect* (make-inspect)) + (new-break :inspect *current-inspect*) (reset-stack) - (setq *inspect-stack* (list object)) - (setq *parent-select-stack* (list "(inspect ...)")) + (setf (inspect-object-stack *current-inspect*) (list object)) + (setf (inspect-parent-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 (string-to-list-skip-spaces arg-string) output-stream)) + (%istep arg-string output-stream)) (setq sb-impl::*inspect-fun* #'inspector) (defun reset-stack () - (setq *inspect-stack* nil) - (setq *parent-select-stack* nil) - (makunbound '*inspected*)) - -(defun %istep (arg-string args output-stream) - (let* ((option (car args)) + (setf (inspect-object-stack *current-inspect*) nil) + (setf (inspect-parent-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)))) + (read-from-string arg-string))) + (stack (inspect-object-stack *current-inspect*))) (cond ;; Redisplay ((or (string= "=" option) @@ -94,30 +103,31 @@ The commands are: ((or (string= "-" option) (string= "^" option)) (cond - ((> (length *inspect-stack*) 1) - (pop *inspect-stack*) + ((> (length stack) 1) + (pop stack) (%inspect output-stream)) - (*inspect-stack* - (format output-stream "Object has no parent.~%")) + (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 ...)")) + (setf (inspect-object-stack *current-inspect*) (list *)) + (setf (inspect-parent-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 (second args)) nil output-stream)) + (inspector (eval (read-from-string (second args))) nil output-stream)) ;; Next or previous parent component ((or (string= "<" option) (string= ">" option)) - (if *inspect-stack* - (if (eq (length *inspect-stack*) 1) + (if stack + (if (eq (length stack) 1) (format output-stream "Object does not have a parent") - (let ((parent (second *inspect-stack*)) - (id (car *parent-select-stack*))) + (let ((parent (second stack)) + (id (car (inspect-parent-stack *current-inspect*)))) (multiple-value-bind (position list-type elements) (find-object-component parent id) (declare (list elements) @@ -127,8 +137,8 @@ The commands are: (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*) + (setf (car stack) new-object) + (setf (car (inspect-parent-stack *current-inspect*)) (if (integerp id) new-position (read-from-string @@ -139,21 +149,27 @@ The commands are: (%inspect output-stream))) ;; Set component to eval'd form ((string-equal "set" option) - (if *inspect-stack* + (if 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) + (find-object-component (car 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))))) - ;; FIXME -- this will require new new generic - ;; function to set component of the object - (format output-stream "Set component - not yet implemented"))) - (%inspect output-stream)) + (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 @@ -161,7 +177,7 @@ The commands are: (%inspect output-stream))) ;; Set/reset raw display mode for components ((string-equal "raw" option) - (when *inspect-stack* + (when stack (when (and (second args) (or (null (second args)) (eq (read-from-string (second args)) t))) @@ -169,7 +185,8 @@ The commands are: (%inspect output-stream))) ;; Reset stack ((string-equal "q" option) - (reset-stack)) + (reset-stack) + (set-break-inspect *current-inspect*)) ;; Display help ((string-equal "?" option) (format output-stream *inspect-help*)) @@ -177,17 +194,18 @@ The commands are: ((string-equal "skip" option) (let ((len (read-from-string (second args)))) (if (and (integerp len) (>= len 0)) - (%inspect output-stream len) + (let ((*inspect-skip* len)) + (%inspect output-stream)) (format output-stream "Skip missing or invalid~%")))) ;; Print stack tree ((string-equal "tree" option) - (if *inspect-stack* + (if stack (progn (format output-stream "The current object is:~%") - (dotimes (i (length *inspect-stack*)) + (dotimes (i (length stack)) (format output-stream "~A, ~A~%" - (inspected-parts (nth i *inspect-stack*) :description t) - (let ((select (nth i *parent-select-stack*))) + (inspected-parts (nth i stack) :description t) + (let ((select (nth i (inspect-parent-stack *current-inspect*)))) (typecase select (integer (format nil "which is componenent number ~d of" select)) @@ -207,9 +225,9 @@ The commands are: ;; Select numbered or named component ((or (symbolp option-read) (integerp option-read)) - (if *inspect-stack* + (if stack (multiple-value-bind (position list-type elements) - (find-object-component (car *inspect-stack*) option-read) + (find-object-component (car stack) option-read) (cond ((integerp position) (let* ((element (elt elements position)) @@ -217,8 +235,8 @@ The commands are: (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*) + (push value (inspect-object-stack *current-inspect*)) + (push option-read (inspect-parent-stack *current-inspect*)) (%inspect output-stream))))) ((null elements) (format output-stream "Object does not contain any subobjects~%")) @@ -238,8 +256,11 @@ The commands are: ;; Default is to select eval'd form (t (reset-stack) - (setq *inspect-stack* (list (eval option-read))) - (setq *parent-select-stack* (list ":i
")) + (let ((object (eval option-read))) + (setf (inspect-object-stack *current-inspect*) (list object)) + (setf (inspect-parent-stack *current-inspect*) + (list (format nil ":i ~S" object)))) + (set-break-inspect *current-inspect*) (%inspect output-stream)) ))) @@ -265,55 +286,70 @@ POSITION is NIL if the id is invalid or not found." (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))) +(defun %inspect (s) + (if (inspect-object-stack *current-inspect*) + (let ((inspected (car (inspect-object-stack *current-inspect*)))) + (setq cl:* inspected) + (multiple-value-bind (description list-type elements) + (inspected-parts inspected) + (display-inspected-parts inspected description list-type elements s))) (format s "No object is being inspected"))) -(defun display-inspected-parts (object description list-type elements stream &optional (skip 0)) +(defun current-length () + "returns the current LENGTH for component display" + *inspect-length*) + +(defun current-skip () + "returns the current SKIP for component display" + *inspect-skip*) + + +(defun display-inspected-parts (object description list-type elements stream) (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))))) - (t - (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))))) + (let* ((n-elem (length elements)) + (last (1- n-elem)) + (max (min last (+ *inspect-skip* *inspect-length*)))) + (do* ((index *inspect-skip* (1+ index)) + (count (if (typep elements 'sequence) + (length elements) + 0)) + (element)) + ((> index max)) + (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))))) + (t + (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))) + (when (< (+ *inspect-skip* *inspect-length*) last) + (format stream "~& ...~%~4,' D ~A~%" last (elt elements last)))) + )) ) ;; end binding for multithreading -;;;; INSPECTED-PARTS - -;;; Destructure an object for inspection, returning +;;; INSPECTED-PARTS +;;; +;;; 20030408 - Reworked by KMR to take a :DESCRIPTION keyword +;;; and to return LIST-TYPE rather than NAMED-P +;;; +;;; Destructure an object for inspection, returning either +;;; DESCRIPTION +;;; if description keyword is T, otherwise returns ;;; (VALUES DESCRIPTION LIST-TYPE ELEMENTS), ;;; where.. ;;; @@ -324,10 +360,10 @@ POSITION is NIL if the id is invalid or not found." ;;; 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 marked as "tail" +;;; but the last element is labelled 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. +;;; Otherwise, each element is just VALUE. ;;; ;;; ELEMENTS is a list of the component parts of OBJECT (whose ;;; representation is determined by LIST-TYPE). @@ -411,6 +447,7 @@ POSITION is NIL if the id is invalid or not found." (list (cons "arglist" (sb-kernel:%simple-fun-arglist object))))))) (defmethod inspected-parts ((object vector) &key description) + (declare (vector object)) (let ((desc (format nil "a ~:[~;displaced ~]vector (~W)" (and (sb-kernel:array-header-p object) @@ -432,6 +469,7 @@ POSITION is NIL if the id is invalid or not found." (format nil "[~W~{,~W~}]" (car list) (cdr list))))) (defmethod inspected-parts ((object simple-vector) &key description) + (declare (simple-vector object)) (let ((desc (format nil "a simple ~A vector (~D)" (array-element-type object) (length object)))) @@ -450,6 +488,7 @@ POSITION is NIL if the id is invalid or not found." (sb-kernel:%array-displaced-p object)) (array-element-type object) dimensions))) + (declare (array reference-array)) (if description desc (progn @@ -550,3 +589,40 @@ POSITION is NIL if the id is invalid or not found." (if description desc (values desc nil nil)))) + +;; FIXME - implement setting of component values + +(defgeneric set-component-value (object component-id value element)) + +(defmethod set-component-value ((object cons) id value element) + (format nil "Cons object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object array) id value element) + (format nil "Array object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object symbol) id value element) + (format nil "Symbol object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object structure-object) id value element) + (format nil "Structure object does not support setting of component ~A" id)) + +(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)) +