home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / debugger / utils.scm < prev   
Encoding:
Text File  |  2008-12-17  |  6.2 KB  |  204 lines
  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.  
  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)))
  204.