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