guile18/ice-9/debugger/utils.scm

   1
   2 (define-module (ice-9 debugger utils)
   3   #:use-module (ice-9 debugger state)
   4   #:export (display-position
   5             source-position
   6             write-frame-args-long
   7             write-frame-index-long
   8             write-frame-short/expression
   9             write-frame-short/application
  10             write-frame-long
  11             write-state-long
  12             write-state-short))
  13
  14 ;;; Procedures in this module print information about a stack frame.
  15 ;;; The available information is as follows.
  16 ;;;
  17 ;;; * Source code location.
  18 ;;;
  19 ;;; For an evaluation frame, this is the location recorded at the time
  20 ;;; that the expression being evaluated was read, if the 'positions
  21 ;;; read option was enabled at that time.
  22 ;;;
  23 ;;; For an application frame, I'm not yet sure.  Some applications
  24 ;;; seem to have associated source expressions.
  25 ;;;
  26 ;;; * Whether frame is still evaluating its arguments.
  27 ;;;
  28 ;;; Only applies to an application frame.  For example, an expression
  29 ;;; like `(+ (* 2 3) 4)' goes through the following stages of
  30 ;;; evaluation.
  31 ;;;
  32 ;;; (+ (* 2 3) 4)       -- evaluation
  33 ;;; [+ ...              -- application; the car of the evaluation
  34 ;;;                        has been evaluated and found to be a
  35 ;;;                        procedure; before this procedure can
  36 ;;;                        be applied, its arguments must be evaluated
  37 ;;; [+ 6 ...            -- same application after evaluating the
  38 ;;;                        first argument
  39 ;;; [+ 6 4]             -- same application after evaluating all
  40 ;;;                        arguments
  41 ;;; 10                  -- result
  42 ;;;
  43 ;;; * Whether frame is real or tail-recursive.
  44 ;;;
  45 ;;; If a frame is tail-recursive, its containing frame as shown by the
  46 ;;; debugger backtrace doesn't really exist as far as the Guile
  47 ;;; evaluator is concerned.  The effect of this is that when a
  48 ;;; tail-recursive frame returns, it looks as though its containing
  49 ;;; frame returns at the same time.  (And if the containing frame is
  50 ;;; also tail-recursive, _its_ containing frame returns at that time
  51 ;;; also, and so on ...)
  52 ;;;
  53 ;;; A `real' frame is one that is not tail-recursive.
  54
  55
  56 (define (write-state-short state)
  57   (let* ((frame (stack-ref (state-stack state) (state-index state)))
  58          (source (frame-source frame))
  59          (position (and source (source-position source))))
  60     (format #t "Frame ~A at " (frame-number frame))
  61     (if position
  62         (display-position position)
  63         (display "unknown source location"))
  64     (newline)
  65     (write-char #\tab)
  66     (write-frame-short frame)
  67     (newline)))
  68
  69 (define (write-state-short* stack index)
  70   (write-frame-index-short stack index)
  71   (write-char #\space)
  72   (write-frame-short (stack-ref stack index))
  73   (newline))
  74
  75 (define (write-frame-index-short stack index)
  76   (let ((s (number->string (frame-number (stack-ref stack index)))))
  77     (display s)
  78     (write-char #\:)
  79     (write-chars #\space (- 4 (string-length s)))))
  80
  81 (define (write-frame-short frame)
  82   (if (frame-procedure? frame)
  83       (write-frame-short/application frame)
  84       (write-frame-short/expression frame)))
  85
  86 (define (write-frame-short/application frame)
  87   (write-char #\[)
  88   (write (let ((procedure (frame-procedure frame)))
  89            (or (and (procedure? procedure)
  90                     (procedure-name procedure))
  91                procedure)))
  92   (if (frame-evaluating-args? frame)
  93       (display " ...")
  94       (begin
  95         (for-each (lambda (argument)
  96                     (write-char #\space)
  97                     (write argument))
  98                   (frame-arguments frame))
  99         (write-char #\]))))
 100
 101 ;;; Use builtin function instead:
 102 (set! write-frame-short/application
 103       (lambda (frame)
 104         (display-application frame (current-output-port) 12)))
 105
 106 (define (write-frame-short/expression frame)
 107   (write (let* ((source (frame-source frame))
 108                 (copy (source-property source 'copy)))
 109            (if (pair? copy)
 110                copy
 111                (unmemoize-expr source)))))
 112 \f
 113 (define (write-state-long state)
 114   (let ((index (state-index state)))
 115     (let ((frame (stack-ref (state-stack state) index)))
 116       (write-frame-index-long frame)
 117       (write-frame-long frame))))
 118
 119 (define (write-frame-index-long frame)
 120   (display "Stack frame: ")
 121   (write (frame-number frame))
 122   (if (frame-real? frame)
 123       (display " (real)"))
 124   (newline))
 125
 126 (define (write-frame-long frame)
 127   (if (frame-procedure? frame)
 128       (write-frame-long/application frame)
 129       (write-frame-long/expression frame)))
 130
 131 (define (write-frame-long/application frame)
 132   (display "This frame is an application.")
 133   (newline)
 134   (if (frame-source frame)
 135       (begin
 136         (display "The corresponding expression is:")
 137         (newline)
 138         (display-source frame)
 139         (newline)))
 140   (display "The procedure being applied is: ")
 141   (write (let ((procedure (frame-procedure frame)))
 142            (or (and (procedure? procedure)
 143                     (procedure-name procedure))
 144                procedure)))
 145   (newline)
 146   (display "The procedure's arguments are")
 147   (if (frame-evaluating-args? frame)
 148       (display " being evaluated.")
 149       (begin
 150         (display ": ")
 151         (write (frame-arguments frame))))
 152   (newline))
 153
 154 (define (display-source frame)
 155   (let* ((source (frame-source frame))
 156          (copy (source-property source 'copy)))
 157     (cond ((source-position source)
 158            => (lambda (p) (display-position p) (display ":\n"))))
 159     (display "  ")
 160     (write (or copy (unmemoize-expr source)))))
 161
 162 (define (source-position source)
 163   (let ((fname (source-property source 'filename))
 164         (line (source-property source 'line))
 165         (column (source-property source 'column)))
 166     (and fname
 167          (list fname line column))))
 168
 169 (define (display-position pos)
 170   (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))
 171
 172 (define (write-frame-long/expression frame)
 173   (display "This frame is an evaluation.")
 174   (newline)
 175   (display "The expression being evaluated is:")
 176   (newline)
 177   (display-source frame)
 178   (newline))
 179
 180 (define (write-frame-args-long frame)
 181   (if (frame-procedure? frame)
 182       (let ((arguments (frame-arguments frame)))
 183         (let ((n (length arguments)))
 184           (display "This frame has ")
 185           (write n)
 186           (display " argument")
 187           (if (not (= n 1))
 188               (display "s"))
 189           (write-char (if (null? arguments) #\. #\:))
 190           (newline))
 191         (for-each (lambda (argument)
 192                     (display "  ")
 193                     (write argument)
 194                     (newline))
 195                   arguments))
 196       (begin
 197         (display "This frame is an evaluation frame; it has no arguments.")
 198         (newline))))
 199
 200 (define (write-chars char n)
 201   (do ((i 0 (+ i 1)))
 202       ((>= i n))
 203     (write-char char)))