/[guile]/guile/guile-core/ice-9/debugger/behaviour.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/debugger/behaviour.scm

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

revision 1.3 by ossau, Thu Sep 25 20:29:24 2003 UTC revision 1.4 by ossau, Tue Nov 11 23:17:06 2003 UTC
# Line 40  Line 40 
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)
# Line 53  Line 54 
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)))
# Line 64  Line 66 
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)))
# Line 75  Line 78 
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)))
# Line 87  Line 91 
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    
# Line 177  Line 184 
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    
# Line 210  Line 228 
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  ;;;  ;;;

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26