summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-10-03 23:09:32 +0200
committerAndy Wingo <wingo@pobox.com>2010-10-03 23:09:32 +0200
commit6e197f3d1af34cffef0b285f655b84d2d63bbdeb (patch)
treee18a1390f19e9a187a047ed37fa72a460e4b8e19
parent6e1dccc42f9ec81e04524ccc0956c692ee423576 (diff)
downloadguile-6e197f3d1af34cffef0b285f655b84d2d63bbdeb.tar.gz
avoid some double-breaks in trap-at-procedure-ip-in-range
* 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.
-rw-r--r--module/system/vm/traps.scm28
1 files changed, 22 insertions, 6 deletions
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 7abe45396..3b2a43875 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -278,15 +278,31 @@
(arg-check proc procedure?)
(arg-check range range?)
(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)
- (let ((now-in-range? (in-range? range (frame-instruction-pointer frame))))
- (cond
- (was-in-range? (set! was-in-range? now-in-range?))
- (now-in-range? (handler frame) (set! was-in-range? #t)))))
+ (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
+ (was-in-range?
+ (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)
- (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
#:current-frame current-frame #:vm vm