From c117d67f59ebda806f168f31fb2c6b0962d997e6 Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Tue, 8 Apr 2003 10:51:04 +0000 Subject: [PATCH] More repl/inspector improvements [0.pre8.47]: Added :processes & :kill commands Improve :help and :alias output Add keywords to (setf alias) for description and abbreviation length --- contrib/sb-aclrepl/inspect.lisp | 122 +++++++++---------- contrib/sb-aclrepl/repl.lisp | 245 ++++++++++++++++++++++++++++++--------- version.lisp-expr | 2 +- 3 files changed, 255 insertions(+), 114 deletions(-) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index adc4d0b..13e4949 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -9,23 +9,20 @@ (cl:in-package :sb-aclrepl) -(defparameter *inspect-stack* nil - "Stack of the hierarchy of an inspected object.") - -(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 + ;; number of components to display + (length 10)) ;; 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") - (defvar *inspect-help* ":istep takes between 0 to 3 arguments. The commands are: @@ -55,21 +52,22 @@ The commands are: ;; Setup binding for multithreading -(let ((*inspect-stack* nil) - (*parent-select-stack* nil) - (*inspect-length* 10) - (*inspect-raw* nil) - (*inspected* nil)) +(let ((*current-inspect* nil) + (*inspect-raw* nil)) (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 "(inspect ...)")) (%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)) @@ -77,14 +75,16 @@ The commands are: (setq sb-impl::*inspect-fun* #'inspector) (defun reset-stack () - (setq *inspect-stack* nil) - (setq *parent-select-stack* nil) - (makunbound '*inspected*)) + (setf (inspect-object-stack *current-inspect*) nil) + (setf (inspect-parent-stack *current-inspect*) nil)) (defun %istep (arg-string args output-stream) + (unless *current-inspect* + (setq *current-inspect* (make-inspect))) (let* ((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 +94,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 +128,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,11 +140,11 @@ 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 @@ -151,7 +152,7 @@ The commands are: (when value-stirng (let ((new-value (eval (read-from-string (third args))))) (let ((result - (set-component-value (car *inspect-stack*) + (set-component-value (car stack) id new-value (nth position elements)))) @@ -167,7 +168,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))) @@ -175,7 +176,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*)) @@ -187,13 +189,13 @@ The commands are: (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)) @@ -208,14 +210,14 @@ The commands are: ((string-equal "print" option) (let ((len (read-from-string (second args)))) (if (and (integerp len) (plusp len)) - (setq *inspect-length* len) + (setf (inspect-length *current-inspect*) 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* + (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)) @@ -223,8 +225,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 stack) + (push option-read (inspect-parent-stack *current-inspect*)) (%inspect output-stream))))) ((null elements) (format output-stream "Object does not contain any subobjects~%")) @@ -244,8 +246,9 @@ 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
")) + (setf (inspect-object-stack *current-inspect*) (list (eval option-read))) + (setf (inspect-parent-stack *current-inspect*) (list ":i ")) + (set-break-inspect *current-inspect*) (%inspect output-stream)) ))) @@ -272,12 +275,13 @@ POSITION is NIL if the id is invalid or not found." (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))) + (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))) (format s "No object is being inspected"))) @@ -289,7 +293,7 @@ POSITION is NIL if the id is invalid or not found." (when elements (do* ((index skip (1+ index)) (nelem (length elements)) - (max (min (1- nelem) (+ skip *inspect-length*))) + (max (min (1- nelem) (+ skip (inspect-length *current-inspect*)))) (suspension (when (plusp (- nelem max)) (- nelem max))) (count (if (typep elements 'sequence) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 8de960a..d1c48f2 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -15,8 +15,27 @@ (cl:in-package :sb-aclrepl) +(defstruct user-cmd + (input nil) ; input, maybe a string or form + (func nil) ; cmd func entered, overloaded + ; (:eof :null-cmd :cmd-error :history-error) + (args nil) ; args for cmd func + (hnum nil)) ; history number + +(defstruct break-data + ;; numeric break level + level + ;; inspect data for a break level + inspect + ;; T when break initiated by an inspect + inspect-initiated + ;; restarts list for a break level + restarts + ;; T if break level is a continuable break + continuable) + (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *default-prompt* "~&~A(~d): " + (defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): " "The default prompt.")) (defparameter *prompt* #.*default-prompt* "The current prompt string or formatter function.") @@ -38,16 +57,11 @@ "The output stream for the repl") (defparameter *repl-input* nil "The input stream for the repl") +(defparameter *break-stack* (list (make-break-data :level 0)) + "A stack of break data stored as a list of break-level structs") (declaim (type list *history*)) -(defstruct user-cmd - (input nil) ; input, maybe a string or form - (func nil) ; cmd func entered, overloaded - ; (:eof :null-cmd :cmd-error :history-error) - (args nil) ; args for cmd func - (hnum nil)) ; history number - (defvar *eof-marker* (cons :eof nil)) (defvar *eof-cmd* (make-user-cmd :func :eof)) (defvar *null-cmd* (make-user-cmd :func :null-cmd)) @@ -67,6 +81,7 @@ (*cmd-number* 1) (*repl-output* nil) (*repl-input* nil) + (*break-stack* (list (make-break-data :level 0))) ) (defun prompt-package-name () @@ -136,16 +151,20 @@ (func nil) ; function handler (desc nil) ; short description (parsing nil) ; (:string :case-sensitive nil) - (group nil)) ; command group (:cmd or :alias) + (group nil) ; command group (:cmd or :alias) + (abbr-len 0)) ; abbreviation length -(defun make-cte (name-param func desc parsing group) +(defun make-cte (name-param func desc parsing group abbr-len) (let ((name (etypecase name-param (string name-param) (symbol (string-downcase (write-to-string name-param)))))) (make-cmd-table-entry :name name :func func :desc desc - :parsing parsing :group group))) + :parsing parsing :group group + :abbr-len (if abbr-len + abbr-len + (length name))))) (defun %add-entry (cmd &optional abbr-len) (let* ((name (cmd-table-entry-name cmd)) @@ -159,7 +178,7 @@ (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing) (%add-entry - (make-cte cmd-string (symbol-function func-name) desc parsing :cmd) + (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len) abbr-len)) (defun find-cmd (cmdstr) @@ -189,9 +208,14 @@ (let ((cmds '())) (maphash (lambda (k v) (when (and - (eql (length k) (length (cmd-table-entry-name v))) + (= (length k) (length (cmd-table-entry-name v))) (eq (cmd-table-entry-group v) group)) - (push (list k (cmd-table-entry-desc v)) cmds))) + (push (list k + (if (= (cmd-table-entry-abbr-len v) + (length k)) + "" + (subseq k 0 (cmd-table-entry-abbr-len v))) + (cmd-table-entry-desc v)) cmds))) *cmd-table-hash*) (sort cmds #'string-lessp :key #'car))) @@ -234,30 +258,36 @@ (format *repl-output* "~A~%" (eval (sb-debug::untrace-all)))) (values)) +#+sb-thread +(defun thread-pids () + "Return a list of the pids for all threads" + (let ((offset (* 4 sb-vm::thread-pid-slot))) + (sb-thread::mapcar-threads + #'(lambda (sap) (sb-sys:sap-ref-32 sap offset))))) + +#+sb-thread +(defun other-thread-pids () + "Returns a list of pids for all threads except the current process" + (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql)) + (defun exit-cmd (&optional (status 0)) #+sb-thread - (flet ((other-thread-pids () - (let* ((offset (* 4 sb-vm::thread-pid-slot)) - (pids (sb-thread::mapcar-threads - #'(lambda (sap) - (sb-sys:sap-ref-32 sap offset))))) - (delete (sb-thread:current-thread-id) pids :test #'eql)))) - (let ((other-pids (other-thread-pids))) - (when other-pids - (format *repl-output* "There exists the following processes~%") - (format *repl-output* "~{~5d~%~}" other-pids) - (format *repl-output* "Do you want to exit lisp anyway [n]? ") - (force-output *repl-output*) - (let ((input (string-trim-whitespace (read-line *repl-input*)))) - (if (and (plusp (length input)) - (or (char= #\y (char input 0)) - (char= #\Y (char input 0)))) - ;; loop in case more threads get created while trying to exit - (do ((pids other-pids (other-thread-pids))) - ((eq nil pids)) - (map nil #'sb-thread:destroy-thread pids) - (sleep 0.2)) - (return-from exit-cmd)))))) + (let ((other-pids (other-thread-pids))) + (when other-pids + (format *repl-output* "There exists the following processes~%") + (format *repl-output* "~{~5d~%~}" other-pids) + (format *repl-output* "Do you want to exit lisp anyway [n]? ") + (force-output *repl-output*) + (let ((input (string-trim-whitespace (read-line *repl-input*)))) + (if (and (plusp (length input)) + (or (char= #\y (char input 0)) + (char= #\Y (char input 0)))) + ;; loop in case more threads get created while trying to exit + (do ((pids other-pids (other-thread-pids))) + ((eq nil pids)) + (map nil #'sb-thread:destroy-thread pids) + (sleep 0.2)) + (return-from exit-cmd))))) (quit :unix-status status) (values)) @@ -353,8 +383,10 @@ (dotimes (i n) (declare (fixnum i)) (let ((hist (nth (- n i 1) *history*))) - (format *repl-output* "~3A ~A~%" (user-cmd-hnum hist) - (user-cmd-input hist))))) + (format *repl-output* "~3A " (user-cmd-hnum hist)) + (if (stringp (user-cmd-input hist)) + (format *repl-output* "~A~%" (user-cmd-input hist)) + (format *repl-output* "~W~%" (user-cmd-input hist)))))) (values)) (defun help-cmd (&optional cmd) @@ -366,22 +398,21 @@ (cmd-table-entry-name cmd-entry) (cmd-table-entry-desc cmd-entry))))) (t - (format *repl-output* "~13A ~a~%" "Command" "Description") - (format *repl-output* "------------- -------------~%") - (format *repl-output* "~13A ~A~%" "n" - "(for any number n) recall nth command from history list") + (format *repl-output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION") + (format *repl-output* "~11A ~4A ~A~%" "" "" + "re-execute th history command") (dolist (doc-entry (get-cmd-doc-list :cmd)) - (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry))))) + (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) + (second doc-entry) (third doc-entry))))) (values)) (defun alias-cmd () (let ((doc-entries (get-cmd-doc-list :alias))) (typecase doc-entries (cons - (format *repl-output* "~13A ~a~%" "Alias" "Description") - (format *repl-output* "------------- -------------~%") + (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION") (dolist (doc-entry doc-entries) - (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry)))) + (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry)))) (t (format *repl-output* "No aliases are defined~%")))) (values)) @@ -403,6 +434,71 @@ (format *repl-output* "No directory on stack to pop.~%")) (values)) +(defun pop-cmd (&optional (n 1)) + (let ((new-level (- (length *break-stack*) n 1))) + (when (minusp new-level) + (setq new-level 0)) + (dotimes (i (- (length *break-stack*) new-level 1)) + (pop *break-stack*))) + ;; Find inspector + (do* ((i (1- (length *break-stack*)) (1- i)) + (found nil)) + ((or found (minusp i))) + (let ((inspect (break-data-inspect (nth i *break-stack*)))) + (when inspect + (set-current-inspect inspect) + (setq found t)))) + (values)) + +(defun continue-cmd (n) + (let ((restarts (break-data-restarts (car *break-stack*)))) + (if restarts + (if (< -1 n (length restarts)) + (progn + (invoke-restart-interactively (nth n restarts)) + ) + (format *repl-output* "~&There is no such restart")) + (format *repl-output* "~&There are no restarts")))) + +(defun error-cmd () + ) + +(defun current-cmd () + ) + +(defun frame-cmd () + ) + +(defun processes-cmd () + #+sb-thread + (let ((pids (thread-pids)) + (current-pid (sb-thread:current-thread-id))) + (dolist (pid pids) + (format *repl-output* "~&~D" pid) + (when (= pid current-pid) + (format *repl-output* " [current listener]")))) + #-sb-thread + (format *repl-output* "~&Threads are not supported in this version of sbcl") + (values)) + +(defun kill-cmd (selected-pid) + #+sb-thread + (let ((pids (thread-pids))) + (if (find selected-pid pids :test #'eql) + (progn + (sb-thread:destroy-thread selected-pid) + (format *repl-output* "Thread ~D destroyed" selected-pid)) + (format *repl-output* "No thread ~D exists" selected-pid))) + #-sb-thread + (declare (ignore selected-pid)) + #-sb-thread + (format *repl-output* "~&Threads are not supported in this version of sbcl") + (values)) + +(defun reset-cmd () + (setf *break-stack* (last *break-stack*)) + (values)) + (defun dirs-cmd () (dolist (dir *dir-stack*) (format *repl-output* "~a~%" dir)) @@ -419,17 +515,24 @@ ("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") ("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") ("exit" 2 exit-cmd "exit sbcl") +;; ("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") ("pwd" 3 pwd-cmd "print current directory") ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string) - ("popd" 2 popd-cmd "pop directory from stack") + ("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") ("trace" 2 trace-cmd "trace a function") ("untrace" 4 untrace-cmd "untrace a function") ("dirs" 2 dirs-cmd "show directory stack") @@ -440,10 +543,10 @@ ;;;; machinery for aliases -(defsetf alias (name) (user-func) +(defsetf alias (name &key abbr-len description) (user-func) `(progn (%add-entry - (make-cte (quote ,name) ,user-func "" nil :alias)) + (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len)) (quote ,name))) (defmacro alias (name-param args &rest body) @@ -466,7 +569,8 @@ (setq abbr-index param))))) `(progn (%add-entry - (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias) + (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index + (1+ ,abbr-index))) ,abbr-index) ,name))) @@ -526,10 +630,25 @@ ;;;; linking into SBCL hooks (defun repl-prompt-fun (stream) - (if (functionp *prompt*) - (write-string (funcall *prompt* (prompt-package-name) *cmd-number*) - stream) - (format stream *prompt* (prompt-package-name) *cmd-number*))) + (let* ((break-data (car *break-stack*)) + (break-level (break-data-level break-data))) + (when (zerop break-level) + (setq break-level nil)) + (if (functionp *prompt*) + (write-string (funcall *prompt* break-level + (break-data-inspect-initiated break-data) + (break-data-continuable break-data) + (prompt-package-name) *cmd-number*) + stream) + (handler-case + (format nil *prompt* break-level + (break-data-inspect-initiated break-data) + (break-data-continuable break-data) + (prompt-package-name) *cmd-number*) + (error () + (format stream "~&Prompt error> ")) + (:no-error (prompt) + (format stream "~&~A" prompt)))))) (defun process-cmd (user-cmd input-stream output-stream) ;; Processes a user command. Returns t if the user-cmd was a top-level @@ -575,5 +694,23 @@ (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun sb-int:*repl-read-form-fun* #'repl-read-form-fun) +;;; Break level processing + +;; use an initial break-level to hold current inspect toplevel at +;; break-level 0 + +(defun new-break (&key restarts inspect continuable) + (push + (make-break-data :level (length *break-stack*) + :restarts restarts + :inspect inspect + :inspect-initiated (when inspect t) + :continuable continuable) + *break-stack*)) + +(defun set-break-inspect (inspect) + "sets the inspect data for the current break level" + (setf (break-data-inspect (car *break-stack*)) inspect)) + ) ;; close special variables bindings diff --git a/version.lisp-expr b/version.lisp-expr index 753fa1a..7c6f557 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.46" +"0.pre8.47" -- 1.7.10.4