Most of this is copied from swank-cmucl. The parts between &&&&& are what I added for openmcl. I piggyback off the inspector which is shipped with openmcl, so inspecting won't look the same as it would in cmucl, I imagine. Still, it's a start. eval in frame uses frame-locals to get bindings so if you have debug settings low or don't have *save-local-symbols* set you won't be able to evaluate.
-Alan
(in-package :swank)
;;;; Inspecting
(defvar *inspectee*) (defvar *inspectee-parts*) (defvar *inspector-stack* '()) (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) (defvar *inspect-length* 30)
(defun reset-inspector () (setq *inspectee* nil) (setq *inspectee-parts* nil) (setq *inspector-stack* nil) (setf (fill-pointer *inspector-history*) 0))
(defslimefun init-inspector (string) (reset-inspector) (inspect-object (eval (from-string string))))
(defun print-part-to-string (value) (let ((*print-pretty* nil)) (let ((string (to-string value)) (pos (position value *inspector-history*))) (if pos (format nil "#~D=~A" pos string) string))))
(defun inspect-object (object) (push (setq *inspectee* object) *inspector-stack*) (unless (find object *inspector-history*) (vector-push-extend object *inspector-history*)) (multiple-value-bind (text parts) (inspected-parts object) (setq *inspectee-parts* parts) (list :text text :type (to-string (type-of object)) :primitive-type (describe-primitive-type object) :parts (loop for (label . value) in parts collect (cons label (print-part-to-string value))))))
(defun nth-part (index) (cdr (nth index *inspectee-parts*)))
(defslimefun inspect-nth-part (index) (inspect-object (nth-part index)))
(defslimefun inspector-pop () "Drop the inspector stack and inspect the second element. Return nil if there's no second element." (cond ((cdr *inspector-stack*) (pop *inspector-stack*) (inspect-object (pop *inspector-stack*))) (t nil)))
(defslimefun inspector-next () "Inspect the next element in the *inspector-history*." (let ((position (position *inspectee* *inspector-history*))) (cond ((= (1+ position) (length *inspector-history*)) nil) (t (inspect-object (aref *inspector-history* (1+ position)))))))
(defslimefun quit-inspector () (reset-inspector) nil)
(defslimefun describe-inspectee () "Describe the currently inspected object." (print-description-to-string *inspectee*))
(defgeneric inspected-parts (object) (:documentation "Return a short description and a list of (label . value) pairs."))
;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ; specific to openmcl
(defvar *value2tag* (make-hash-table))
(do-symbols (s (find-package 'arch)) (if (and (> (length (symbol-name s)) 7) (string= (symbol-name s) "SUBTAG-" :end1 7) (boundp s) (numberp (symbol-value s)) (< (symbol-value s) 255)) (setf (gethash (symbol-value s) *value2tag*) s)))
(defun describe-primitive-type (thing) (let ((typecode (ccl::typecode thing))) (if (gethash typecode *value2tag*) (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
(defmethod inspected-parts (o) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) (lines (loop for l below count for (value label) = (multiple-value-list (inspector::line-n i l)) collect (cons (string-right-trim " :" (string-capitalize (format nil "~a" label))) value)))) (values (string-left-trim (string #\newline) (with-output-to-string (s) (let ((*print-lines* 1) (*print-right-margin* 80)) (pprint o s)))) (cddr lines))))
(defslimefun eval-in-frame (form index) (map-backtrace #'(lambda (frame-number p tcr lfun pc) (when (= frame-number index) (multiple-value-bind (count vsp parent-vsp) (ccl::count-values-in-frame p tcr) (let ((bindings nil)) (dotimes (i count) (multiple-value-bind (var type name) (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) (declare (ignore type)) (when name (push (list name `',var) bindings)) )) (return-from eval-in-frame (eval `(let ,bindings (Declare (ccl::ignore-if-unused ,@(mapcar 'car bindings))) ,form))) ))))))
(defslimefun inspect-in-frame (string index) (reset-inspector) (inspect-object (eval-in-frame (from-string string) index))) ;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
(defmethod inspected-parts ((object cons)) (if (consp (cdr object)) (inspected-parts-of-nontrivial-list object) (inspected-parts-of-simple-cons object)))
(defun inspected-parts-of-simple-cons (object) (values "The object is a CONS." (list (cons (string 'car) (car object)) (cons (string 'cdr) (cdr object)))))
(defun inspected-parts-of-nontrivial-list (object) (let ((length 0) (in-list object) (reversed-elements nil)) (flet ((done (description-format) (return-from inspected-parts-of-nontrivial-list (values (format nil description-format length) (nreverse reversed-elements))))) (loop (cond ((null in-list) (done "The object is a proper list of length ~S.~%")) ((>= length *inspect-length*) (push (cons (string 'rest) in-list) reversed-elements) (done "The object is a long list (more than ~S elements).~%")) ((consp in-list) (push (cons (format nil "~D" length) (pop in-list)) reversed-elements) (incf length)) (t (push (cons (string 'rest) in-list) reversed-elements) (done "The object is an improper list of length ~S.~%")))))))