Skip to content
Browse files

(find-top-frame): New function used to hide debugger internal frames.

(call-with-debugging-environment): Use it.
  • Loading branch information...
1 parent a8fad51 commit f18968b230835a2195449fab584b27ef54bbeee9 Helmut Eller committed May 1, 2004
Showing with 21 additions and 12 deletions.
  1. +21 −12 swank-lispworks.lisp
View
33 swank-lispworks.lisp
@@ -178,15 +178,6 @@ Return NIL if the symbol is unbound."
(defvar *sldb-top-frame*)
-(defimplementation call-with-debugging-environment (fn)
- (dbg::with-debugger-stack ()
- (let ((*sldb-top-frame*
- (dbg::frame-next
- (dbg::frame-next
- (dbg::frame-next
- (dbg::debugger-stack-current-frame dbg::*debugger-stack*))))))
- (funcall fn))))
-
(defun interesting-frame-p (frame)
(cond ((or (dbg::call-frame-p frame)
(dbg::derived-call-frame-p frame)
@@ -200,12 +191,30 @@ Return NIL if the symbol is unbound."
((dbg::open-frame-p frame) dbg:*print-open-frames*)
(t nil)))
-(defun nth-frame (index)
- (do ((frame *sldb-top-frame* (dbg::frame-next frame))
- (i index (if (interesting-frame-p frame) (1- i) i)))
+(defun nth-next-frame (frame n)
+ "Unwind FRAME N times."
+ (do ((frame frame (dbg::frame-next frame))
+ (i n (if (interesting-frame-p frame) (1- i) i)))
((and (interesting-frame-p frame) (zerop i)) frame)
(assert frame)))
+(defun nth-frame (index)
+ (nth-next-frame *sldb-top-frame* index))
+
+(defun find-top-frame ()
+ "Return the most suitable top-frame for the debugger."
+ (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
+ (nth-next-frame frame 1)))
+ ((and (dbg::call-frame-p frame)
+ (eq (dbg::call-frame-function-name frame)
+ 'invoke-debugger))
+ (nth-next-frame frame 1))))
+
+(defimplementation call-with-debugging-environment (fn)
+ (dbg::with-debugger-stack ()
+ (let ((*sldb-top-frame* (find-top-frame)))
+ (funcall fn))))
+
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum))
(backtrace '()))

0 comments on commit f18968b

Please sign in to comment.
Something went wrong with that request. Please try again.