[slime-devel] inspect, eval-in-frame, inspect-in-frame for openmcl

[Alan Ruttenberg]

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.~%")))))))