1 ;;;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006 Free Software Foundation
3 ;;;; This library is free software; you can redistribute it and/or
4 ;;;; modify it under the terms of the GNU Lesser General Public
5 ;;;; License as published by the Free Software Foundation; either
6 ;;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;; This library is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;;; Lesser General Public License for more details.
13 ;;;; You should have received a copy of the GNU Lesser General Public
14 ;;;; License along with this library; if not, write to the Free Software
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17 ;;;; The author can be reached at djurfeldt@nada.kth.se
18 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
22 (define-module (ice-9 debug)
23 :export (frame-number->index trace untrace trace-stack untrace-stack))
28 (define (frame-number->index n . stack)
29 (let ((stack (if (null? stack)
30 (fluid-ref the-last-stack)
32 (if (memq 'backwards (debug-options))
34 (- (stack-length stack) n 1))))
39 ;;; This code is just an experimental prototype (e. g., it is not
40 ;;; thread safe), but since it's at the same time useful, it's
43 (define traced-procedures '())
45 (define (trace . args)
47 (nameify traced-procedures)
49 (for-each (lambda (proc)
50 (if (not (procedure? proc))
51 (error "trace: Wrong type argument:" proc))
52 (set-procedure-property! proc 'trace #t)
53 (if (not (memq proc traced-procedures))
54 (set! traced-procedures
55 (cons proc traced-procedures))))
57 (trap-set! apply-frame-handler trace-entry)
58 (trap-set! exit-frame-handler trace-exit)
59 ;; We used to reset `trace-level' here to 0, but this is wrong
60 ;; if `trace' itself is being traced, since `trace-exit' will
61 ;; then decrement `trace-level' to -1! It shouldn't actually
62 ;; be necessary to set `trace-level' here at all.
66 (define (untrace . args)
68 (not (null? traced-procedures)))
69 (apply untrace traced-procedures)
71 (for-each (lambda (proc)
72 (set-procedure-property! proc 'trace #f)
73 (set! traced-procedures (delq! proc traced-procedures)))
75 (if (null? traced-procedures)
76 (debug-disable 'trace))
81 (let ((name (procedure-name proc)))
85 (define trace-level 0)
86 (add-hook! abort-hook (lambda () (set! trace-level 0)))
88 (define traced-stack-ids (list 'repl-stack))
89 (define trace-all-stacks? #f)
91 (define (trace-stack id)
92 "Add ID to the set of stack ids for which tracing is active.
93 If `#t' is in this set, tracing is active regardless of stack context.
94 To remove ID again, use `untrace-stack'. If you add the same ID twice
95 using `trace-stack', you will need to remove it twice."
96 (set! traced-stack-ids (cons id traced-stack-ids))
97 (set! trace-all-stacks? (memq #t traced-stack-ids)))
99 (define (untrace-stack id)
100 "Remove ID from the set of stack ids for which tracing is active."
101 (set! traced-stack-ids (delq1! id traced-stack-ids))
102 (set! trace-all-stacks? (memq #t traced-stack-ids)))
104 (define (trace-entry key cont tail)
105 (if (or trace-all-stacks?
106 (memq (stack-id cont) traced-stack-ids))
107 (let ((cep (current-error-port))
108 (frame (last-stack-frame cont)))
110 (set! trace-level (+ trace-level 1)))
111 (let indent ((n trace-level))
112 (cond ((> n 1) (display "| " cep) (indent (- n 1)))))
113 (display-application frame cep)
115 ;; It's not necessary to call the continuation since
116 ;; execution will continue if the handler returns
120 (define (trace-exit key cont retval)
121 (if (or trace-all-stacks?
122 (memq (stack-id cont) traced-stack-ids))
123 (let ((cep (current-error-port)))
124 (set! trace-level (- trace-level 1))
125 (let indent ((n trace-level))
126 (cond ((> n 0) (display "| " cep) (indent (- n 1)))))
131 ;;; A fix to get the error handling working together with the module system.
133 ;;; XXX - Still needed?
134 (module-set! the-root-module 'debug-options debug-options)