mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

avoid some double-breaks in trap-at-procedure-ip-in-range

Browse source 
* module/system/vm/traps.scm (trap-at-procedure-ip-in-range): Rework not
  to call the handler when returning to a frame that was already
  entered. So now breaking at foo.scm:1234 doesn't break when returning
  to that line.
This commit is contained in:
Andy Wingo 2010-10-03 23:09:32 +02:00
parent 6e1dccc42f
commit 6e197f3d1a
1 changed files with 22 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

26
module/system/vm/traps.scm
View file

@ -278,15 +278,31 @@
(arg-check proc procedure?) (arg-check proc procedure?)
(arg-check range range?) (arg-check range range?)
(arg-check handler procedure?) (arg-check handler procedure?)
(let ((was-in-range? #f)) (let ((fp-stack '()))
(define (cull-frames! fp)
(let lp ((frames fp-stack))
(if (and (pair? frames) (< (car frames) fp))
(lp (cdr frames))
(set! fp-stack frames))))
(define (next-handler frame) (define (next-handler frame)
(let ((now-in-range? (in-range? range (frame-instruction-pointer frame)))) (let ((fp (frame-address frame))
(ip (frame-instruction-pointer frame)))
(cull-frames! fp)
(let ((now-in-range? (in-range? range ip))
(was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
(cond (cond
(was-in-range? (set! was-in-range? now-in-range?)) (was-in-range?
(now-in-range? (handler frame) (set! was-in-range? #t))))) (if (not now-in-range?)
(set! fp-stack (cdr fp-stack))))
(now-in-range?
(set! fp-stack (cons fp fp-stack))
(handler frame))))))
(define (exit-handler frame) (define (exit-handler frame)
(set! was-in-range? #f)) (if (and (pair? fp-stack)
(= (car fp-stack) (frame-address frame)))
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler (trap-instructions-in-procedure proc next-handler exit-handler
#:current-frame current-frame #:vm vm #:current-frame current-frame #:vm vm