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 / debugging / trace.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  4.5 KB  |  158 lines
  1. ;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
  2.  
  3. ;;; Copyright (C) 2002 Free Software Foundation, Inc.
  4. ;;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library 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. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18.  
  19. (define-module (ice-9 debugging trace)
  20.   #:use-module (ice-9 debug)
  21.   #:use-module (ice-9 debugger)
  22.   #:use-module (ice-9 debugging ice-9-debugger-extensions)
  23.   #:use-module (ice-9 debugging steps)
  24.   #:use-module (ice-9 debugging traps)
  25.   #:export (trace-trap
  26.         trace-port
  27.         set-trace-layout
  28.             trace/pid
  29.             trace/stack-id
  30.             trace/stack-depth
  31.             trace/stack-real-depth
  32.             trace/stack
  33.             trace/source-file-name
  34.             trace/source-line
  35.             trace/source-column
  36.             trace/source
  37.             trace/type
  38.             trace/real?
  39.             trace/info
  40.         trace-at-exit
  41.         trace-until-exit))
  42.  
  43. (cond ((string>=? (version) "1.7")
  44.        (use-modules (ice-9 debugger utils))))
  45.  
  46. (define trace-format-string #f)
  47. (define trace-arg-procs #f)
  48.  
  49. (define (set-trace-layout format-string . arg-procs)
  50.   (set! trace-format-string format-string)
  51.   (set! trace-arg-procs arg-procs))
  52.  
  53. (define (trace/pid trap-context)
  54.   (getpid))
  55.  
  56. (define (trace/stack-id trap-context)
  57.   (stack-id (tc:stack trap-context)))
  58.  
  59. (define (trace/stack-depth trap-context)
  60.   (tc:depth trap-context))
  61.  
  62. (define (trace/stack-real-depth trap-context)
  63.   (tc:real-depth trap-context))
  64.  
  65. (define (trace/stack trap-context)
  66.   (format #f "~a:~a+~a"
  67.       (stack-id (tc:stack trap-context))
  68.       (tc:real-depth trap-context)
  69.       (- (tc:depth trap-context) (tc:real-depth trap-context))))
  70.  
  71. (define (trace/source-file-name trap-context)
  72.   (cond ((frame->source-position (tc:frame trap-context)) => car)
  73.     (else "")))
  74.  
  75. (define (trace/source-line trap-context)
  76.   (cond ((frame->source-position (tc:frame trap-context)) => cadr)
  77.     (else 0)))
  78.  
  79. (define (trace/source-column trap-context)
  80.   (cond ((frame->source-position (tc:frame trap-context)) => caddr)
  81.     (else 0)))
  82.  
  83. (define (trace/source trap-context)
  84.   (cond ((frame->source-position (tc:frame trap-context))
  85.      =>
  86.      (lambda (pos)
  87.        (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
  88.     (else "")))
  89.  
  90. (define (trace/type trap-context)
  91.   (case (tc:type trap-context)
  92.     ((#:application) "APP")
  93.     ((#:evaluation) "EVA")
  94.     ((#:return) "RET")
  95.     ((#:error) "ERR")
  96.     (else "???")))
  97.  
  98. (define (trace/real? trap-context)
  99.   (if (frame-real? (tc:frame trap-context)) " " "t"))
  100.  
  101. (define (trace/info trap-context)
  102.   (with-output-to-string
  103.     (lambda ()
  104.       (if (memq (tc:type trap-context) '(#:application #:evaluation))
  105.       ((if (tc:expression trap-context)
  106.            write-frame-short/expression
  107.            write-frame-short/application) (tc:frame trap-context))
  108.       (begin
  109.         (display "=>")
  110.         (write (tc:return-value trap-context)))))))
  111.  
  112. (set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)
  113.  
  114. ;;; trace-trap
  115. ;;;
  116. ;;; Trace the current location, and install a hook to trace the return
  117. ;;; value when we exit the current frame.
  118.  
  119. (define (trace-trap trap-context)
  120.   (apply format
  121.      (trace-port)
  122.      trace-format-string
  123.      (map (lambda (arg-proc)
  124.         (arg-proc trap-context))
  125.           trace-arg-procs)))
  126.  
  127. (set! (behaviour-ordering trace-trap) 50)
  128.  
  129. ;;; trace-port
  130. ;;;
  131. ;;; The port to which trace information is printed.
  132.  
  133. (define trace-port
  134.   (let ((port (current-output-port)))
  135.     (make-procedure-with-setter
  136.      (lambda () port)
  137.      (lambda (new) (set! port new)))))
  138.  
  139. ;;; trace-at-exit
  140. ;;;
  141. ;;; Trace return value on exit from the current frame.
  142.  
  143. (define (trace-at-exit trap-context)
  144.   (at-exit (tc:depth trap-context) trace-trap))
  145.  
  146. ;;; trace-until-exit
  147. ;;;
  148. ;;; Trace absolutely everything until exit from the current frame.
  149.  
  150. (define (trace-until-exit trap-context)
  151.   (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
  152.     (install-trap step-trap)
  153.     (at-exit (tc:depth trap-context)
  154.          (lambda (trap-context)
  155.            (uninstall-trap step-trap)))))
  156.  
  157. ;;; (ice-9 debugging trace) ends here.
  158.