[slime-cvs] CVS slime

[gcarncross]

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
Remove frames from the backtrace that are in a swank package as those are misleading. Fixup locals display.


--- /project/slime/cvsroot/slime/ChangeLog	2008/04/30 02:10:49	1.1350
+++ /project/slime/cvsroot/slime/ChangeLog	2008/05/01 02:47:32	1.1351
@@ -1,3 +1,10 @@
+2008-04-30  Geo Carncross  <geocar at geocar-laptop>
+
+	* swank-ecl.lisp (call-with-debugging-environment)
+	(in-swank-package-p): Remove frames from the backtrace that are
+	in a swank package as those are misleading. Fixup locals
+	display.
+
 2008-04-29  Geo Carncross  <geocar at gmail.com>
 
 	* swank-ecl.lisp: Backtrace and frame/eval improvements
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/04/30 02:10:49	1.20
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/05/01 02:47:32	1.21
@@ -226,6 +226,17 @@
 
 (defvar *backtrace* '())
 
+(defun in-swank-package-p (x)
+  (if (consp x) (setf x (frame-name x)))
+  (when (symbolp x)
+    (and
+     (member (symbol-package x)
+             (list #.(find-package :swank)
+                   #.(find-package :swank-backend)
+                   #.(ignore-errors (find-package :swank-mop))
+                   #.(ignore-errors (find-package :swank-loader))))
+     t)))
+
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*tpl-commands* si::tpl-commands)
@@ -236,7 +247,7 @@
 	 (*read-suppress* nil)
 	 (*tpl-level* (1+ *tpl-level*))
          (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
-                            collect (list (si::ihs-fun (1+ ihs))
+                            collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)
                                           nil))))
     (loop for f from *frs-base* until *frs-top*
@@ -246,7 +257,7 @@
                         (name (si::frs-tag f)))
                    (unless (fixnump name)
                      (push name (third x)))))))
-    (setf *backtrace* (nreverse *backtrace*))
+    (setf *backtrace* (remove-if #'in-swank-package-p (nreverse *backtrace*)))
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))