From: Kevin Rosenberg Date: Tue, 8 Apr 2003 19:39:47 +0000 (+0000) Subject: contrib/sb-aclrepl/repl.lisp [0.pre8.48] X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1318df2c3359471005ba38e80f9e2386939d9ff7;p=sbcl.git contrib/sb-aclrepl/repl.lisp [0.pre8.48] - use prompt function hook rather than calling sb-aclrepl's prompt function - use reader conditionals for #+sb-thread and #+aclrepl-debug to control which top-level commands are usable contrib/sb-aclrepl/inspect.lisp - Have inspect length now better mimic ACL's inspect length - Print suspension points and last value of a long component --- diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 13e4949..e1cb509 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -9,19 +9,24 @@ (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. @@ -53,7 +58,9 @@ The commands are: ;; 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)) @@ -70,7 +77,7 @@ The commands are: (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) @@ -78,10 +85,11 @@ The commands are: (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*))) @@ -185,7 +193,8 @@ 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) @@ -210,7 +219,7 @@ The commands are: ((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) @@ -274,48 +283,57 @@ POSITION is NIL if the id is invalid or not found." (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 @@ -323,6 +341,9 @@ POSITION is NIL if the id is invalid or not found." ;;; 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 @@ -336,7 +357,7 @@ 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 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. @@ -423,6 +444,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) @@ -444,6 +466,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)))) @@ -462,6 +485,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 diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index d1c48f2..268246c 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -34,6 +34,15 @@ ;; 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.")) @@ -145,15 +154,6 @@ *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 @@ -304,6 +304,7 @@ (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) @@ -469,6 +470,12 @@ (defun frame-cmd () ) +(defun zoom-cmd () + ) + +(defun local-cmd (&optional var) + ) + (defun processes-cmd () #+sb-thread (let ((pids (thread-pids)) @@ -515,28 +522,31 @@ ("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)))) @@ -686,7 +696,7 @@ (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))))) diff --git a/version.lisp-expr b/version.lisp-expr index 7c6f557..85c7ed7 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.47" +"0.pre8.48"