ice-9/debugging/ice-9-debugger-extensions.scm

   1
   2 (define-module (ice-9 debugging ice-9-debugger-extensions)
   3   #:use-module (ice-9 debugger))
   4
   5 ;;; Upgrade the debugger state object so that it can carry a flag
   6 ;;; indicating whether the debugging session is continuable.
   7
   8 (cond ((string>=? (version) "1.7")
   9        (use-modules (ice-9 debugger state))
  10        (define-module (ice-9 debugger state)))
  11       (else
  12        (define-module (ice-9 debugger))))
  13
  14 (set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
  15 (set! state? (record-predicate state-rtd))
  16 (set! make-state
  17   (let ((make-state-internal (record-constructor state-rtd
  18                                                  '(stack index flags))))
  19     (lambda (stack index . flags)
  20       (make-state-internal stack index flags))))
  21 (set! state-stack (record-accessor state-rtd 'stack))
  22 (set! state-index (record-accessor state-rtd 'index))
  23
  24 (define state-flags (record-accessor state-rtd 'flags))
  25
  26 ;;; Add commands that (ice-9 debugger) doesn't currently have, for
  27 ;;; continuing or single stepping program execution.
  28
  29 (cond ((string>=? (version) "1.7")
  30        (use-modules (ice-9 debugger command-loop))
  31        (define-module (ice-9 debugger command-loop)
  32          #:use-module (ice-9 debugger)
  33          #:use-module (ice-9 debugger state)
  34          #:use-module (ice-9 debugging traps))
  35        (define new-define-command define-command)
  36        (set! define-command
  37              (lambda (name argument-template documentation procedure)
  38                (new-define-command name argument-template procedure))))
  39       (else
  40        (define-module (ice-9 debugger))))
  41
  42 (use-modules (ice-9 debugging steps))
  43
  44 (define (assert-continuable state)
  45   ;; Check that debugger is in a state where `continuing' makes sense.
  46   ;; If not, signal an error.
  47   (or (memq #:continuable (state-flags state))
  48       (user-error "This debug session is not continuable.")))
  49
  50 (define (debugger:continue state)
  51   "Tell the program being debugged to continue running.  (In fact this is
  52 the same as the @code{quit} command, because it exits the debugger
  53 command loop and so allows whatever code it was that invoked the
  54 debugger to continue.)"
  55   (assert-continuable state)
  56   (throw 'exit-debugger))
  57
  58 (define (debugger:finish state)
  59   "Continue until evaluation of the current frame is complete, and
  60 print the result obtained."
  61   (assert-continuable state)
  62   (at-exit (- (stack-length (state-stack state))
  63               (state-index state))
  64            (list trace-trap debug-trap))
  65   (debugger:continue state))
  66
  67 (define (debugger:step state n)
  68   "Tell the debugged program to do @var{n} more steps from its current
  69 position.  One @dfn{step} means executing until the next frame entry
  70 or exit of any kind.  @var{n} defaults to 1."
  71   (assert-continuable state)
  72   (at-step debug-trap (or n 1))
  73   (debugger:continue state))
  74
  75 (define (debugger:next state n)
  76   "Tell the debugged program to do @var{n} more steps from its current
  77 position, but only counting frame entries and exits where the
  78 corresponding source code comes from the same file as the current
  79 stack frame.  (See @ref{Step Traps} for the details of how this
  80 works.)  If the current stack frame has no source code, the effect of
  81 this command is the same as of @code{step}.  @var{n} defaults to 1."
  82   (assert-continuable state)
  83   (at-step debug-trap
  84            (or n 1)
  85            (frame-file-name (stack-ref (state-stack state)
  86                                        (state-index state)))
  87            (if (memq #:return (state-flags state))
  88                #f
  89                (- (stack-length (state-stack state)) (state-index state))))
  90   (debugger:continue state))
  91
  92 (define-command "continue" '()
  93   "Continue program execution."
  94   debugger:continue)
  95
  96 (define-command "finish" '()
  97   "Continue until evaluation of the current frame is complete, and
  98 print the result obtained."
  99   debugger:finish)
 100
 101 (define-command "step" '('optional exact-integer)
 102   "Continue until entry to @var{n}th next frame."
 103   debugger:step)
 104
 105 (define-command "next" '('optional exact-integer)
 106   "Continue until entry to @var{n}th next frame in same file."
 107   debugger:next)
 108
 109 ;;; Export a couple of procedures for use by (ice-9 debugging trace).
 110
 111 (cond ((string>=? (version) "1.7"))
 112       (else
 113        (define-module (ice-9 debugger))
 114        (export write-frame-short/expression
 115                write-frame-short/application)))
 116
 117 ;;; Provide a `debug-trap' entry point in (ice-9 debugger).  This is
 118 ;;; designed so that it can be called to explore the stack at a
 119 ;;; breakpoint, and to single step from the breakpoint.
 120
 121 (define-module (ice-9 debugger))
 122
 123 (use-modules (ice-9 debugging traps))
 124
 125 (define *not-yet-introduced* #t)
 126
 127 (cond ((string>=? (version) "1.7"))
 128       (else
 129        (define (debugger-command-loop state)
 130          (read-and-dispatch-commands state (current-input-port)))))
 131
 132 (define-public (debug-trap trap-context)
 133   "Invoke the Guile debugger to explore the stack at the specified @var{trap}."
 134   (start-stack 'debugger
 135                (let* ((stack (tc:stack trap-context))
 136                       (flags1 (let ((trap-type (tc:type trap-context)))
 137                                 (case trap-type
 138                                   ((#:return #:error)
 139                                    (list trap-type
 140                                          (tc:return-value trap-context)))
 141                                   (else
 142                                    (list trap-type)))))
 143                       (flags (if (tc:continuation trap-context)
 144                                  (cons #:continuable flags1)
 145                                  flags1))
 146                       (state (apply make-state stack 0 flags)))
 147                  (if *not-yet-introduced*
 148                      (let ((ssize (stack-length stack)))
 149                        (display "This is the Guile debugger -- for help, type `help'.\n")
 150                        (set! *not-yet-introduced* #f)
 151                        (if (= ssize 1)
 152                            (display "There is 1 frame on the stack.\n\n")
 153                            (format #t "There are ~A frames on the stack.\n\n" ssize))))
 154                  (write-state-short-with-source-location state)
 155                  (debugger-command-loop state))))
 156
 157 (define write-state-short-with-source-location
 158   (cond ((string>=? (version) "1.7")
 159          write-state-short)
 160         (else
 161          (lambda (state)
 162            (let* ((frame (stack-ref (state-stack state) (state-index state)))
 163                   (source (frame-source frame))
 164                   (position (and source (source-position source))))
 165              (format #t "Frame ~A at " (frame-number frame))
 166              (if position
 167                  (display-position position)
 168                  (display "unknown source location"))
 169              (newline)
 170              (write-char #\tab)
 171              (write-frame-short frame)
 172              (newline))))))