[slime-cvs] CVS slime

[gcarncross]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12042

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
Backtrace and frame/eval improvements

--- /project/slime/cvsroot/slime/ChangeLog	2008/04/24 18:51:16	1.1349
+++ /project/slime/cvsroot/slime/ChangeLog	2008/04/30 02:10:49	1.1350
@@ -1,3 +1,7 @@
+2008-04-29  Geo Carncross  <geocar at gmail.com>
+
+	* swank-ecl.lisp: Backtrace and frame/eval improvements
+
 2008-04-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-backend.lisp: Clarified docstrings of interface functions
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/04/24 01:44:10	1.19
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/04/30 02:10:49	1.20
@@ -207,7 +207,8 @@
 ;;; Debugging
 
 (import
- '(si::*ihs-top*
+ '(si::*break-env*
+   si::*ihs-top*
    si::*ihs-current*
    si::*ihs-base*
    si::*frs-base*
@@ -216,11 +217,15 @@
    si::*tpl-level*
    si::frs-top
    si::ihs-top
+   si::ihs-fun
+   si::ihs-env
    si::sch-frs-base
    si::set-break-env
    si::set-current-ihs
    si::tpl-commands))
 
+(defvar *backtrace* '())
+
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*tpl-commands* si::tpl-commands)
@@ -229,27 +234,97 @@
 	 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
 	 (*frs-top* (frs-top))
 	 (*read-suppress* nil)
-	 (*tpl-level* (1+ *tpl-level*)))
+	 (*tpl-level* (1+ *tpl-level*))
+         (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
+                            collect (list (si::ihs-fun (1+ ihs))
+                                          (si::ihs-env ihs)
+                                          nil))))
+    (loop for f from *frs-base* until *frs-top*
+          do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+               (when (plusp i)
+                 (let* ((x (elt *backtrace* i))
+                        (name (si::frs-tag f)))
+                   (unless (fixnump name)
+                     (push name (third x)))))))
+    (setf *backtrace* (nreverse *backtrace*))
     (set-break-env)
     (set-current-ihs)
-    (funcall debugger-loop-fn)))
+    (let ((*ihs-base* *ihs-top*))
+      (funcall debugger-loop-fn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
+    (funcall fun)))
 
-;; (defimplementation call-with-debugger-hook (hook fun)
-;;   (let ((*debugger-hook* hook))
-;;     (funcall fun)))
-
-(defun nth-frame (n)
-  (cond ((>= n *ihs-top* ) nil)
-        (t (- *ihs-top*  n))))
-                                               
 (defimplementation compute-backtrace (start end)
-  (loop for i from start below end
-        for f = (nth-frame i)     
-        while f
-        collect f))
+  (when (numberp end)
+    (setf end (min end (length *backtrace*))))
+  (subseq *backtrace* start end))
+
+(defun frame-name (frame)
+  (let ((x (first frame)))
+    (if (symbolp x)
+      x
+      (function-name x))))
+
+(defun function-position (fun)
+  (multiple-value-bind (file position)
+      (si::bc-file fun)
+    (and file (make-location `(:file ,file) `(:position ,position)))))
+
+(defun frame-function (frame)
+  (let* ((x (first frame))
+         fun position)
+    (etypecase x
+      (symbol (and (fboundp x)
+                   (setf fun (fdefinition x)
+                         position (function-position fun))))
+      (function (setf fun x position (function-position x))))
+    (values fun position)))
+
+(defun frame-decode-env (frame)
+  (let ((functions '())
+        (blocks '())
+        (variables '()))
+    (dolist (record (second frame))
+      (let* ((record0 (car record))
+	     (record1 (cdr record)))
+	(cond ((symbolp record0)
+	       (setq variables (acons record0 record1 variables)))
+	      ((not (fixnump record0))
+	       (push record1 functions))
+	      ((symbolp record1)
+	       (push record1 blocks))
+	      (t
+	       ))))
+    (values functions blocks variables)))
 
 (defimplementation print-frame (frame stream)
-  (format stream "~A" (si::ihs-fname frame)))
+  (format stream "~A" (first frame)))
+
+(defimplementation frame-source-location-for-emacs (frame-number)
+  (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+  (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+  (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+        with i = 0
+        collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+  (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+       var-id))
+
+(defimplementation disassemble-frame (frame-number)
+  (let ((fun (frame-fun (elt *backtrace* frame-number))))
+    (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+  (let ((env (second (elt *backtrace* frame-number))))
+    (si:eval-with-env form env)))
 
 ;;;; Inspector
 
@@ -312,7 +387,7 @@
   (or
    (typecase obj
      (function
-      (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj))
+      (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
         (if (and file pos) 
             (make-location
               `(:file ,(namestring file))