27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
(define-syntax common:handle-exceptions
(syntax-rules ()
((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))
(define (debug:calc-verbosity vstr)
(cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
(define-syntax common:handle-exceptions
(syntax-rules ()
((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))
;; iup callbacks are not dumping the stack, this is a work-around
;;
(define-simple-syntax (debug:catch-and-dump proc procname)
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(with-output-to-port (current-error-port)
(lambda ()
(print ((condition-property-accessor 'exn 'message) exn))
(print "Callback error in " procname)
(print "Full condition info:\n" (condition->list exn)))))
(proc)))
(define (debug:calc-verbosity vstr)
(cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
|
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print params)
)))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
|
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
|
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
|
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
|