/[slime]/slime/swank-lispworks.lisp
ViewVC logotype

Diff of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.40 by heller, Fri Apr 30 06:32:24 2004 UTC revision 1.41 by heller, Sat May 1 16:37:43 2004 UTC
# Line 178  Return NIL if the symbol is unbound." Line 178  Return NIL if the symbol is unbound."
178    
179  (defvar *sldb-top-frame*)  (defvar *sldb-top-frame*)
180    
 (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))))  
   
181  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
182    (cond ((or (dbg::call-frame-p frame)    (cond ((or (dbg::call-frame-p frame)
183               (dbg::derived-call-frame-p frame)               (dbg::derived-call-frame-p frame)
# Line 200  Return NIL if the symbol is unbound." Line 191  Return NIL if the symbol is unbound."
191          ((dbg::open-frame-p frame) dbg:*print-open-frames*)          ((dbg::open-frame-p frame) dbg:*print-open-frames*)
192          (t nil)))          (t nil)))
193    
194  (defun nth-frame (index)  (defun nth-next-frame (frame n)
195    (do ((frame *sldb-top-frame* (dbg::frame-next frame))    "Unwind FRAME N times."
196         (i index (if (interesting-frame-p frame) (1- i) i)))    (do ((frame frame (dbg::frame-next frame))
197           (i n (if (interesting-frame-p frame) (1- i) i)))
198        ((and (interesting-frame-p frame) (zerop i)) frame)        ((and (interesting-frame-p frame) (zerop i)) frame)
199      (assert frame)))      (assert frame)))
200    
201    (defun nth-frame (index)
202      (nth-next-frame *sldb-top-frame* index))
203    
204    (defun find-top-frame ()
205      "Return the most suitable top-frame for the debugger."
206      (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
207                  (nth-next-frame frame 1)))
208          ((and (dbg::call-frame-p frame)
209                (eq (dbg::call-frame-function-name frame)
210                    'invoke-debugger))
211           (nth-next-frame frame 1))))
212    
213    (defimplementation call-with-debugging-environment (fn)
214      (dbg::with-debugger-stack ()
215        (let ((*sldb-top-frame* (find-top-frame)))
216          (funcall fn))))
217    
218  (defimplementation compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
219    (let ((end (or end most-positive-fixnum))    (let ((end (or end most-positive-fixnum))
220          (backtrace '()))          (backtrace '()))

Legend:
Removed from v.1.40  
changed lines
  Added in v.1.41

  ViewVC Help
Powered by ViewVC 1.1.5