[slime-cvs] CVS update: slime/swank-openmcl.lisp
Helmut Eller
heller at common-lisp.net
Sun Dec 14 08:24:21 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv7069
Modified Files:
swank-openmcl.lisp
Log Message:
Mega patch by Alan Ruttenberg. Implements eval-in-frame and inspector
support.
Date: Sun Dec 14 03:24:21 2003
Author: heller
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.34 slime/swank-openmcl.lisp:1.35
--- slime/swank-openmcl.lisp:1.34 Sun Dec 14 02:55:19 2003
+++ slime/swank-openmcl.lisp Sun Dec 14 03:24:21 2003
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.34 2003/12/14 07:55:19 heller Exp $
+;;; $Id: swank-openmcl.lisp,v 1.35 2003/12/14 08:24:21 heller Exp $
;;;
;;;
@@ -434,6 +434,27 @@
(defslimefun sldb-abort ()
(invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
+(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)))
+ ))))))
+
;;; Utilities
(defslimefun-unimplemented describe-setf-function (symbol-name))
@@ -489,3 +510,155 @@
;;; Macroexpansion
(defslimefun-unimplemented swank-macroexpand-all (string))
+
+
+;;;; Inspecting
+
+;;XXX refactor common code.
+
+(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 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.~%")))))))
+
More information about the slime-cvs
mailing list