1 ;;;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation
3 ;;;; This program is free software; you can redistribute it and/or modify
4 ;;;; it under the terms of the GNU General Public License as published by
5 ;;;; the Free Software Foundation; either version 2, or (at your option)
6 ;;;; any later version.
8 ;;;; This program 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
11 ;;;; GNU General Public License for more details.
13 ;;;; You should have received a copy of the GNU General Public License
14 ;;;; along with this software; see the file COPYING. If not, write to
15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 ;;;; Boston, MA 02111-1307 USA
18 ;;;; As a special exception, the Free Software Foundation gives permission
19 ;;;; for additional uses of the text contained in its release of GUILE.
21 ;;;; The exception is that, if you link the GUILE library with other files
22 ;;;; to produce an executable, this does not by itself cause the
23 ;;;; resulting executable to be covered by the GNU General Public License.
24 ;;;; Your use of that executable is in no way restricted on account of
25 ;;;; linking the GUILE library code into it.
27 ;;;; This exception does not however invalidate any other reasons why
28 ;;;; the executable file might be covered by the GNU General Public License.
30 ;;;; This exception applies only to the code released by the
31 ;;;; Free Software Foundation under the name GUILE. If you copy
32 ;;;; code from other Free Software Foundation releases into a copy of
33 ;;;; GUILE, as the General Public License permits, the exception does
34 ;;;; not apply to the code that you add in this way. To avoid misleading
35 ;;;; anyone as to the status of such modified files, you must delete
36 ;;;; this exception notice from them.
38 ;;;; If you write modifications of your own for GUILE, it is your choice
39 ;;;; whether to permit this exception to apply to your modifications.
40 ;;;; If you do not wish that, delete this exception notice.
42 ;;;; The author can be reached at djurfeldt@nada.kth.se
43 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
47 (define-module (ice-9 debug))
52 (define-public (frame-number->index n . stack)
53 (let ((stack (if (null? stack)
54 (fluid-ref the-last-stack)
56 (if (memq 'backwards (debug-options))
58 (- (stack-length stack) n 1))))
63 ;;; This code is just an experimental prototype (e. g., it is not
64 ;;; thread safe), but since it's at the same time useful, it's
67 (define traced-procedures '())
69 (define-public (trace . args)
71 (nameify traced-procedures)
73 (for-each (lambda (proc)
74 (if (not (procedure? proc))
75 (error "trace: Wrong type argument:" proc))
76 (set-procedure-property! proc 'trace #t)
77 (if (not (memq proc traced-procedures))
78 (set! traced-procedures
79 (cons proc traced-procedures))))
81 (set! apply-frame-handler trace-entry)
82 (set! exit-frame-handler trace-exit)
87 (define-public (untrace . args)
89 (not (null? traced-procedures)))
90 (apply untrace traced-procedures)
92 (for-each (lambda (proc)
93 (set-procedure-property! proc 'trace #f)
94 (set! traced-procedures (delq! proc traced-procedures)))
96 (if (null? traced-procedures)
97 (debug-disable 'trace))
102 (let ((name (procedure-name proc)))
106 (define trace-level 0)
107 (add-hook! abort-hook (lambda () (set! trace-level 0)))
109 (define (trace-entry key cont tail)
110 (if (eq? (stack-id cont) 'repl-stack)
111 (let ((cep (current-error-port))
112 (frame (last-stack-frame cont)))
114 (set! trace-level (+ trace-level 1)))
115 (let indent ((n trace-level))
116 (cond ((> n 1) (display "| " cep) (indent (- n 1)))))
117 (display-application frame cep)
119 ;; It's not necessary to call the continuation since
120 ;; execution will continue if the handler returns
124 (define (trace-exit key cont retval)
125 (if (eq? (stack-id cont) 'repl-stack)
126 (let ((cep (current-error-port)))
127 (set! trace-level (- trace-level 1))
128 (let indent ((n trace-level))
129 (cond ((> n 0) (display "| " cep) (indent (- n 1)))))
134 ;;; A fix to get the error handling working together with the module system.
136 ;;; XXX - Still needed?
137 (module-set! the-root-module 'debug-options debug-options)
141 (debug-enable 'debug)
142 (read-enable 'positions)