module/ice-9/debugging/trace.scm

   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.