Commit | Line | Data |
---|---|---|
4fe4070a MD |
1 | ;;;; Copyright (C) 1996 Mikael Djurfeldt |
2 | ;;;; | |
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. | |
7 | ;;;; | |
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. | |
12 | ;;;; | |
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, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | ;;;; | |
17 | ;;;; The author can be reached at djurfeldt@nada.kth.se | |
18 | ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN | |
19 | ;;;; | |
20 | \f | |
21 | ||
22 | (define-module #/ice-9/debug) | |
23 | ||
24 | \f | |
25 | ||
26 | ;;; {Run-time options} | |
27 | ||
28 | (define names '((debug-options-interface | |
29 | (debug-options debug-enable debug-disable) | |
30 | (debug-set!)) | |
31 | ||
32 | (evaluator-traps-interface | |
33 | (traps trap-enable trap-disable) | |
34 | (trap-set!)) | |
35 | ||
36 | (read-options-interface | |
37 | (read-options read-enable read-disable) | |
38 | (read-set!)) | |
39 | ||
40 | (print-options-interface | |
41 | (print-options print-enable print-disable) | |
42 | (print-set!)) | |
43 | )) | |
44 | ||
45 | (define option-name car) | |
46 | (define option-value cadr) | |
47 | (define option-documentation caddr) | |
48 | ||
49 | (define (print-option option) | |
50 | (display (option-name option)) | |
51 | (if (< (string-length (symbol->string (option-name option))) 8) | |
52 | (display #\tab)) | |
53 | (display #\tab) | |
54 | (display (option-value option)) | |
55 | (display #\tab) | |
56 | (display (option-documentation option)) | |
57 | (newline)) | |
58 | ||
59 | ;;; Below follows the macros defining the run-time option interfaces. | |
60 | ;;; *fixme* These should not be macros, but need to be until module | |
61 | ;;; system is improved. | |
62 | ;;; | |
63 | ||
64 | (define (make-options interface) | |
65 | `(lambda args | |
66 | (cond ((null? args) (,interface)) | |
67 | ((pair? (car args)) (,interface (car args)) (,interface)) | |
68 | (else (for-each print-option (,interface #t)))))) | |
69 | ||
70 | (define (make-enable interface) | |
71 | `(lambda flags | |
6d2388ee | 72 | (,interface (append flags (,interface))) |
4fe4070a MD |
73 | (,interface))) |
74 | ||
75 | (define (make-disable interface) | |
76 | `(lambda flags | |
77 | (let ((options (,interface))) | |
78 | (for-each (lambda (flag) | |
79 | (set! options (delq! flag options))) | |
6d2388ee | 80 | flags) |
4fe4070a MD |
81 | (,interface options) |
82 | (,interface)))) | |
83 | ||
84 | (define (make-set! interface) | |
85 | `((name exp) | |
86 | (,'quasiquote | |
87 | (begin (,interface (append (,interface) | |
88 | (list '(,'unquote name) | |
89 | (,'unquote exp)))) | |
90 | (,interface))))) | |
91 | ||
92 | (defmacro define-all () | |
93 | (cons 'begin | |
94 | (apply append | |
95 | (map (lambda (group) | |
96 | (let ((interface (car group))) | |
97 | (append (map (lambda (name constructor) | |
98 | `(define-public ,name | |
99 | ,(constructor interface))) | |
100 | (cadr group) | |
101 | (list make-options | |
102 | make-enable | |
103 | make-disable)) | |
104 | (map (lambda (name constructor) | |
105 | `(defmacro-public ,name | |
106 | ,@(constructor interface))) | |
107 | (caddr group) | |
108 | (list make-set!))))) | |
109 | names)))) | |
110 | ||
111 | (define-all) | |
6d2388ee MD |
112 | |
113 | \f | |
e6875011 MD |
114 | ;;; {Trace} |
115 | ;;; | |
9a942103 MD |
116 | ;;; This code is just an experimental prototype (e. g., it is not |
117 | ;;; thread safe), but since it's at the same time useful, it's | |
118 | ;;; included anyway. | |
119 | ;;; | |
e6875011 MD |
120 | (define traced-procedures '()) |
121 | ||
122 | (define-public (trace . args) | |
123 | (if (null? args) | |
124 | (nameify traced-procedures) | |
125 | (begin | |
126 | (for-each (lambda (proc) | |
cb3a1784 MD |
127 | (if (not (procedure? proc)) |
128 | (error "trace: Wrong type argument:" proc)) | |
e6875011 MD |
129 | (set-procedure-property! proc 'trace #t) |
130 | (if (not (memq proc traced-procedures)) | |
131 | (set! traced-procedures | |
132 | (cons proc traced-procedures)))) | |
133 | args) | |
134 | (set! apply-frame-handler trace-entry) | |
135 | (set! exit-frame-handler trace-exit) | |
136 | (set! trace-level 0) | |
137 | (debug-enable 'trace) | |
138 | (nameify args)))) | |
139 | ||
140 | (define-public (untrace . args) | |
141 | (if (and (null? args) | |
142 | (not (null? traced-procedures))) | |
143 | (apply untrace traced-procedures) | |
144 | (begin | |
145 | (for-each (lambda (proc) | |
146 | (set-procedure-property! proc 'trace #f) | |
147 | (set! traced-procedures (delq! proc traced-procedures))) | |
148 | args) | |
149 | (if (null? traced-procedures) | |
150 | (debug-disable 'trace)) | |
151 | (nameify args)))) | |
152 | ||
153 | (define (nameify ls) | |
154 | (map (lambda (proc) | |
155 | (let ((name (procedure-name proc))) | |
156 | (or name proc))) | |
157 | ls)) | |
158 | ||
159 | (define trace-level 0) | |
59e1116d | 160 | (add-hook! abort-hook (lambda () (set! trace-level 0))) |
e6875011 MD |
161 | |
162 | (define (trace-entry key cont tail) | |
9a942103 MD |
163 | (if (eq? (stack-id cont) 'repl-stack) |
164 | (let ((cep (current-error-port)) | |
165 | (frame (last-stack-frame cont))) | |
166 | (if (not tail) | |
167 | (set! trace-level (+ trace-level 1))) | |
168 | (let indent ((n trace-level)) | |
169 | (cond ((> n 1) (display "| " cep) (indent (- n 1))))) | |
3b326536 | 170 | (display-application frame cep))) |
9a942103 MD |
171 | (debug-enable 'trace) |
172 | ;; It's not necessary to call the continuation since | |
173 | ;; execution will continue if the handler returns | |
174 | ;(cont #f) | |
175 | ) | |
e6875011 MD |
176 | |
177 | (define (trace-exit key cont retval) | |
9a942103 MD |
178 | (if (eq? (stack-id cont) 'repl-stack) |
179 | (let ((cep (current-error-port))) | |
180 | (set! trace-level (- trace-level 1)) | |
181 | (let indent ((n trace-level)) | |
182 | (cond ((> n 0) (display "| " cep) (indent (- n 1))))) | |
183 | (write retval cep) | |
184 | (newline cep))) | |
185 | (debug-enable 'trace)) | |
e6875011 | 186 | |
e6875011 | 187 | \f |
9a942103 MD |
188 | ;;; A fix to get the error handling working together with the module system. |
189 | ;;; | |
190 | (variable-set! (builtin-variable 'debug-options) debug-options) | |
191 | ||
192 | \f | |
e6875011 | 193 | |
61529d8e MD |
194 | (debug-enable 'debug) |
195 | (read-enable 'positions) |