Commit | Line | Data |
---|---|---|
8746959c NJ |
1 | ;;;; (ice-9 debugging trace) -- breakpoint trace behaviour |
2 | ||
3 | ;;; Copyright (C) 2002 Free Software Foundation, Inc. | |
4 | ;;; | |
53befeb7 NJ |
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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
8746959c NJ |
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. |