;;; -*- Mode: Lisp; fill-column: 79; -*- ;;; ;;; inspect.lsp -- a reasonably hairy tty CL inspector ;;; ;;; Copyright (C) 1998 Vassili Bykov ;;; ;;; Date: January 26, 1998 ;;; Legalese: GNU General Public License ;;; Seems to work in: CLISP, CMUCL+PCL ;;; But: No warranty (see Legalese), flames to /dev/null ;;; ;;; Supposed to work in any CL with CLOS+some MOP (or native CLISP CLOS), and ;;; LOOP. Includes CLISP-specific access to structures and CLOS instances, but ;;; the major part is generic CL. Does NOT jump through many (any?) hoops to ;;; be efficient garbage- or speed-wise, but on the plus side, reasonably ;;; simple with quite a few bells and whistles. ;;; ;;; See the tutorial at the bottom of the file. For more, see the file itself. (defpackage "INSPECTOR" (:use "COMMON-LISP") #+(AND CLISP (NOT PCL)) (:import-from "CLOS" clos::structure-object clos::class-slot-location-table) #+PCL (:import-from "PCL" pcl::class-slots pcl::slot-definition-name) (:export inspect *inspector-length* *inspector-level* *inspector-page* *mode-switch-indicator*) ) (in-package "INSPECTOR") ;;; ========= ;;; UTILITIES ;;; ========= (defun symbol< (a b) (string< (symbol-name a) (symbol-name b))) (declaim (inline symbol<)) (define-condition internal-error (error) () (:documentation "The error signaled whenever a condition is detected that could not have occurred in a healthy program, regardless of the input.")) ;;; =============== ;;; PRINTER CONTROL ;;; =============== ;;; ;;; Here is what we do to not let the printer break loose. (defparameter *inspector-level* 2 "*print-level* gets bound to this when Inspector prints its objects.") (defparameter *inspector-length* 6 "*print-length* gets bound to this when Inspector prints its objects.") (defparameter *inspector-page* 25 "Large objects are displayed this many parts at a time.") (defmacro with-bound-printer-vars (&body forms) "Evaluate FORMS in a dynamic environment where the important printer control variables are bound to our preferred values." `(LET ((*PRINT-CIRCLE* T) #-clisp (*PRINT-LINES* 1) ; no *print-lines* in CLISP (*PRINT-LEVEL* *INSPECTOR-LEVEL*) (*PRINT-LENGTH* *INSPECTOR-LENGTH*)) ,@forms)) (defparameter *mode-switch-indicator* #\+ "A string or a character printed before the title of the current object if the object allows inspection mode switch.") ; CMUCL only for now ;;; ==================== ;;; INSPECTION INTERFACE ;;; ==================== ;;; ;;; Inspector works by invoking these generics on the currently inspected ;;; object, occasionally with other arguments. Teaching a new type to the ;;; inspector means writing methods specializing on that type for a few of ;;; these functions (more often than not PART-COUNT, PRINT-PARTS, PART-REF, ;;; PART-SET, and REFERENCE-EXPLANATION). See generic docs for details. (define-condition part-ref-error (error) () (:documentation "Signaled when an attempt is made to access an object part that does not exist or is unbound or set a part that is not settable.")) ;; For now mode switch is used in CMUCL only. (defgeneric allows-mode-switch-p (object) (:documentation "True if the object can be viewed in several modes.")) (defmacro declare-as-mode-switcher (class) "Make sure instances of the class are recognized as mode switchers." `(DEFMETHOD ALLOWS-MODE-SWITCH-P ((OBJ ,class)) (DECLARE (IGNORE OBJ)) T)) (defgeneric print-blurb (object) (:documentation "Print a short description of the OBJECT, no newlines.")) (defgeneric part-count (object) (:documentation "Return the number of parts selectable in the OBJECT.")) (defgeneric print-parts (object &key first last) (:documentation "Print a list of parts selectable in the OBJECT.")) (defgeneric part-ref (object index) (:documentation "Return value of a part at INDEX in the OBJECT or signal PART-REF-ERROR if the index is invalid or the part cannot be selected (e.g. a slot is unbound).")) (defgeneric part-set (object index value) (:documentation "Make VALUE the value of part at INDEX in the OBJECT. Signal PART-REF-ERROR if the index is invalid or the place cannot be modified.")) (defsetf part-ref part-set) (defgeneric reference-explanation (object index) (:documentation "Return a string describing a part at INDEX in the object.")) (defgeneric perform-command (object command args) ;; Object is less important in specializing than the command! (:argument-precedence-order command args object) (:documentation "Process an input string from the user that has been parsed as a list (COMMAND &REST ARGS). COMMAND, if a symbol, is interned in the :INSPECTOR package so methods can easily EQL-specialize on it.")) (defgeneric help-on-commands (object) (:documentation "Print a summary of special commands supported by the object.")) ;;; =============== ;;; OBJECT WRAPPING ;;; =============== ;;; ;;; Some objects are not placed on the inspector stack as they are. Instead, ;;; an instance of a "wrapper" type holding onto the original object is ;;; used. We can specialize on that type to provide unusual behaviour (like ;;; displaying only this many lines at a time). (defgeneric wrap-for-inspection (object) (:documentation "Wrap the argument into all the wrappers it requires and return the result.")) (defgeneric unwrap (object) (:documentation "Remove one layer of wrappers from the OBJECT.")) (defgeneric unwrap* (object) (:documentation "Remove all wrappers from the OBJECT.")) (defmethod wrap-for-inspection ((object t)) (if (> (part-count object) *inspector-page*) (make-peephole object) object)) (defclass wrapper (standard-object) ((contents :initarg :contents :accessor unwrap))) (defmethod unwrap ((object t)) object) ;; defmethod unwrap ((object wrapper)) is a default accessor (defmethod unwrap* ((object t)) object) (defmethod unwrap* ((w wrapper)) (unwrap* (unwrap w))) (eval-when #+CLISP (compile load eval) #-CLISP (:compile-toplevel :load-toplevel :execute) (defun %arg-symbol (form) ;; Converts a lambda list entry of a form NAME or (NAME TYPE) ;; into NAME. (cond ((symbolp form) form) ((consp form) (%arg-symbol (car form))) (t (error "malformed delegator arglist")))) ) ; EVAL-WHEN (defmacro define-unwrapping-delegator (class fun (&rest args)) "Defines a method of a generic FUN specializing on a CLASS, supposedly a wrapper, so that it fetches the wrapper contents and reinvokes the function on it." `(DEFMETHOD ,fun ((WRAPPER ,class) ,@args) (,fun (UNWRAP WRAPPER) ,@(mapcar #'%arg-symbol args)))) ;; Default wrapper reinvokes all inspection interface functions on its contents ;; instead of itself. This means wrappers cannot be inspected themselves but ;; who cares? (define-unwrapping-delegator wrapper allows-mode-switch-p ()) (define-unwrapping-delegator wrapper print-blurb ()) (define-unwrapping-delegator wrapper part-ref (index)) (define-unwrapping-delegator wrapper part-set (index value)) (define-unwrapping-delegator wrapper perform-command (cmd args)) (define-unwrapping-delegator wrapper reference-explanation (ref)) (define-unwrapping-delegator wrapper help-on-commands ()) ;; This is too complex for the poor simple-minded DEFINE-UNWRAPPING... (defmethod print-parts ((w wrapper) &key first last) (perform-command (unwrap w) :first first :last last)) ;;; =============== ;;; INSPECTOR STATE ;;; =============== ;;; ;;; Objects are printed together with a list of their parts. Parts are ;;; identified by integer indices. As we descend into objects' parts, the ;;; objects get pushed onto a stack, as well as the indices used to access ;;; each object in its container object. This allows us to print a pretty ;;; explanation of what each object is in the one that used to contain it. (defvar *object-stack* '() "The current inspection history (a list of objects). As we dive into the object slots objects get consed onto this list. Note: the variable is BOUND to NIL each time the inspector is entered.") (defvar *component-reference-stack* '() "A list of integers 'parallel' to the *OBJECT-STACK* list. Each index shows what part index was used to descend to the correspnding object from its parent. The index is nil for the bottom of the stack (the object on which the inspector itself was invoked. Note: the variable is BOUND when the inspector is invoked.") (defvar *inspector-count* 0 "Number of recursive calls to the inspector currently in effect.") (defun push-object (object parent-ref) (push (wrap-for-inspection object) *object-stack*) (push parent-ref *component-reference-stack*)) (defun top-object () (car *object-stack*)) (defun top-reference () (car *component-reference-stack*)) (defun pop-stacks () (pop *object-stack*) (pop *component-reference-stack*)) (defun at-object-stack-top-p () (null (cdr *object-stack*))) ;;; ======================================= ;;; INSPECTOR ENTRANCE AND THE COMMAND LOOP ;;; ======================================= (defun inspect (object) "Enter the inspector with the OBJECT as the inspected object. Use ? or H after entering the inspector to see the (context-sensitive) list of commands." (catch 'QUIT (unwind-protect (let ((*object-stack* '()) (*component-reference-stack* '()) (*standard-output* *debug-io*) (*standard-input* *debug-io*)) (incf *inspector-count*) (inspector-loop object)) (decf *inspector-count*)))) (defvar *redisplay* nil "This is set to true by various command bodies to let the inspector loop know that the object needs redisplaying (probably after one of the slots has been changed. The loop resets this back to NIL after it prints the object. The loop also prints the object stack top after a command is executed if it is not EQ to the object remembered before the command (i.e. new object is selected.") (defun inspector-loop (object) "Repeatedly read and process the user's commands, displaying the prompt and, possibly, the current object between the commands." (let (previous-top-cell) (push-object object nil) (format t "~&Entering inspector loop, ? for a list of commands.~%") (loop (let ((top-cell *object-stack*)) (when (or *redisplay* (not (eq top-cell previous-top-cell))) (print-menu (car top-cell)) (setq previous-top-cell top-cell) (setq *redisplay* nil))) (print-prompt) (catch 'ABORT (restart-case (process-command (read-command)) (return-to-inspector () :report "Return to the inspector loop" (format t "~&Returning to the inspector.") (setq *redisplay* t) (throw 'ABORT nil))))))) (defun print-prompt () (format t "~&~D.~D Inspect> " *inspector-count* (length *object-stack*)) (finish-output)) (defun read-command () "Read a line from the standard input and parse it into individual components separated by whitespace. Components are fetched by READ, with all the consequences it implies (words are interned as symbols in the current package). Return a list of components." (let ((cline (read-line nil nil "Q")) ; on EOF act as if it were Quit (command '()) (eof-marker (cons nil nil))) (with-input-from-string (s cline) (loop (let ((word (read s nil eof-marker))) (if (eq word eof-marker) (return (nreverse command)) (push word command))))))) (defun process-command (command) "Accept a list of command components as supplied by READ-COMMAND and invoke PERFORM-COMMAND generic function. The function EQL-specializes on the first argument to choose the command handler. The first argument, if symbol, is thus reinterned in the INSPECTOR package." (perform-command (top-object) (and command (if (symbolp (car command)) ;; Reintern command in INSPECTOR so we can EQL-specialize on it. (intern (symbol-name (car command)) (find-package :inspector)) (car command))) (and command (cdr command)))) (defun print-menu (object) "Print description of the current object and a list of its parts." (with-bound-printer-vars (princ (if (allows-mode-switch-p object) *mode-switch-indicator* " ")) (print-blurb object) (terpri) (print-parts object))) ;;; ================================== ;;; GROUND CASE PRESENTATION INTERFACE ;;; ================================== ;;; ;;; These provide reasonable defaults taking care of indivisible objects ;;; like numbers and characters, and anything the inspector does not know ;;; about. (defmethod allows-mode-switch-p ((object t)) (declare (ignore object)) nil) (defmethod print-blurb ((object t)) (format t "a ~(~A~) ~S" (type-of object) object)) (defmethod part-count ((object t)) (declare (ignore object)) 0) (defmethod print-parts ((object t) &key first last) (declare (ignore object first last))) (defmethod part-ref ((object t) index) (declare (ignore object index)) (error 'part-ref-error)) (defmethod part-set ((object t) index value) (declare (ignore object index value)) (error 'part-ref-error)) (defmethod reference-explanation ((object t) ref) (declare (ignore object ref)) (error 'internal-error "atomic object could not have parts")) ;;; ==================== ;;; GROUND CASE COMMANDS ;;; ==================== ;;; ;;; If the command line was "foo 3 bar" the COMMAND passed to PERFORM-COMMAND ;;; is 'INSPECTOR::FOO and ARGS is (3 BAR) where BAR is in *PACKAGE*. (defmethod perform-command (object command args) "Least specific of all: command is not recognized." (declare (ignore object command args)) (princ "Invalid command, ? for help.")) (defmethod perform-command (object (index integer) (args null)) "Command is 'integer': generic descend into a part." (declare (ignore args)) (handler-case (push-object (part-ref object index) index) (part-ref-error () (format t "~D does not refer to a selectable part." index)))) (defmethod perform-command (object (index integer) (args cons)) "Command is ' ': generic set part's value." (let ((value (eval (expand-$ (car args))))) (handler-case (part-set object index value) (part-ref-error () (format t "~D does not refer to a settable part." index)) (:no-error (v) (declare (ignore v)) (setq *redisplay* t))))) (defmethod perform-command (object (command (eql '?)) args) "?: help." (declare (ignore command args)) (help-on-commands object)) (defmethod perform-command (object (command (eql 'H)) args) "H: help." (declare (ignore command args)) (help-on-commands object)) (defconstant +help-message+ "Commands: U ~15T- Up to the object containing the current one. T ~15T- Return to the top (first object inspected). D ~15T- Display the current object. W ~15T- Where am I? Print the history of inspected objects. N ~15T- Inspect next component of the parent object. P ~15T- Inspect previous component of the parent object. I ~15T- Inspect result of in a recursive inspector. E ~15T- Evaluate and print the result. () ~15T- Same as 'E ()'. ? or H ~15T- Help message. Q ~15T- Quit (return the currently inspected object). If an object has a selectable part at index N, 'N ' sets place N to the resullt of . In expressions, $ and ($) evaluate to the current object, ($ N) - to part N of it. ($ ()) and ($ (N)) - to the object one level up the stack and part N of it, etc. ~%") (defmethod help-on-commands (object) (declare (ignore object)) (format t +help-message+)) (defmethod perform-command (object (command (eql 'D)) args) "D: redisplay the object" (declare (ignore object command args)) (setq *redisplay* t)) (defmethod perform-command (object (command (eql 'U)) args) "U: go up to the object's parent." (declare (ignore object command args)) (if (at-object-stack-top-p) (princ "Already at the top.") (pop-stacks))) (defmethod perform-command (object (command (eql 'T)) args) "T: go to the top object - the one the inspector was invoked on." (declare (ignore object command args)) (setq *object-stack* (last *object-stack*)) (setq *component-reference-stack* (last *component-reference-stack*))) (defmethod perform-command (object (command (eql 'N)) args) "N: go to the next part within the parent object." (declare (ignore object command args)) (move-in-parent 1)) (defmethod perform-command (object (command (eql 'P)) args) "P: go to the previous part of the parent object." (declare (ignore object command args)) (move-in-parent -1)) (defun move-in-parent (delta) (let ((top-reference (top-reference))) (cond ((null top-reference) (princ "No parent composite object.")) (t (let ((parent (cadr *object-stack*)) (new-ref (+ top-reference delta))) (cond ((or (minusp new-ref) (>= new-ref (part-count parent))) (format t "Already at the ~:[last~;first~] part." (minusp delta))) (t (pop-stacks) (perform-command parent new-ref nil)))))))) (defmethod perform-command (object (command (eql 'W)) args) "W: where - go up the history stack explaining how we got here." (declare (ignore object command args)) (format t " Currently looking at ") (loop for oc on *object-stack* and or on *component-reference-stack* do (with-bound-printer-vars (print-blurb (car oc))) (when (car or) (format t "~& which is the ~A of " (reference-explanation (cadr oc) (car or)))))) (defmethod perform-command (object (command (eql 'I)) (args cons)) "I: evaluate the arguments and invoke a recursive inspector to inspect the result. DO NOT set * to the result of the inspection: it may be out of sync with /, + and such." (declare (ignore object command)) (inspect (evaluate (car args))) (setq *redisplay* t)) (defmethod perform-command (object (command (eql 'Q)) args) "Quit." ;; If the command letter for Quit is changed from Q, the change should also ;; go into READ-COMMAND function which mocks Quit on EOF. (declare (ignore object command args)) (throw 'QUIT (unwrap* (top-object)))) (defmethod perform-command (object (command cons) args) "The command is a list: it is a shortcut for evaluation." (declare (ignore object args)) (evaluate command)) (defmethod perform-command (object (command (eql 'E)) args) "E: evaluate the first argument." (declare (ignore object command)) (cond ((null args) (princ "Nothing to evaluate.")) (t (evaluate (car args))))) (defun evaluate (form) "Expand $ macros in the form, evaluate it setting all the /s and such, print the list of returned values and return the first value returned by the form, nil if zero values." (let* ((expansion (expand-$ form)) (results (multiple-value-list (eval expansion))) (result (and results (car results)))) (setq /// // // / / results) (setq +++ ++ ++ + + expansion) (setq *** ** ** * * result) (format t "~{ ~S~%~}" results) result)) (defparameter inspector-macro-name "$" "A symbol name; a form with this name in the car position get expanded into a call to INSPECTOR::GRAB-OBJECT with the cdr passed unevaluated as an argument.") ;; Expand instead of specially binding $ as a variable and a function to avoid ;; interning $ in the current package every time. (defun expand-$ (form) (flet ((macro-symbol-p (object) (and (symbolp object) (string= (symbol-name object) inspector-macro-name)))) (cond ((macro-symbol-p form) ; $ (expand-$-part-grabber nil)) ((consp form) ; ($ ...) (if (macro-symbol-p (car form)) (expand-$-part-grabber (cdr form)) (cons (expand-$ (car form)) (expand-$-rest (cdr form))))) (t form)))) (defun expand-$-rest (form) (if (atom form) (expand-$ form) (cons (expand-$ (car form)) (expand-$-rest (cdr form))))) ;; The following is responsible for the actual decoding of an inspected object ;; reference of the form ($ ), where (unevaluated) ;; becomes the SPEC argument, as follows: ;; ;; Original form SPEC Meaning ;; $ or ($) nil Top (currently inspected) object ;; ($ N) (N) Slot N of the top object (N must be a number). ;; ($ ()) (nil) Second object on the stack. ;; ($ (N)) ((N)) Slot N of the second object on the stack. ;; ($ (())) ((nil)) Third object on the stack. ;; ($ ((N))) (((N))) Slot N of the third object on the stack. ;; etc. ;; (defun expand-$-part-grabber (spec) (labels ((translate-spec (spec level) ;; A spec is translated into a two-element list. The first is how ;; many levels down the inspector stack we go, the second is the ;; slot number in the object that many levels up. (typecase spec (null (list level nil)) (cons (typecase (car spec) (integer (list level (car spec))) (t (translate-spec (car spec) (1+ level))))) (t (error "object spec is funny" spec))))) `(FETCH-OBJECT-OR-PART ,@(translate-spec spec 0)))) ;; OBJREF and PARTREF in the following functions are list elements generated ;; by TRANSLATE-SPEC in EXPAND-$-PART-GRABBER above. (defun fetch-object-or-part (objref partref) (let ((object-cell (nthcdr objref *object-stack*))) (when (null object-cell) (error 'part-ref-error)) (if partref (part-ref (car object-cell) partref) (car object-cell)))) (defsetf fetch-object-or-part (objref partref) (store) (let ((tmp (gensym))) (unless partref (error "only parts of objects are SETFable")) `(LET ((,tmp (NTHCDR ,objref *OBJECT-STACK*))) (UNLESS ,tmp (ERROR 'PART-REF-ERROR)) (PART-SET (CAR ,tmp) ,partref ,store)))) ;;; =================== ;;; INSPECTOR-PEEPHOLES ;;; =================== ;;; ;;; Peepholes are wrappers used to limit object part lists to *INSPECTOR-PAGE* ;;; lines at a time. All objects with PART-COUNT exceeding *INSPECTOR-PAGE* ;;; get wrapped into a peephole before they are placed on the inspector stack. ;;; Peepholes intercept some commands to provide this paging bahaviour. (defclass inspector-peephole (wrapper) ((top :initform 0) (part-count :initarg :part-count))) (defun make-peephole (object) (make-instance 'inspector-peephole :contents object :part-count (part-count object))) (defmethod print-parts ((p inspector-peephole) &key first last) (declare (ignore first last)) (with-slots (top part-count contents) p (let ((bottom (min (+ top *inspector-page*) part-count))) (unless (zerop top) (format t " ...~%")) (print-parts contents :first top :last bottom) (unless (>= bottom part-count) (format t "~& ... (~D elements total)~%" part-count))))) (defun peephole-go-to (p position) "Move the peephole origin to the specified POSITION, after making sure it would not become negative or move beyond the end." (with-slots (top part-count) p (let ((new-top (max (min (- part-count *inspector-page*) position) 0))) (setf top new-top)))) (defmethod perform-command :after ((p inspector-peephole) (c integer) (args cons)) "After setting a part we want to redisplay around the set position." (declare (ignore args)) ;; Just simulate the command so it comes out nicely centered. (perform-command p 'G (list c))) (defmethod help-on-commands :after ((p inspector-peephole)) (format t "~%~3T[Return] ~15T- Display next screenful of parts.~@ ~3TB ~15T- Display previous screenful of parts.~@ ~3TG ~15T- Go to (display) parts around the one at index.~%")) (defmethod perform-command ((p inspector-peephole) (c (eql NIL)) args) "EMPTY LINE (RETURN): display next screenful" (declare (ignore c args)) (peephole-go-to p (+ *inspector-page* (slot-value p 'top))) (setq *redisplay* t)) (defmethod perform-command ((p inspector-peephole) (c (eql 'B)) args) "B: go back a screenful" (declare (ignore c args)) (peephole-go-to p (- (slot-value p 'top) *inspector-page*)) (setq *redisplay* t)) (defmethod perform-command ((p inspector-peephole) (c (eql 'G)) args) "G: go to index." (let ((target-pos (if (integerp (car args)) (car args) 0))) (with-slots (part-count) p (peephole-go-to p (- target-pos (floor (/ *inspector-page* 2)))))) (setq *redisplay* t)) ;;; ************************************************************************ ;;; Data type-specific stuff follows. Most of these just specialize on the ;;; functions from INSPECTION INTERFACE section above. Objects of types not ;;; mentioned here are considered atomic by the methods from the GROUND CASE ;;; section: they are displayed as having no subcomponents. ;;; ************************************************************************ ;;; ======= ;;; SYMBOLS ;;; ======= (defmethod part-count ((s symbol)) (declare (ignore s)) 5) (defmethod print-parts ((s symbol) &key first last) (declare (ignore first last)) (format t "~& [0] name : ~S~ ~& [1] value : ~:[~A~;~S~]~ ~& [2] function : ~:[~A~;~S~]~ ~& [3] plist : ~S~ ~& [4] package : ~S" (symbol-name s) (boundp s) (if (boundp s) (symbol-value s) "") (fboundp s) (if (fboundp s) (symbol-function s) "") (symbol-plist s) (symbol-package s))) (defmethod part-ref ((s symbol) index) (handler-case (case index (0 (symbol-name s)) (1 (symbol-value s)) (2 (symbol-function s)) (3 (symbol-plist s)) (4 (symbol-package s)) (t (signal 'part-ref-error))) ((or unbound-variable undefined-function) () (error 'part-ref-error)))) (defmethod part-set ((s symbol) index value) (case index (1 (setf (symbol-value s) value)) (2 (setf (symbol-function s) value)) (3 (setf (symbol-plist s) value)) (t (signal 'part-ref-error)))) (defmethod reference-explanation ((s symbol) ref) (ecase ref (0 "name") (1 "value cell") (2 "function cell") (3 "property list") (4 "package"))) (defmethod help-on-commands ((s symbol)) (call-next-method) (format t " 0..4 ~15T- Descend into a component at that index.~%")) ;;; ==================== ;;; SEQUENCES IN GENERAL ;;; ==================== (defmethod part-count ((s sequence)) (length s)) (defmethod part-ref ((s sequence) index) (handler-case (elt s index) (error () (error 'part-ref-error)))) (defmethod part-set ((s sequence) index value) (handler-case (setf (elt s index) value) (error () (error 'part-ref-error)))) (defmethod reference-explanation ((s sequence) ref) (format nil "element ~D" ref)) (defmethod help-on-commands ((s sequence)) (call-next-method) (format t " 0..~D ~15T- Descend into a component at that index.~%" (1- (length s)))) ;;; ====== ;;; CONSES ;;; ====== ;;; ;;; These are arbitrary CONS concoctions--anything rooted in a CONS cell. We ;;; thus should be prepared to deal with improper and circular lists. The way ;;; it is done now is we walk the construct to see what it looks like on every ;;; access. Might be quite a lot of work and generate lots of garbage, ;;; however, this saves us the trouble of caring to stay up to date with the ;;; list. ;;; ;;; We also treat CDRs of cells as addressable parts. For example, in a list ;;; of 5 elements indices 0-4 refer to CARs of the cells, while indices 10-14 ;;; refer to CDRs. (Always prepend 1 to element (CAR) reference index to ;;; obtain the same cell's CDR reference index. (defun circularp (l) "Check whether the argument cons has a circularity in its CDR chain." (loop for tortoise = l then (cdr tortoise) and hare = (cdr l) then (cddr hare) while (and hare (consp hare) (cdr hare) (consp (cdr hare))) thereis (eq tortoise hare))) (defun improperp (l) "Return true if the argument (MUST NOT be circular) is an improper list." (not (null (cdr (last l))))) (defun cons-construct-kind (c) "Classify the argument arbitrary CONS. Tests are done in a safe order so the argument may have CDR-cycles or be improper. Return one of the following: :CIRCULAR, :IMPROPER or :PROPER." (cond ((circularp c) :circular) ((improperp c) :improper) (t :proper))) (defun cdrbase (n) "Calculate the base index for CDR references in a list of N elements: that is, the smallest power of 10 greater than N." (declare (integer n)) (expt 10 (ceiling (log n 10)))) (defmethod print-blurb ((c cons)) (with-bound-printer-vars (format t "~A ~S" (ecase (cons-construct-kind c) (:proper "a proper list") (:improper (if (consp (cdr c)) "an improper list" "a cons cell")) (:circular "a circular list")) c))) (defmethod part-count ((c cons)) (ecase (cons-construct-kind c) (:proper (length c)) (:improper (loop for cell on c and i = 1 then (1+ i) while (consp (cdr cell)) finally (return i))) (:circular (let ((seen (make-hash-table))) (loop for cell on c and i = 0 then (1+ i) until (gethash cell seen) do (setf (gethash cell seen) t) finally (return i)))))) (defmethod print-parts ((c cons) &key first last) (let* ((length (part-count c)) (first (or first 0)) (last (or last length))) (ecase (cons-construct-kind c) (:proper (loop for cell on (nthcdr first c) and i from first below last do (format t "~& [~D]~10,4T: ~S" i (car cell)))) (:improper (cond ((consp (cdr c)) (loop for cell on (nthcdr (min first (1- length)) c) and i from first below last do (format t "~& [~D]~20,4T: ~S" i (car cell)) (unless (consp (cdr cell)) (format t "~& [~D] last cdr~20,4T: ~S" (+ i (cdrbase length)) (cdr cell)) (return)))) (t ; single cons cell (format t "~& [0] car : ~S~% [1] cdr : ~S" (car c) (cdr c))))) (:circular (let ((printed-cells (make-hash-table))) (loop for cell on (nthcdr first c) and i = first then (1+ i) while (<= i last) do (let ((pos (gethash cell printed-cells))) (cond ((null pos) (setf (gethash cell printed-cells) i) (format t "~& [~D]~20,4T: ~S" i (car cell))) (t (format t "~& [~D] last cdr~20,4T-> cell #~D" (+ (cdrbase length) (1- length)) pos) (return)))))))))) (defmethod part-ref ((c cons) (ref integer)) (let* ((length (part-count c)) (cdr-ref (- ref (cdrbase length)))) (cond ((< -1 ref length) (nth ref c)) ((< -1 cdr-ref length) (nthcdr (1+ cdr-ref) c)) (t (error 'part-ref-error))))) (defmethod part-set ((c cons) (ref integer) value) (let* ((length (part-count c)) (cdr-ref (- ref (cdrbase length)))) (cond ((< -1 ref length) (setf (nth ref c) value)) ((< -1 cdr-ref length) (rplacd (nthcdr cdr-ref c) value)) (t (error 'part-ref-error))))) (defmethod reference-explanation ((c cons) ref) (let* ((length (part-count c)) (cdr-ref (- ref (cdrbase length)))) (if (< -1 cdr-ref length) (format nil "CDR of cell ~D" cdr-ref) (call-next-method)))) (defmethod help-on-commands ((c cons)) (call-next-method) (format t "~% If CAR of a cell is accessible at index N, CDR is accessible at index 1N.~%")) ;;; ====== ;;; ARRAYS ;;; ====== (defmethod print-blurb ((a array)) (format t "a ~A array of ~A ~S" (array-dimensions a) (array-element-type a) a)) (defmethod part-count ((a array)) (array-total-size a)) (defmethod print-parts ((a array) &key first last) (loop for i from (or first 0) below (or last (part-count a)) do (format t " [~D] ~S ~10,5T: ~S~%" i (array-subscripts a i) (row-major-aref a i)))) (defmethod part-ref ((a array) index) (handler-case (row-major-aref a index) (error () (error 'part-ref-error)))) (defmethod part-set ((a array) index value) (handler-case (setf (row-major-aref a index) value) (error () (error 'part-ref-error)))) (defmethod reference-explanation ((a array) ref) (format nil "element ~S" (array-subscripts a ref))) (defun array-subscripts (a index) "Answer a list of integers which is the translation of INDEX into row-major array subscripts for the array A." (labels ((subs (dims partial-i) (if (null dims) '() (let* ((dim (car dims)) (i (mod partial-i dim)) (rest (floor (/ partial-i dim)))) (cons i (subs (cdr dims) rest)))))) (nreverse (subs (nreverse (array-dimensions a)) index)))) ;;; =================== ;;; VECTORS AND STRINGS ;;; =================== ;;; ;;; We just want to print their description and parts differently from arrays, ;;; the rest is taken care of by less specific methods on ARRAYs. (defmethod print-blurb ((v vector)) (format t "a vector (~D) ~S" (length v) v)) (defmethod print-blurb ((s string)) (format t "a string (~D) ~S" (length s) s)) (defmethod print-parts ((v vector) &key first last) (loop for i from (or first 0) below (or last (length v)) do (format t "~& [~D]~8T: ~S~%" i (aref v i)))) (defmethod reference-explanation ((v vector) ref) (format nil "element ~S" ref)) ;;; =========== ;;; HASH TABLES ;;; =========== ;;; ;;; We assume that MAPHASH always iterates through the entries in same order, ;;; provided the table has not been changed. The spec does not seem to ;;; guarantee this but it sounds as a reasonable assumption. (defmethod print-blurb ((ht hash-table)) (format t "a hash table ~S" ht)) (defmethod part-count ((ht hash-table)) (hash-table-count ht)) (defmethod print-parts ((ht hash-table) &key first last) (let ((first (or first 0)) (last (or last (hash-table-count ht))) (i 0)) (maphash #'(lambda (key value) (when (<= first i (1- last)) (format t "~& [~D] ~S : ~S" i key value)) (incf i)) ht))) (defun funcall-with-hash-entry (fun ht index) "Invoke FUN with key and value of the INDEXth element (so to say) of the hash table HT." (let ((i 0)) (maphash #'(lambda (key value) (when (= i index) (return-from funcall-with-hash-entry (funcall fun key value))) (incf i)) ht)) (error 'part-ref-error)) (defmethod part-ref ((ht hash-table) index) (funcall-with-hash-entry #'(lambda (key value) (declare (ignore key)) value) ht index)) (defmethod part-set ((ht hash-table) index value) (funcall-with-hash-entry #'(lambda (key v) (declare (ignore v)) (setf (gethash key ht) value)) ht index)) (defmethod reference-explanation ((ht hash-table) index) (funcall-with-hash-entry #'(lambda (key value) (declare (ignore value)) (format nil "value at key ~S" key)) ht index)) ;;; ======== ;;; PACKAGES ;;; ======== (defmethod print-blurb ((p package)) (format t "a package ~S" p)) (defmethod print-parts ((p package) &key first last) (declare (ignore first last)) (format t "~& [0] name : ~A~ ~& [1] nicknames : ~S~ ~& [2] uses : ~S~ ~& [3] used by : ~S~ ~& [4] external : ~S~ ~& [5] present : ~S~ ~& [6] shadowing : ~S~%" (package-name p) (package-nicknames p) (package-use-list p) (package-used-by-list p) (loop for s being each external-symbol of p collect s) (loop for s being each present-symbol of p collect s) (package-shadowing-symbols p))) (defmethod part-ref ((p package) index) (case index (0 (package-name p)) (1 (package-nicknames p)) (2 (package-use-list p)) (3 (package-used-by-list p)) (4 (sort (loop for s being each external-symbol of p collect s) #'symbol<)) (5 (sort (loop for s being each present-symbol of p collect s) #'symbol<)) (6 (sort (package-shadowing-symbols p) #'symbol<)) (t (error 'part-ref-error)))) (defmethod part-set ((p package) index value) (case index (0 (rename-package p value)) (t (error 'part-ref-error)))) (defmethod reference-explanation ((p package) index) (ecase index (0 "name") (1 "nickname list") (2 "uses list") (3 "used-by list") (4 "external symbols list") (5 "present symbols list") (6 "shadowing symbols list"))) ;;; ============================= ;;; CLOS INSTANCES AND STRUCTURES ;;; ============================= ;;; ;;; This whole section requires MOP or CLOS as implemented in CLISP so if this ;;; is not the case, instances and structures are shown as atomic (bummer). ;;; PCL below would better be MOP but MOP does not seem to be a standard ;;; *feature*, so watch out. #+(OR CLISP PCL) (progn ;; The workhorse: a dumb interface to slots, works for both CLOS instances and ;; structures. Methods specializing on them simply dispatch to these ;; functions. OBJECT argument is a general instance of either STANDARD-OBJECT ;; or STRUCTURE-OBJECT. (defun %slots-of-instance (object) (sort #+(AND CLISP (NOT PCL)) (loop for name being each hash-key of (class-slot-location-table (class-of object)) collect name) #+PCL (mapcar #'slot-definition-name (class-slots (class-of object))) #'symbol<)) (defun %instance-part-count (object) (length (%slots-of-instance object))) (defun %instance-print-parts (object &key first last) (let ((first (or first 0)) (last (or last (%instance-part-count object)))) (loop for slot in (%slots-of-instance object) and i = 0 then (1+ i) when (<= first i (1- last)) do (format t "~& [~D] ~(~A~)~28,8T: ~:[~A~;~S~]" i slot (slot-boundp object slot) (handler-case (slot-value object slot) (error () "")))))) (defun %instance-part-ref (object index) (let ((slots (%slots-of-instance object))) (unless (< -1 index (length slots)) (error 'part-ref-error)) (handler-case (slot-value object (nth index slots)) (error () (signal 'part-ref-error))))) (defun %instance-part-set (object index value) (let ((slots (%slots-of-instance object))) (unless (< -1 index (length slots)) (error 'part-ref-error)) (setf (slot-value object (nth index slots)) value))) (defun %instance-reference-explanation (object index) (let ((slots (%slots-of-instance object))) (unless (< -1 index (length slots)) (error 'part-ref-error)) (format nil "value of slot ~A" (nth index slots)))) (declaim (inline %instance-part-count %instance-print-parts %instance-part-ref %instance-part-set %instance-reference-explanation)) ;; Now we can take care of CLOS instances and structure objects. (defmethod print-blurb ((o standard-object)) (format t "an instance of ~A" (class-name (class-of o)))) (defmethod print-blurb ((o structure-object)) (format t "a structure ~A" (symbol-name (type-of o)))) (defmethod part-count ((o standard-object)) (%instance-part-count o)) (defmethod part-count ((o structure-object)) (%instance-part-count o)) (defmethod print-parts ((obj standard-object) &key first last) (%instance-print-parts obj :first first :last last)) (defmethod print-parts ((obj structure-object) &key first last) (%instance-print-parts obj :first first :last last)) (defmethod part-ref ((o standard-object) index) (%instance-part-ref o index)) (defmethod part-ref ((o structure-object) index) (%instance-part-ref o index)) (defmethod part-set ((o standard-object) index value) (%instance-part-set o index value)) (defmethod part-set ((o structure-object) index value) (%instance-part-set o index value)) (defmethod reference-explanation ((o standard-object) index) (%instance-reference-explanation o index)) (defmethod reference-explanation ((o structure-object) index) (%instance-reference-explanation o index)) ) ; #+(OR CLISP PCL) ;;; ==================== ;;; EXTRA TOYS FOR CMUCL ;;; ==================== ;;; ;;; Packages and hash tables in CMUCL are structure objects. However, because ;;; STRUCTURE-OBJECT is less specific than PACKAGE or HASHTABLE, we cannot see ;;; their "internals". The following allows us to switch between "external" ;;; and "internal" views of packages and hash tables using V. #+CMU (progn (defclass instance-revealing-wrapper (wrapper) ()) (defmethod print-blurb ((o instance-revealing-wrapper)) (let ((o (unwrap o))) (format t "a ~A ~S" (class-name (class-of o)) o))) (defmethod part-count ((o instance-revealing-wrapper)) (%instance-part-count (unwrap o))) (defmethod print-parts ((o instance-revealing-wrapper) &key first last) (%instance-print-parts (unwrap o) :first first :last last)) (defmethod part-ref ((o instance-revealing-wrapper) index) (%instance-part-ref (unwrap o) index)) (defmethod part-set ((o instance-revealing-wrapper) index value) (%instance-part-set (unwrap o) index value)) (defmethod reference-explanation ((o instance-revealing-wrapper) index) (%instance-reference-explanation (unwrap o) index)) ;; This is the mode switching machinery (declare-as-mode-switcher package) (declare-as-mode-switcher hash-table) (defun reveal-top-object () (let ((top (unwrap* (top-object))) (topref (top-reference))) (pop-stacks) (push-object (make-instance 'instance-revealing-wrapper :contents top) topref))) (defmethod perform-command ((o package) (cmd (eql 'V)) args) (declare (ignore o cmd args)) (reveal-top-object)) (defmethod perform-command ((o hash-table) (cmd (eql 'V)) args) (declare (ignore o cmd args)) (reveal-top-object)) (defmethod perform-command ((o instance-revealing-wrapper) (cmd (eql 'V)) a) (declare (ignore o cmd a)) (let ((top (unwrap* (top-object))) (topref (top-reference))) (pop-stacks) (push-object (wrap-for-inspection top) topref))) (defun explain-view-mode-switch () (format t "~3TV ~15T- switch the view mode.~%")) (defmethod help-on-commands :after ((o package)) (declare (ignore o)) (explain-view-mode-switch)) (defmethod help-on-commands :after ((o hash-table)) (declare (ignore o)) (explain-view-mode-switch)) ) ; #+CMUCL (progn ;;; end of inspect.lsp #| ========================================================================== INSPECTOR TUTORIAL A commented sample interaction transcript. Should probably go from here into a file in Docs/Tutorials directory. (in CLISP, in CMUCL the package would be COMMON-LISP-USER). > (setq quux '(1 2 3 (foo bar baz))) (1 2 3 (FOO BAR BAZ)) > (inspect 'quux) Entering inspector loop, ? for a list of commands. a symbol QUUX [0] name : "QUUX" [1] value : (1 2 3 (FOO BAR BAZ)) [2] function : [3] plist : NIL [4] package : # 1.1 Inspect> We get a short description of the object ("a symbol ..."), a list of its _slots_, if any, and an inspector prompt. Numbers in front of the prompt show the current recursive inspector invocation and the current inspection depth (how many levels we have gone down from the original object). Both are initially 1. Slots are not necessarily slots in the sense used for structures and CLOS objects. Elements of an array, cells of a CONS, cells of symbols are all slots as well. Numbers in square brackets in the list of object slots can be used to descend into those slots. We try to descend into the slot 1 of the symbol we see: its value cell. 1.1 Inspect> 1 a proper list (1 2 3 (FOO BAR BAZ)) [0] : 1 [1] : 2 [2] : 3 [3] : (FOO BAR BAZ) 1.2 Inspect> Now the current object is the list found in the value cell of the symbol we first inspected. Note that the inspection depth is now 2. The original symbol we inspected is remembered as the _parent_ of the object we are inspecting now. We can descend into objects as many times as we want. 1.2 Inspect> 2 a fixnum 3 1.3 Inspect> We "dove" once more. The current object is the element of the previous list. It has no parts; we cannot dive any deeper. However, we may dive out of the current object to its parent: 1.3 Inspect> u a proper list (1 2 3 #) [0] : 1 [1] : 2 [2] : 3 [3] : (FOO BAR BAZ) 1.2 Inspect> We are back at depth 2. We may dive again into another element 1.2 Inspect> 3 a proper list (FOO BAR BAZ) [0] : FOO [1] : BAR [2] : BAZ 1.3 Inspect> 0 a symbol FOO [0] name : "FOO" [1] value : [2] function : [3] plist : |NIL| [4] package : # 1.4 Inspect> We went into a sublist of the original list, and then into its first element which is a symbol. Suppose that after seeing the symbol's details we want to inspect the second element of the parent list. We might have gone one level up and then choose element 1 but there is a convenient shortcut. 'N' moves to the next selectable part of the parent of the current object, 'P' - to the previous one. 1.4 Inspect> n a symbol BAR [0] name : "BAR" [1] value : [2] function : [3] plist : NIL [4] package : # 1.4 Inspect> Note that we stay at depth 4. After some traveling up, down, and sideways we might get confused about what we are currently looking at. 'W' (Where) shows a nice readable explanation of the objects we are inspecting: 1.4 Inspect> 0 a string of length 3 "BAR" [0] : #\B [1] : #\A [2] : #\R 1.5 Inspect> 2 a character #\R 1.6 Inspect> p a character #\A 1.6 Inspect> w Currently looking at a character #\A which is the element 1 of a string (3) "BAR" which is the name of a symbol BAR which is the element 1 of a proper list (FOO BAR BAZ) which is the element 3 of a proper list (1 2 3 (FOO BAR BAZ)) which is the value cell of a symbol QUUX 1.6 Inspect> Now that we have seen enough of the object structure, suppose we want to go to the value of the original symbol and perform some surgery on its value list. Instead of doing 'U' many times, we may "reset" to the top directly and then go down to the value cell. 1.6 Inspect> t a symbol QUUX [0] name : "QUUX" [1] value : (1 2 3 (FOO BAR BAZ)) [2] function : [3] plist : NIL [4] package : # 1.1 Inspect> 1 a proper list (1 2 3 (FOO BAR BAZ)) [0] : 1 [1] : 2 [2] : 3 [3] : (FOO BAR BAZ) 1.2 Inspect> To set a slot value, type its number followed by an arbitrary Lisp expression. The slot will be set (if it is settable) to the value of the expression. 1.2 Inspect> 0 100 a proper list (100 2 3 #) [0] : 100 [1] : 2 [2] : 3 [3] : (FOO BAR BAZ) 1.2 Inspect> 3 (* 45 67) a proper list (100 2 3 3015) [0] : 100 [1] : 2 [2] : 3 [3] : 3015 1.2 Inspect> Of course, it is possible to evaluate a Lisp expression without assigning it to a slot. Type 'E' followed by a Lisp expression to evaluate. If the form is a list (quite often), 'E' is not necessary: no other inspector commands are lists, so the inspector assumes you want to evaluate it. 1.2 Inspect> e quux (100 2 3 3015) 1.2 Inspect> (append quux '(5 6 7)) (100 2 3 3015 5 6 7) 1.2 Inspect> In the expressions, you can conveniently refer to the inspected object or its slots using $ notation. ($) means the inspected object, ($ 1) - slot 1 of that object, etc. You may also go up the inspector stack using this notation: ($ ()) means the parent of the current object, ($ (2)) - slot 2 of the parent, etc. Finally, $ by itself may be used instead of ($) to refer to the current object. 1.2 Inspect> e $ (100 2 3 3015) 1.2 Inspect> ($) (100 2 3 3015) 1.2 Inspect> ($ 3) 3015 1.2 Inspect> ($ ()) QUUX 1.2 Inspect> ($ (4)) # 1.2 Inspect> Note that invoking destructive list functions such as NREVERSE on the list being inspected may yield strange results. (Nothing terrible, just the inspector will keep inspecting the original "head" cons while the original list structure *might* be modified in *some* way). Besides simply evaluating an expression, you can enter a recursive inspector on its result using 'I ' command. The inspector will use the result of the expression as its initial object; quitting the recursive inspector will return you to the original one. 1.2 Inspect> i (package-name ($ (4))) "USER" Entering inspector loop, ? for a list of commands. a string of length 4 "USER" [0] : #\U [1] : #\S [2] : #\E [3] : #\R 2.1 Inspect> Note that the new prompt shows 2 as the recursion level and 1 as the inspection depth. Now as soon as we want to go back to the outer inspector... 2.1 Inspect> q a proper list (100 2 3 3015) [0] : 100 [1] : 2 [2] : 3 [3] : 3015 1.2 Inspect> ...and we are back to where we were. Of course, setting slot values is also possible for many other objects, not only lists. Lists, however, allow some advanced surgery as well. In addition to slots you see in the slot list (0..3 in our example) each list also allows to use same slot numbers with 1 prepended to refer to CDR locations of the corresponding cells. In the list we inspect, "implicit" slot 10 means CDR of the first cell, 13 - CDR of the last cell. 1.2 Inspect> ($ 10) (2 3 3015) Here we accessed slot 10 of the current object which appeared to be the same as (cdr $) would be. We can use these CDR slots in set operations to do strange and wondrous things to the list: 1.2 Inspect> 13 55555 an improper list (100 2 3 3015 . 55555) [0] : 100 [1] : 2 [2] : 3 [3] : 3015 [13] last cdr : 55555 1.2 Inspect> 13 (cdr $) Here we have just set CDR of the last cell, turning the list into an improper one. Note that for improper lists, the last "implicit" slot is printed explicitly. Now let's make the list circular instead. 1.2 Inspect> 13 ($ 10) a circular list (100 . #1=#) [0] : 100 [1] : 2 [2] : 3 [3] : 3015 [13] last cdr -> cell #1 1.2 Inspect> We have placed the value of "slot" 10 (that is, CDR of the first cons cell of the list) into the CDR of the last cell, this making the list turn back onto its second (#1) cell. NOTE: if you quit the inspector at this moment, your Lisp may go into an endless loop! The value of a call to INSPECT is the last object you were "looking at", in this case circular list. If the toplevel printer was not configured to print circular cons structures, it will loop trying to print the result. Let's return the list back to normal before quitting. 1.2 Inspect> 13 nil a proper list (100 2 3 3015) [0] : 100 [1] : 2 [2] : 3 [3] : 3015 1.2 Inspect> q (100 2 3 3015) > The value returned from INSPECT is the object that was being inspected at the time you quit. > quux (100 2 3 3015) > |# ;;; EOF