ice-9/debugger/behaviour.scm

   1 ;;;; (ice-9 debugger behaviour) -- what to do when you hit a breakpoint
   2
   3 ;;; Copyright (C) 2002 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This program is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU General Public License as
   7 ;;; published by the Free Software Foundation; either version 2, or
   8 ;;; (at your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU General Public License
  16 ;;; along with this software; see the file COPYING.  If not, write to
  17 ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;; Boston, MA 02111-1307 USA
  19 ;;;
  20 ;;; As a special exception, the Free Software Foundation gives permission
  21 ;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;
  23 ;;; The exception is that, if you link the GUILE library with other files
  24 ;;; to produce an executable, this does not by itself cause the
  25 ;;; resulting executable to be covered by the GNU General Public License.
  26 ;;; Your use of that executable is in no way restricted on account of
  27 ;;; linking the GUILE library code into it.
  28 ;;;
  29 ;;; This exception does not however invalidate any other reasons why
  30 ;;; the executable file might be covered by the GNU General Public License.
  31 ;;;
  32 ;;; This exception applies only to the code released by the
  33 ;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;; code from other Free Software Foundation releases into a copy of
  35 ;;; GUILE, as the General Public License permits, the exception does
  36 ;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;; anyone as to the status of such modified files, you must delete
  38 ;;; this exception notice from them.
  39 ;;;
  40 ;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;; whether to permit this exception to apply to your modifications.
  42 ;;; If you do not wish that, delete this exception notice.
  43
  44 (define-module (ice-9 debugger behaviour)
  45   #:use-module (ice-9 and-let-star)
  46   #:use-module (ice-9 debug)
  47   #:use-module (ice-9 debugger)
  48   #:use-module (ice-9 debugger trap-hooks)
  49   #:use-module (ice-9 debugger trc)
  50   #:use-module (ice-9 debugger utils)
  51   #:use-module (ice-9 optargs)
  52   #:export (at-exit
  53             at-entry
  54             at-apply
  55             at-step
  56             at-next
  57             debug-here
  58             trace-here
  59             trace-until-exit
  60             trace-subtree
  61             trace-exit-value
  62             add-debug-entry-message
  63             with-reference-frame
  64             with-reference-frame*))
  65
  66 ;;; This module defines useful kinds of behaviour for breakpoints.
  67
  68 (define *cont* #f)
  69 (define *frame* #f)
  70 (define *depth* #f)
  71 (define *expr* #f)
  72 (define *retval* #f)
  73 (define *trace-retval* #f)
  74 (define *trace-entry* #f)
  75 (define *trace-depths* '())
  76 (define *debug-flag* #f)
  77
  78 (add-hook! before-enter-frame-hook
  79            (lambda (cont tail? expr)
  80              (trc 'before-enter-frame-hook cont tail? expr)
  81              (set! *cont* cont)
  82              (set! *frame* (last-stack-frame cont))
  83              (set! *depth* (stack-length (make-stack cont)))
  84              (set! *expr* expr)
  85              (set! *trace-entry* #t)
  86              (set! *debug-flag* #f)
  87              (set! *debug-entry-messages* '())))
  88
  89 (add-hook! before-apply-frame-hook
  90            (lambda (cont tail?)
  91              (trc 'before-apply-frame-hook cont tail?)
  92              (set! *cont* cont)
  93              (set! *frame* (last-stack-frame cont))
  94              (set! *depth* (stack-length (make-stack cont)))
  95              (set! *expr* #f)
  96              (set! *trace-entry* #t)
  97              (set! *debug-flag* #f)
  98              (set! *debug-entry-messages* '())))
  99
 100 (add-hook! before-exit-frame-hook
 101            (lambda (cont retval)
 102              (trc 'before-exit-frame-hook cont retval)
 103              (set! *cont* cont)
 104              (set! *frame* (last-stack-frame cont))
 105              (set! *depth* (stack-length (make-stack cont)))
 106              (set! *expr* #f)
 107              (set! *retval* retval)
 108              (set! *trace-entry* #f)
 109              (set! *trace-retval* #f)
 110              (set! *debug-flag* #f)
 111              (set! *debug-entry-messages* '())))
 112
 113 (define (debug-if-flag-set)
 114   (if *debug-flag*
 115       (begin
 116         (for-each display (reverse! *debug-entry-messages*))
 117         (set! *debug-entry-messages* '())
 118         (debug-stack (make-stack *cont*) #:continuable))))
 119
 120 (add-hook! after-enter-frame-hook debug-if-flag-set)
 121
 122 (add-hook! after-apply-frame-hook debug-if-flag-set)
 123
 124 (add-hook! after-exit-frame-hook
 125            (lambda ()
 126              (if *trace-retval*
 127                  (begin
 128                    (let indent ((td *trace-depths*))
 129                      (cond ((null? td))
 130                            (else (display "|  ")
 131                                  (indent (cdr td)))))
 132                    (display "|  ")
 133                    (write *retval*)
 134                    (newline)
 135                    (set! *trace-retval* #f)))
 136              (debug-if-flag-set)))
 137
 138 (define (frame-depth frame)
 139   (- (stack-length (car frame)) (cdr frame)))
 140
 141 (define (with-reference-frame* frame thunk)
 142   (let ((saved-*frame* *frame*)
 143         (saved-*depth* *depth*))
 144     (dynamic-wind
 145         (lambda ()
 146           (set! *frame* frame)
 147           (set! *depth* (frame-depth frame)))
 148         thunk
 149         (lambda ()
 150           (set! *frame* saved-*frame*)
 151           (set! *depth* saved-*depth*)))))
 152
 153 (define-macro (with-reference-frame frame . body)
 154   `(with-reference-frame* ,frame (lambda () ,@body)))
 155
 156 ;;; at-exit THUNK
 157 ;;;
 158 ;;; Install a thunk to run when we exit the current frame.
 159
 160 (define* (at-exit #:optional thunk)
 161   (or thunk (set! thunk debug-here))
 162   (let ((depth *depth*))
 163     (letrec ((exit (lambda ()
 164                      (if (<= *depth* depth)
 165                          (begin
 166                            (remove-exit-frame-hook! exit)
 167                            (thunk))))))
 168       (add-exit-frame-hook! exit))))
 169
 170 ;;; at-entry [COUNT [THUNK]]
 171 ;;;
 172 ;;; Install a thunk to run when we get to the COUNT'th next frame
 173 ;;; entry.  COUNT defaults to 1; THUNK defaults to debug-here.
 174
 175 (define* (at-entry #:optional count thunk)
 176   (or count (set! count 1))
 177   (or thunk (set! thunk debug-here))
 178   (letrec ((enter (lambda ()
 179                     (set! count (- count 1))
 180                     (if (<= count 0)
 181                         (begin
 182                           (remove-enter-frame-hook! enter)
 183                           (thunk))))))
 184     (add-enter-frame-hook! enter)))
 185
 186 ;;; at-apply [COUNT [THUNK]]
 187 ;;;
 188 ;;; Install a thunk to run when we get to the COUNT'th next
 189 ;;; application.  COUNT defaults to 1; THUNK defaults to debug-here.
 190
 191 (define* (at-apply #:optional count thunk)
 192   (or count (set! count 1))
 193   (or thunk (set! thunk debug-here))
 194   (letrec ((apply (lambda ()
 195                     (set! count (- count 1))
 196                     (if (<= count 0)
 197                         (begin
 198                           (remove-apply-frame-hook! apply)
 199                           (thunk))))))
 200     (add-apply-frame-hook! apply)))
 201
 202 ;;; at-step [COUNT [THUNK]]
 203 ;;;
 204 ;;; Install a thunk to run when we get to the COUNT'th next
 205 ;;; application or frame entry.  COUNT defaults to 1; THUNK defaults
 206 ;;; to debug-here.
 207
 208 (define* (at-step #:optional count thunk)
 209   (or count (set! count 1))
 210   (or thunk (set! thunk debug-here))
 211   (letrec ((step (lambda ()
 212                    (set! count (- count 1))
 213                    (if (<= count 0)
 214                        (begin
 215                          (remove-enter-frame-hook! step)
 216                          (remove-apply-frame-hook! step)
 217                          (thunk))))))
 218     (add-enter-frame-hook! step)
 219     (add-apply-frame-hook! step)))
 220
 221 ;;; at-next [COUNT [THUNK]]
 222 ;;;
 223 ;;; Install a thunk to run when we get to the COUNT'th next frame
 224 ;;; entry in the same source file as the current location.  COUNT
 225 ;;; defaults to 1; THUNK defaults to debug-here.  If the current
 226 ;;; location has no filename, fall back silently to `at-entry'
 227 ;;; behaviour.
 228
 229 (define (current-file-name)
 230   (and-let* ((source (frame-source *frame*))
 231              (position (source-position source)))
 232     (and position (car position))))
 233
 234 (define* (at-next #:optional count thunk)
 235   (or count (set! count 1))
 236   (or thunk (set! thunk debug-here))
 237   (let ((filename (current-file-name)))
 238     (if filename
 239         (letrec ((next (lambda ()
 240                          (if (equal? (current-file-name) filename)
 241                              (begin
 242                                (set! count (- count 1))
 243                                (if (<= count 0)
 244                                    (begin
 245                                      (remove-enter-frame-hook! next)
 246                                      (thunk))))))))
 247           (add-enter-frame-hook! next))
 248         (at-entry count thunk))))
 249
 250 ;;; debug-here
 251 ;;;
 252 ;;; Set flag to enter the debugger once all behaviour hooks for this
 253 ;;; location have been run.
 254
 255 (define (debug-here)
 256   (set! *debug-flag* #t))
 257
 258 ;;; trace-here
 259 ;;;
 260 ;;; Trace the current location, and install a hook to trace the return
 261 ;;; value when we exit the current frame.
 262
 263 (define (trace-here)
 264   (if *trace-entry*
 265       (let ((stack (make-stack *cont*))
 266             (push-current-depth #f))
 267         (cond ((null? *trace-depths*)
 268                (set! push-current-depth #t))
 269               (else
 270                (let loop ((frame-number (car *trace-depths*)))
 271                  (cond ((>= frame-number *depth*))
 272                        ((frame-real? (stack-ref stack
 273                                                 (frame-number->index frame-number stack)))
 274                         (set! push-current-depth #t))
 275                        (else (loop (+ frame-number 1)))))))
 276         (if push-current-depth
 277             (set! *trace-depths* (cons *depth* *trace-depths*)))
 278         (let indent ((td *trace-depths*))
 279           (cond ((null? td))
 280                 (else
 281                  (display "|  ")
 282                  (indent (cdr td)))))
 283         ((if *expr*
 284              write-frame-short/expression
 285              write-frame-short/application) *frame*)
 286         (newline)
 287         (if push-current-depth
 288             (at-exit (lambda ()
 289                        (set! *trace-depths* (cdr *trace-depths*))
 290                        (set! *trace-retval* #t))))
 291         (set! *trace-entry* #f))))
 292
 293 ;;; trace-subtree
 294 ;;;
 295 ;;; Install hooks to trace everything until exit from the current
 296 ;;; frame.  Variable lookups are omitted, as they would (usually) just
 297 ;;; clog up the trace without conveying any useful information
 298
 299 (define (trace-until-exit)
 300   (let ((trace (lambda ()
 301                  (or (variable? *expr*)
 302                      (trace-here)))))
 303     (add-enter-frame-hook! trace)
 304     (add-apply-frame-hook! trace)
 305     (at-exit (lambda ()
 306                (remove-enter-frame-hook! trace)
 307                (remove-apply-frame-hook! trace)))))
 308
 309 (define (trace-subtree)
 310   (trace-until-exit)
 311   (trace-here))
 312
 313 ;;; trace-exit-value
 314 ;;;
 315 ;;; Trace the returned value in an exit frame handler.
 316
 317 (define (trace-exit-value)
 318   (set! *trace-retval* #t))
 319
 320 ;;; {Debug Entry Messages}
 321 ;;;
 322 ;;; Messages to be displayed if we decide to enter the debugger.
 323
 324 (define *debug-entry-messages* '())
 325
 326 (define (add-debug-entry-message message)
 327   (set! *debug-entry-messages*
 328         (cons message *debug-entry-messages*)))
 329
 330 ;;; {Error Hook Utilities}
 331
 332 ;(define (single-instance-installer hook handler)
 333 ;  (let ((installed? #f))
 334 ;    (lambda (yes/no?)
 335 ;      (if (and yes/no? (not installed?))
 336 ;           (begin
 337 ;             (add-hook! hook handler)
 338 ;             (set! installed? #t)))
 339 ;      (if (and (not yes/no?) installed?)
 340 ;           (begin
 341 ;             (remove-hook! hook handler)
 342 ;             (set! installed? #f))))))
 343 ;
 344 ;(define-public save-stack-on-error
 345 ;  (letrec ((handler (lambda (key a b c d)
 346 ;                       (save-stack handler))))
 347 ;    (single-instance-installer error-hook handler)))
 348 ;
 349 ;(define-public display-stack-on-error
 350 ;  (letrec ((handler (lambda (key a b c d)
 351 ;                       (display "DISPLAY-STACK-ON-ERROR: ")
 352 ;                       (write (list key a b c d))
 353 ;                       (newline)
 354 ;                       (display-backtrace (make-stack #t handler)
 355 ;                                          (current-error-port)))))
 356 ;    (single-instance-installer error-hook handler)))
 357 ;
 358 ;(define-public debug-on-error
 359 ;  (letrec ((handler (lambda (key a b c d)
 360 ;                       (let ((stack (make-stack #t handler)))
 361 ;                         (display "DEBUG-ON-ERROR: ")
 362 ;                         (write (list key a b c d))
 363 ;                         (newline)
 364 ;                         (display-error stack (current-error-port) a b c d)
 365 ;                         (debug-stack stack)))))
 366 ;    (single-instance-installer error-hook handler)))
 367
 368 ;;; (ice-9 debugger behaviour) ends here.