-(defun %istep (arg-string args output-stream)
- (let* ((option (car args))
- (option-read (when arg-string
- (read-from-string arg-string))))
- (cond
- ;; Redisplay
- ((or (string= "=" option)
- (zerop (length args)))
- (%inspect output-stream))
- ;; Select parent
- ((or (string= "-" option)
- (string= "^" option))
- (cond
- ((> (length *inspect-stack*) 1)
- (pop *inspect-stack*)
- (%inspect output-stream))
- (*inspect-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 ...)"))
- (%inspect output-stream))
- ;; Start new inspect level for eval'd form
- ((string= "+" option)
- (inspector (eval (second args)) nil output-stream))
- ;; Next or previous parent component
- ((or (string= "<" option)
- (string= ">" option))
- (if *inspect-stack*
- (if (eq (length *inspect-stack*) 1)
- (format output-stream "Object does not have a parent")
- (let ((parent (second *inspect-stack*))
- (id (car *parent-select-stack*)))
- (multiple-value-bind (position list-type elements)
- (find-object-component parent id)
- (declare (list elements)
- (ignore list-type))
- (let ((new-position (if (string= ">" option)
- (1+ position)
- (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*)
- (if (integerp id)
- new-position
- (read-from-string
- (car (nth new-position elements)))))
- (%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 *inspect-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)
- (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))
- (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 *inspect-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))
- ;; 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))
- (%inspect output-stream len)
- (format output-stream "Skip missing or invalid~%"))))
- ;; Print stack tree
- ((string-equal "tree" option)
- (if *inspect-stack*
- (progn
- (format output-stream "The current object is:~%")
- (dotimes (i (length *inspect-stack*))
- (format output-stream "~A, ~A~%"
- (inspected-parts (nth i *inspect-stack*) :description t)
- (let ((select (nth i *parent-select-stack*)))
- (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 *inspect-stack*
- (multiple-value-bind (position list-type elements)
- (find-object-component (car *inspect-stack*) option-read)
- (cond
- ((integerp position)
- (let* ((element (elt elements position))
- (value (if (eq list-type :named) (cdr element) element)))
- (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*)
- (%inspect output-stream)))))
- ((null elements)
- (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
- (= (length elements) 1)
- (1- (length elements))))))))
- (%inspect output-stream)))
- ;; Default is to select eval'd form
- (t
- (reset-stack)
- (setq *inspect-stack* (list (eval option-read)))
- (setq *parent-select-stack* (list ":i <form>"))
- (%inspect output-stream))
- )))