X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finspect.lisp;h=37e04c8311b65b356ca8b92ee491d8b1f9d44e00;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=a7643895c35736073f2b4e77f95ff94c0e9629d6;hpb=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;p=sbcl.git diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index a764389..37e04c8 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -17,15 +17,22 @@ ;;; indicates that that a slot is unbound. (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")) -(defun inspect (object) +(defun inspector (object input-stream output-stream) + (declare (ignore input-stream)) (catch 'quit-inspect - (%inspect object *standard-output*)) + (%inspect object output-stream)) (values)) +(defvar *inspect-fun* #'inspector + "a function of three arguments OBJECT, INPUT, and OUTPUT which starts an interactive inspector.") + (defvar *inspected*) (setf (documentation '*inspected* 'variable) "the value currently being inspected in CL:INSPECT") +(defun inspect (object) + (funcall *inspect-fun* object *standard-input* *standard-output*)) + (defvar *help-for-inspect* " help for INSPECT: @@ -41,87 +48,84 @@ evaluated expressions. ") (defun %inspect (*inspected* s) - (named-let redisplay () ; "lambda, the ultimate GOTO":-| + (named-let redisplay () ; "LAMBDA, the ultimate GOTO":-| (multiple-value-bind (description named-p elements) - (inspected-parts *inspected*) + (inspected-parts *inspected*) (tty-display-inspected-parts description named-p elements s) (named-let reread () - (format s "~&> ") - (force-output) - (let (;; KMP idiom, using stream itself as EOF value - (command (read *standard-input* nil *standard-input*))) - (typecase command - (stream ; i.e. EOF - ;; currently-undocumented feature: EOF is handled as Q. - ;; If there's ever consensus that this is *the* right - ;; thing to do (as opposed to e.g. handling it as U), we - ;; could document it. Meanwhile, it seems more Unix-y to - ;; do this than to signal an error. - (/show0 "THROWing QUIT-INSPECT for EOF") - (throw 'quit-inspect nil)) - (integer - (let ((elements-length (length elements))) - (cond ((< -1 command elements-length) - (let* ((element (nth command elements)) - (value (if named-p (cdr element) element))) - (cond ((eq value *inspect-unbound-object-marker*) - (format s "~%That slot is unbound.~%") - (return-from %inspect (reread))) - (t - (%inspect value s) - ;; If we ever return, then we should be - ;; looking at *INSPECTED* again. - (return-from %inspect (redisplay)))))) - ((zerop elements-length) - (format s "~%The object contains nothing to inspect.~%") - (return-from %inspect (reread))) - (t - (format s "~%Enter a valid index (~:[0-~D~;0~]).~%" - (= elements-length 1) (1- elements-length)) - (return-from %inspect (reread)))))) - (symbol - (case (find-symbol (symbol-name command) *keyword-package*) - ((:q :e) - (/show0 "THROWing QUIT-INSPECT for :Q or :E") - (throw 'quit-inspect nil)) - (:u - (return-from %inspect)) - (:r - (return-from %inspect (redisplay))) - ((:h :? :help) - (write-string *help-for-inspect* s) - (return-from %inspect (reread))) - (t - (eval-for-inspect command s) - (return-from %inspect (reread))))) - (t - (eval-for-inspect command s) - (return-from %inspect (reread))))))))) + (format s "~&> ") + (force-output) + (let* (;; newly-consed object for hermetic protection against + ;; mischievous input like #.*EOF-OBJECT*: + (eof (cons *eof-object* nil)) + (command (read *standard-input* nil eof))) + (when (eq command eof) + ;; currently-undocumented feature: EOF is handled as Q. + ;; If there's ever consensus that this is *the* right + ;; thing to do (as opposed to e.g. handling it as U), we + ;; could document it. Meanwhile, it seems more Unix-y to + ;; do this than to signal an error. + (/show0 "THROWing QUIT-INSPECT for EOF") + (throw 'quit-inspect nil)) + (typecase command + (integer + (let ((elements-length (length elements))) + (cond ((< -1 command elements-length) + (let* ((element (nth command elements)) + (value (if named-p (cdr element) element))) + (cond ((eq value *inspect-unbound-object-marker*) + (format s "~%That slot is unbound.~%") + (return-from %inspect (reread))) + (t + (%inspect value s) + ;; If we ever return, then we should be + ;; looking at *INSPECTED* again. + (return-from %inspect (redisplay)))))) + ((zerop elements-length) + (format s "~%The object contains nothing to inspect.~%") + (return-from %inspect (reread))) + (t + (format s "~%Enter a valid index (~:[0-~W~;0~]).~%" + (= elements-length 1) (1- elements-length)) + (return-from %inspect (reread)))))) + (symbol + (case (find-symbol (symbol-name command) *keyword-package*) + ((:q :e) + (/show0 "THROWing QUIT-INSPECT for :Q or :E") + (throw 'quit-inspect nil)) + (:u + (return-from %inspect)) + (:r + (return-from %inspect (redisplay))) + ((:h :? :help) + (write-string *help-for-inspect* s) + (return-from %inspect (reread))) + (t + (eval-for-inspect command s) + (return-from %inspect (reread))))) + (t + (eval-for-inspect command s) + (return-from %inspect (reread))))))))) (defun eval-for-inspect (command stream) - (let ((result-list (restart-case (multiple-value-list (eval command)) - (nil () :report "Return to the inspector." - (format stream "~%returning to the inspector~%") - (return-from eval-for-inspect nil))))) - ;; FIXME: Much of this interactive-EVAL logic is shared with - ;; the main REPL EVAL and with the debugger EVAL. The code should - ;; be shared explicitly. - (setf /// // // / / result-list) - (setf +++ ++ ++ + + - - command) - (setf *** ** ** * * (car /)) - (format stream "~&~{~S~%~}" /))) + (let ((result-list (restart-case + (multiple-value-list (interactive-eval command)) + (nil () :report "Return to the inspector." + (format stream "~%returning to the inspector~%") + (return-from eval-for-inspect nil))))) + (format stream "~&~{~S~%~}" result-list))) (defun tty-display-inspected-parts (description named-p elements stream) (format stream "~%~A" description) (let ((index 0)) (dolist (element elements) (if named-p - (destructuring-bind (name . value) element - (format stream "~W. ~A: ~W~%" index name - (if (eq value *inspect-unbound-object-marker*) - "unbound" - value))) - (format stream "~W. ~W~%" index element)) + (destructuring-bind (name . value) element + (format stream "~W. ~A: ~W~%" index name + (if (eq value *inspect-unbound-object-marker*) + "unbound" + value))) + (format stream "~W. ~W~%" index element)) (incf index)))) ;;;; INSPECTED-PARTS @@ -146,111 +150,133 @@ evaluated expressions. (defgeneric inspected-parts (object)) (defmethod inspected-parts ((object symbol)) - (values (format nil "The object is a SYMBOL.~%" object) - t - (list (cons "Name" (symbol-name object)) - (cons "Package" (symbol-package object)) - (cons "Value" (if (boundp object) - (symbol-value object) - *inspect-unbound-object-marker*)) - (cons "Function" (if (fboundp object) - (symbol-function object) - *inspect-unbound-object-marker*)) - (cons "Plist" (symbol-plist object))))) + (values (format nil "The object is a SYMBOL.~%") + t + (list (cons "Name" (symbol-name object)) + (cons "Package" (symbol-package object)) + (cons "Value" (if (boundp object) + (symbol-value object) + *inspect-unbound-object-marker*)) + (cons "Function" (if (fboundp object) + (symbol-function object) + *inspect-unbound-object-marker*)) + (cons "Plist" (symbol-plist object))))) (defun inspected-structure-elements (object) (let ((parts-list '()) (info (layout-info (sb-kernel:layout-of object)))) (when (sb-kernel::defstruct-description-p info) (dolist (dd-slot (dd-slots info) (nreverse parts-list)) - (push (cons (dsd-%name dd-slot) + (push (cons (dsd-name dd-slot) (funcall (dsd-accessor-name dd-slot) object)) parts-list))))) (defmethod inspected-parts ((object structure-object)) (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%" - (type-of object)) - t - (inspected-structure-elements object))) + (type-of object)) + t + (inspected-structure-elements object))) (defun inspected-standard-object-elements (object) (let ((reversed-elements nil) - (class-slots (sb-pcl::class-slots (class-of object)))) + (class-slots (sb-pcl::class-slots (class-of object)))) (dolist (class-slot class-slots (nreverse reversed-elements)) (let* ((slot-name (slot-value class-slot 'sb-pcl::name)) - (slot-value (if (slot-boundp object slot-name) - (slot-value object slot-name) - *inspect-unbound-object-marker*))) - (push (cons slot-name slot-value) reversed-elements))))) + (slot-value (if (slot-boundp object slot-name) + (slot-value object slot-name) + *inspect-unbound-object-marker*))) + (push (cons slot-name slot-value) reversed-elements))))) (defmethod inspected-parts ((object standard-object)) (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%" - (type-of object)) - t - (inspected-standard-object-elements object))) + (type-of object)) + t + (inspected-standard-object-elements object))) + +(defmethod inspected-parts ((object sb-mop:funcallable-standard-object)) + (values (format nil "The object is a ~S of type ~S.~%" + 'sb-mop:funcallable-standard-object (type-of object)) + t + (inspected-standard-object-elements object))) -(defmethod inspected-parts ((object funcallable-instance)) - (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%" - (type-of object)) - t - (inspected-structure-elements object))) +(defmethod inspected-parts ((object condition)) + (values (format nil "The object is a CONDITION of type ~S.~%" + (type-of object)) + t + (inspected-standard-object-elements object))) (defmethod inspected-parts ((object function)) - (let* ((type (sb-kernel:widetag-of object)) - (object (if (= type sb-vm:closure-header-widetag) - (sb-kernel:%closure-fun object) - object))) - (values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object - (sb-kernel:%simple-fun-arglist object) - ;; Defined-from stuff used to be here. Someone took - ;; it out. FIXME: We should make it easy to get - ;; to DESCRIBE from the inspector. - ) - t - nil))) + (values (format nil "The object is a ~A named ~S.~%" + (if (closurep object) 'closure 'function) + (nth-value 2 (function-lambda-expression object))) + t + ;; Defined-from stuff used to be here. Someone took + ;; it out. FIXME: We should make it easy to get + ;; to DESCRIBE from the inspector. + (list* + (cons "Lambda-list" (%fun-lambda-list object)) + (cons "Ftype" (%fun-type object)) + (when (closurep object) + (list + (cons "Closed over values" (%closure-values object))))))) + +#+sb-eval +(defmethod inspected-parts ((object sb-eval:interpreted-function)) + (values (format nil "The object is an interpreted function named ~S.~%" + (nth-value 2 (function-lambda-expression object))) + t + ;; Defined-from stuff used to be here. Someone took + ;; it out. FIXME: We should make it easy to get + ;; to DESCRIBE from the inspector. + (list + (cons "Lambda-list" (sb-eval:interpreted-function-lambda-list object)) + (cons "Definition" (function-lambda-expression object)) + (cons "Documentation" (sb-eval:interpreted-function-documentation object))))) (defmethod inspected-parts ((object vector)) (values (format nil - "The object is a ~:[~;displaced ~]VECTOR of length ~D.~%" - (and (array-header-p object) - (%array-displaced-p object)) - (length object)) - nil - ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what - ;; does *INSPECT-LENGTH* mean? - (coerce object 'list))) + "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%" + (and (array-header-p object) + (%array-displaced-p object)) + (length object)) + nil + ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what + ;; does *INSPECT-LENGTH* mean? + (coerce object 'list))) (defun inspected-index-string (index rev-dimensions) (if (null rev-dimensions) "[]" (let ((list nil)) - (dolist (dim rev-dimensions) - (multiple-value-bind (q r) (floor index dim) - (setq index q) - (push r list))) - (format nil "[~D~{,~D~}]" (car list) (cdr list))))) + (dolist (dim rev-dimensions) + (multiple-value-bind (q r) (floor index dim) + (setq index q) + (push r list))) + (format nil "[~W~{,~W~}]" (car list) (cdr list))))) (defmethod inspected-parts ((object array)) (let* ((length (min (array-total-size object) *inspect-length*)) - (reference-array (make-array length :displaced-to object)) - (dimensions (array-dimensions object)) - (reversed-elements nil)) + (reference-array (make-array length + :element-type (array-element-type object) + :displaced-to object)) + (dimensions (array-dimensions object)) + (reversed-elements nil)) ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what does ;; *INSPECT-LENGTH* mean? (dotimes (i length) (push (cons (format nil - "~A " - (inspected-index-string i (reverse dimensions))) - (aref reference-array i)) - reversed-elements)) + "~A " + (inspected-index-string i (reverse dimensions))) + (aref reference-array i)) + reversed-elements)) (values (format nil "The object is ~:[a displaced~;an~] ARRAY of ~A.~%~ Its dimensions are ~S.~%" - (array-element-type object) - (and (array-header-p object) - (%array-displaced-p object)) - dimensions) - t - (nreverse reversed-elements)))) + (array-element-type object) + (and (array-header-p object) + (%array-displaced-p object)) + dimensions) + t + (nreverse reversed-elements)))) (defmethod inspected-parts ((object cons)) (if (consp (cdr object)) @@ -260,31 +286,31 @@ evaluated expressions. (defun inspected-parts-of-simple-cons (object) (values "The object is a CONS. " - t - (list (cons 'car (car object)) - (cons 'cdr (cdr object))))) + t + (list (cons 'car (car object)) + (cons 'cdr (cdr object))))) (defun inspected-parts-of-nontrivial-list (object) (let ((length 0) - (in-list object) - (reversed-elements nil)) + (in-list object) + (reversed-elements nil)) (flet ((done (description-format) - (return-from inspected-parts-of-nontrivial-list - (values (format nil description-format length) - t - (nreverse reversed-elements))))) + (return-from inspected-parts-of-nontrivial-list + (values (format nil description-format length) + t + (nreverse reversed-elements))))) (loop (cond ((null in-list) - (done "The object is a proper list of length ~S.~%")) - ((>= length *inspect-length*) - (push (cons 'rest in-list) reversed-elements) - (done "The object is a long list (more than ~S elements).~%")) - ((consp in-list) - (push (cons length (pop in-list)) reversed-elements) - (incf length)) - (t - (push (cons 'rest in-list) reversed-elements) - (done "The object is an improper list of length ~S.~%"))))))) + (done "The object is a proper list of length ~S.~%")) + ((>= length *inspect-length*) + (push (cons 'rest in-list) reversed-elements) + (done "The object is a long list (more than ~S elements).~%")) + ((consp in-list) + (push (cons length (pop in-list)) reversed-elements) + (incf length)) + (t + (push (cons 'rest in-list) reversed-elements) + (done "The object is an improper list of length ~S.~%"))))))) (defmethod inspected-parts ((object t)) (values (format nil "The object is an ATOM:~% ~W~%" object) nil nil))