40 |
|
|
41 |
;;; This module defines useful kinds of behaviour for breakpoints. |
;;; This module defines useful kinds of behaviour for breakpoints. |
42 |
|
|
43 |
|
(define *trap* #f) |
44 |
(define *cont* #f) |
(define *cont* #f) |
45 |
(define *frame* #f) |
(define *frame* #f) |
46 |
(define *depth* #f) |
(define *depth* #f) |
54 |
(add-hook! before-enter-frame-hook |
(add-hook! before-enter-frame-hook |
55 |
(lambda (cont tail? expr) |
(lambda (cont tail? expr) |
56 |
(trc 'before-enter-frame-hook cont tail? expr) |
(trc 'before-enter-frame-hook cont tail? expr) |
57 |
|
(set! *trap* #:evaluation) |
58 |
(set! *cont* cont) |
(set! *cont* cont) |
59 |
(set! *frame* (last-stack-frame cont)) |
(set! *frame* (last-stack-frame cont)) |
60 |
(set! *depth* (stack-length (make-stack cont))) |
(set! *depth* (stack-length (make-stack cont))) |
66 |
(add-hook! before-apply-frame-hook |
(add-hook! before-apply-frame-hook |
67 |
(lambda (cont tail?) |
(lambda (cont tail?) |
68 |
(trc 'before-apply-frame-hook cont tail?) |
(trc 'before-apply-frame-hook cont tail?) |
69 |
|
(set! *trap* #:application) |
70 |
(set! *cont* cont) |
(set! *cont* cont) |
71 |
(set! *frame* (last-stack-frame cont)) |
(set! *frame* (last-stack-frame cont)) |
72 |
(set! *depth* (stack-length (make-stack cont))) |
(set! *depth* (stack-length (make-stack cont))) |
78 |
(add-hook! before-exit-frame-hook |
(add-hook! before-exit-frame-hook |
79 |
(lambda (cont retval) |
(lambda (cont retval) |
80 |
(trc 'before-exit-frame-hook cont retval) |
(trc 'before-exit-frame-hook cont retval) |
81 |
|
(set! *trap* #:return) |
82 |
(set! *cont* cont) |
(set! *cont* cont) |
83 |
(set! *frame* (last-stack-frame cont)) |
(set! *frame* (last-stack-frame cont)) |
84 |
(set! *depth* (stack-length (make-stack cont))) |
(set! *depth* (stack-length (make-stack cont))) |
91 |
|
|
92 |
(define (debug-if-flag-set) |
(define (debug-if-flag-set) |
93 |
(if *debug-flag* |
(if *debug-flag* |
94 |
(begin |
(let ((ds-flags (cons #:continuable |
95 |
|
(if (eq? *trap* #:return) |
96 |
|
(list *trap* *retval*) |
97 |
|
(list *trap*))))) |
98 |
(for-each (lambda (msg) |
(for-each (lambda (msg) |
99 |
(display msg (debugger-output-port))) |
(display msg (debugger-output-port))) |
100 |
(reverse! *debug-entry-messages*)) |
(reverse! *debug-entry-messages*)) |
101 |
(set! *debug-entry-messages* '()) |
(set! *debug-entry-messages* '()) |
102 |
(debug-stack (make-stack *cont*) #:continuable)))) |
(apply debug-stack (make-stack *cont*) ds-flags)))) |
103 |
|
|
104 |
(add-hook! after-enter-frame-hook debug-if-flag-set) |
(add-hook! after-enter-frame-hook debug-if-flag-set) |
105 |
|
|
184 |
(thunk)))))) |
(thunk)))))) |
185 |
(add-apply-frame-hook! apply))) |
(add-apply-frame-hook! apply))) |
186 |
|
|
187 |
;;; at-step [COUNT [THUNK]] |
;;; at-step [COUNT [THUNK [FILENAME]]] |
188 |
;;; |
;;; |
189 |
;;; Install a thunk to run when we get to the COUNT'th next |
;;; Install THUNK to run on the COUNT'th next application, frame entry |
190 |
;;; application or frame entry. COUNT defaults to 1; THUNK defaults |
;;; or frame exit. COUNT defaults to 1; THUNK defaults to debug-here. |
191 |
;;; to debug-here. |
;;; If FILENAME is specified and not #f, only frames that begin in the |
192 |
|
;;; named file are counted. |
193 |
|
|
194 |
(define* (at-step #:optional count thunk) |
(define* (at-step #:optional count thunk filename) |
195 |
(or count (set! count 1)) |
(or count (set! count 1)) |
196 |
(or thunk (set! thunk debug-here)) |
(or thunk (set! thunk debug-here)) |
197 |
(letrec ((step (lambda () |
(letrec ((proc (lambda () |
198 |
|
;; Behaviour whenever we enter or exit a frame. |
199 |
(set! count (- count 1)) |
(set! count (- count 1)) |
200 |
(if (<= count 0) |
(if (= count 0) |
201 |
(begin |
(begin |
202 |
(remove-enter-frame-hook! step) |
(remove-enter-frame-hook! step) |
203 |
(remove-apply-frame-hook! step) |
(remove-apply-frame-hook! step) |
204 |
(thunk)))))) |
(thunk))))) |
205 |
|
(step (lambda () |
206 |
|
;; Behaviour on frame entry: both execute the above |
207 |
|
;; and install it as an exit hook. |
208 |
|
(if (or (not filename) |
209 |
|
(equal? (current-file-name) filename)) |
210 |
|
(begin |
211 |
|
(proc) |
212 |
|
(at-exit proc)))))) |
213 |
|
(at-exit proc) |
214 |
(add-enter-frame-hook! step) |
(add-enter-frame-hook! step) |
215 |
(add-apply-frame-hook! step))) |
(add-apply-frame-hook! step))) |
216 |
|
|
228 |
(and position (car position)))) |
(and position (car position)))) |
229 |
|
|
230 |
(define* (at-next #:optional count thunk) |
(define* (at-next #:optional count thunk) |
231 |
(or count (set! count 1)) |
(at-step count thunk (current-file-name))) |
|
(or thunk (set! thunk debug-here)) |
|
|
(let ((filename (current-file-name))) |
|
|
(if filename |
|
|
(letrec ((next (lambda () |
|
|
(if (equal? (current-file-name) filename) |
|
|
(begin |
|
|
(set! count (- count 1)) |
|
|
(if (<= count 0) |
|
|
(begin |
|
|
(remove-enter-frame-hook! next) |
|
|
(thunk)))))))) |
|
|
(add-enter-frame-hook! next)) |
|
|
(at-entry count thunk)))) |
|
232 |
|
|
233 |
;;; debug-here |
;;; debug-here |
234 |
;;; |
;;; |