summaryrefslogtreecommitdiff
path: root/ice-9/debug.scm
blob: f5515d376a6c0be9a5ee36966c94023f58c6a447 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;;;; 	Copyright (C) 1996 Mikael Djurfeldt
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;;


(define-module #/ice-9/debug)



;;; {Run-time options}

(define names '((debug-options-interface
		 (debug-options debug-enable debug-disable)
		 (debug-set!))
		
		(evaluator-traps-interface
		 (traps trap-enable trap-disable)
		 (trap-set!))
		
		(read-options-interface
		 (read-options read-enable read-disable)
		 (read-set!))
		
		(print-options-interface
		 (print-options print-enable print-disable)
		 (print-set!))
		))

(define option-name car)
(define option-value cadr)
(define option-documentation caddr)

(define (print-option option)
  (display (option-name option))
  (if (< (string-length (symbol->string (option-name option))) 8)
      (display #\tab))
  (display #\tab)
  (display (option-value option))
  (display #\tab)
  (display (option-documentation option))
  (newline))

;;; Below follows the macros defining the run-time option interfaces.
;;; *fixme* These should not be macros, but need to be until module
;;; system is improved.
;;;

(define (make-options interface)
  `(lambda args
     (cond ((null? args) (,interface))
	   ((pair? (car args)) (,interface (car args)) (,interface))
	   (else (for-each print-option (,interface #t))))))

(define (make-enable interface)
  `(lambda flags
     (,interface (append flags (,interface)))
     (,interface)))

(define (make-disable interface)
  `(lambda flags
     (let ((options (,interface)))
       (for-each (lambda (flag)
		   (set! options (delq! flag options)))
		 flags)
       (,interface options)
       (,interface))))

(define (make-set! interface)
  `((name exp)
    (,'quasiquote
     (begin (,interface (append (,interface)
				(list '(,'unquote name)
				      (,'unquote exp))))
	    (,interface)))))
       
(defmacro define-all ()
  (cons 'begin
	(apply append
	       (map (lambda (group)
		      (let ((interface (car group)))
			(append (map (lambda (name constructor)
				       `(define-public ,name
					  ,(constructor interface)))
				     (cadr group)
				     (list make-options
					   make-enable
					   make-disable))
				(map (lambda (name constructor)
				       `(defmacro-public ,name
					  ,@(constructor interface)))
				     (caddr group)
				     (list make-set!)))))
		    names))))

(define-all)


;;; {Trace}
;;;
;;; This code is just an experimental prototype (e. g., it is not
;;; thread safe), but since it's at the same time useful, it's
;;; included anyway.
;;;
(define traced-procedures '())

(define-public (trace . args)
  (if (null? args)
      (nameify traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (if (not (procedure? proc))
			(error "trace: Wrong type argument:" proc))
		    (set-procedure-property! proc 'trace #t)
		    (if (not (memq proc traced-procedures))
			(set! traced-procedures
			      (cons proc traced-procedures))))
		  args)
	(set! apply-frame-handler trace-entry)
	(set! exit-frame-handler trace-exit)
	(set! trace-level 0)
	(debug-enable 'trace)
	(nameify args))))

(define-public (untrace . args)
  (if (and (null? args)
	   (not (null? traced-procedures)))
      (apply untrace traced-procedures)
      (begin
	(for-each (lambda (proc)
		    (set-procedure-property! proc 'trace #f)
		    (set! traced-procedures (delq! proc traced-procedures)))
		  args)
	(if (null? traced-procedures)
	    (debug-disable 'trace))
	(nameify args))))

(define (nameify ls)
  (map (lambda (proc)
	 (let ((name (procedure-name proc)))
	   (or name proc)))
       ls))

(define trace-level 0)
(add-hook! abort-hook (lambda () (set! trace-level 0)))

(define (trace-entry key cont tail)
  (if (eq? (stack-id cont) 'repl-stack)
      (let ((cep (current-error-port))
	    (frame (last-stack-frame cont)))
	(if (not tail)
	    (set! trace-level (+ trace-level 1)))
	(let indent ((n trace-level))
	  (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
	(display-application frame cep)))
  (debug-enable 'trace)
  ;; It's not necessary to call the continuation since
  ;; execution will continue if the handler returns
  ;(cont #f)
  )

(define (trace-exit key cont retval)
  (if (eq? (stack-id cont) 'repl-stack)
      (let ((cep (current-error-port)))
	(set! trace-level (- trace-level 1))
	(let indent ((n trace-level))
	  (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
	(write retval cep)
	(newline cep)))
  (debug-enable 'trace))


;;; A fix to get the error handling working together with the module system.
;;;
(variable-set! (builtin-variable 'debug-options) debug-options)



(debug-enable 'debug)
(read-enable 'positions)