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
|
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
|
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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)))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr)
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
|
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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)
)))))
;; Brandon's debug printer shortcut (indulge me :)
(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location #f))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(this-func (cadr (string-split this-loc " "))))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
(let ((dp-args (append (list 0 *default-log-port* location" " ) in-args)))
(apply debug:print dp-args))))
(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*
|