(cl:in-package :sb-aclrepl)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +default-inspect-length+ 10))
+
(defstruct inspect
;; stack of parents of inspected object
object-stack
;; a stack of indices of parent object components
- parent-stack
- ;; number of components to display
- (length 10))
+ 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.")
+(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.
;; Setup binding for multithreading
(let ((*current-inspect* nil)
- (*inspect-raw* nil))
+ (*inspect-raw* nil)
+ (*inspect-length* +default-inspect-length+)
+ (*inspect-skip* 0))
(defun inspector (object input-stream output-stream)
(declare (ignore input-stream))
(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)
(setf (inspect-object-stack *current-inspect*) nil)
(setf (inspect-parent-stack *current-inspect*) nil))
-(defun %istep (arg-string args output-stream)
+(defun %istep (arg-string output-stream)
(unless *current-inspect*
(setq *current-inspect* (make-inspect)))
- (let* ((option (car args))
+ (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*)))
((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)
((string-equal "print" option)
(let ((len (read-from-string (second args))))
(if (and (integerp len) (plusp len))
- (setf (inspect-length *current-inspect*) len)
+ (setq *inspect-length* len)
(format output-stream "Cannot set print limit to ~A~%" len))))
;; Select numbered or named component
((or (symbolp option-read)
(values nil nil nil)))
-(defun %inspect (s &optional (skip 0))
+(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 skip)))
+ (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 *current-inspect*))))
- (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
\f
;;; 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
;;; 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 label 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.
(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)
(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))))
(sb-kernel:%array-displaced-p object))
(array-element-type object)
dimensions)))
+ (declare (array reference-array))
(if description
desc
(progn
;; T if break level is a continuable break
continuable)
+;;; cmd table entry
+(defstruct cmd-table-entry
+ (name nil) ; name of command
+ (func nil) ; function handler
+ (desc nil) ; short description
+ (parsing nil) ; (:string :case-sensitive nil)
+ (group nil) ; command group (:cmd or :alias)
+ (abbr-len 0)) ; abbreviation length
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): "
"The default prompt."))
*eof-cmd*
(make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
-;;; cmd table entry
-(defstruct cmd-table-entry
- (name nil) ; name of command
- (func nil) ; function handler
- (desc nil) ; short description
- (parsing nil) ; (:string :case-sensitive nil)
- (group nil) ; command group (:cmd or :alias)
- (abbr-len 0)) ; abbreviation length
-
(defun make-cte (name-param func desc parsing group abbr-len)
(let ((name (etypecase name-param
(string
(defun string-to-list-skip-spaces (str)
"Return a list of strings, delimited by spaces, skipping spaces."
+ (declare (string str))
(when str
(loop for i = 0 then (1+ j)
as j = (position #\space str :start i)
(defun frame-cmd ()
)
+(defun zoom-cmd ()
+ )
+
+(defun local-cmd (&optional var)
+ )
+
(defun processes-cmd ()
#+sb-thread
(let ((pids (thread-pids))
("cf" 2 cf-cmd "compile file" :parsing :string)
("cload" 2 cload-cmd "compile if needed and load file"
:parsing :string)
-;; ("current" 3 current-cmd "print the expression for the current stack frame")
-;; ("continue" 4 continue-cmd "continue from a continuable error")
+ #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
+ #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
("describe" 2 describe-cmd "describe an object")
("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
("package" 2 package-cmd "change current package")
-;; ("error" 3 error-cmd "print the last error message")
+ #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
("exit" 2 exit-cmd "exit sbcl")
-;; ("frame" 2 frame-cmd "print info about the current frame")
+ #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
("help" 2 help-cmd "print this help")
("history" 3 history-cmd "print the recent history")
("inspect" 2 inspect-cmd "inspect an object")
("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
- ("kill" 2 kill-cmd "kill a process")
+ #+sb-thread ("kill" 2 kill-cmd "kill a process")
+ #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
("pwd" 3 pwd-cmd "print current directory")
("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
("popd" 4 popd-cmd "pop directory from stack")
- ("processes" 3 processes-cmd "list all processes")
+ #+sb-thread ("processes" 3 processes-cmd "list all processes")
("trace" 2 trace-cmd "trace a function")
("untrace" 4 untrace-cmd "untrace a function")
("dirs" 2 dirs-cmd "show directory stack")
- ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
+ ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
+ #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
+ )))
(dolist (cmd cmd-table)
(destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
(add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
(loop for user-cmd = (read-cmd input-stream) do
(if (process-cmd user-cmd input-stream output-stream)
(progn
- (repl-prompt-fun output-stream)
+ (funcall sb-int:*repl-prompt-fun* output-stream)
(force-output output-stream))
(return (user-cmd-input user-cmd)))))
projects / sbcl.git / commitdiff