[slime-cvs] CVS slime

[gcarncross]

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

Modified Files:
	swank-ecl.lisp 
Log Message:
Trim swank sources from the ECL backtrace.


--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/05/01 02:47:32	1.21
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/05/02 01:43:23	1.22
@@ -227,15 +227,31 @@
 (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)))
+  (and
+   (symbolp x)
+   (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))
+
+(defun is-swank-source-p (name)
+  (setf name (pathname name))
+  (pathname-match-p
+   name
+   (make-pathname :defaults swank-loader::*source-directory*
+                  :name (pathname-name name)
+                  :type (pathname-type name)
+                  :version (pathname-version name))))
+
+(defun is-ignorable-fun-p (x)
+  (or
+   (in-swank-package-p (frame-name x))
+   (multiple-value-bind (file position)
+       (ignore-errors (si::bc-file (car x)))
+     (declare (ignore position))
+     (if file (is-swank-source-p file)))))
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
@@ -257,7 +273,8 @@
                         (name (si::frs-tag f)))
                    (unless (fixnump name)
                      (push name (third x)))))))
-    (setf *backtrace* (remove-if #'in-swank-package-p (nreverse *backtrace*)))
+    (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+    (Setf *tmp* *backtrace*)
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))