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