1(library (nmosh debugger core)
2	 (export debugger)
3	 (import (rnrs) (nmosh global-flags)
4                 (nmosh debugger condition-printer)
5                 (prefix (nmosh ui deco) deco:)
6                 (nmosh conditions)
7                 (srfi :48)
8                 (srfi :98)
9		 (primitives
10                   dbg-files dbg-syms fasl-read %get-nmosh-dbg-image))
11
12(define (guru-mode?)
13  (get-global-flag '%nmosh-guru-mode))
14
15(define color-output?
16  (get-environment-variable "NMOSH_CLICOLOR"))
17
18
19(define libsyms '())
20
21(define intsyms '())
22
23(define (list-dbgfile)
24  (map cadr dbg-files))
25
26(define (get-symfile fn)
27  (guard
28    (c (#t
29        (when (guru-mode?)
30          (display (format "Cannot load ~a\n" fn) (current-error-port)))
31        #f))
32    (call-with-port (open-file-input-port fn) fasl-read)))
33
34(define (load-symfiles)
35  (define syms '())
36  (define (addsym l)
37    (set! syms (append syms l)))
38  (define (step fn)
39    (let ((r (get-symfile fn)))
40      (when r
41	(for-each
42	  (lambda (e)
43	    (if (eq? 'DBG-SYMS (car e))
44	      (addsym (cdr e))))
45	  r))))
46  (let ((f (list-dbgfile)))
47    (for-each step f))
48  syms)
49
50(define (load-intsyms)
51  (define syms '())
52  (define (addsym l)
53    (set! syms (append syms l)))
54  (define (step l)
55    (for-each
56      (lambda (e)
57	(if (eq? 'DBG-SYMS (car e))
58	  (addsym (cdr e))))
59      l))
60  (for-each step (%get-nmosh-dbg-image))
61  syms)
62
63(define (ungensym sym)
64  (define (chopseqnum l) ; => symbol
65    (define (step e cur)
66      (if (char=? #\~ e)
67	'()
68	(cons e cur)))
69    (string->symbol (list->string (fold-right step '() l))))
70  (let ((l (string->list (symbol->string sym))))
71    (if (char=? #\& (car l))
72      (chopseqnum (cdr l))
73      sym)))
74
75(define (disp l)
76  (display l (current-error-port)))
77
78(define deco/err
79  (if color-output?
80    deco:deco/err
81    disp))
82
83(define (fallback-trace-printer/deco trace)
84
85  (define (cprocprint h)
86    (let ((proc (car h)))
87      (disp "  cprc   ")
88      (deco/err proc)))
89  (define (undec proc)
90    (define (do-undec sym)
91      (if (symbol? sym)
92	(ungensym sym)
93	sym))
94    (deco/err (map do-undec proc)))
95  (define (decprint proc)
96    (define (step cur e)
97      (cond
98	((assq e libsyms) => (lambda (p) (cons 'lib p)))
99	((assq e dbg-syms) => (lambda (p) (cons 'dbg p)))
100	((assq e intsyms) => (lambda (p) (cons 'int p)))
101	(else cur)))
102    (let ((dbg (fold-left step #f proc)))
103      (cond
104	(dbg
105	  (case (car dbg)
106	    ((lib) (disp "==USRP== "))
107	    ((dbg) (disp "==DBGP== "))
108	    ((int) (disp "  nmsh   ")))
109	  (undec proc)
110	  (disp " @ ")
111	  (deco/err (debug-format (cddr dbg))))
112	(else
113	  (disp "  usrp   ")
114	  (undec proc)))))
115  (define (procprint h)
116    (let ((proc (car h))
117	  (loc (cadr h)))
118      (cond
119	(loc
120	  (disp "  mosh   ")
121	  (deco/err proc)
122	  (disp " @ ")
123	  (deco/err (debug-format loc)))
124	(else
125	  (decprint proc)))))
126
127  (define (numprint i)
128    (when (< i 10)
129      (disp " "))
130    (when (< i 100)
131      (disp " "))
132    (deco/err i)
133    (disp " : "))
134
135  (define (print num e)
136    (let ((id (cadr e))
137	  (param (cddr e)))
138      (case id
139	((*proc*)
140	 (numprint num)
141	 (procprint param))
142	((*cproc*)
143	 (numprint num)
144	 (cprocprint param))
145	(else 'ok)))
146    (disp "\n"))
147  (define (user-code? e)
148    (define (step cur e)
149      (cond
150	((assq e libsyms) #t)
151	((assq e dbg-syms) #t)
152	((assq e intsyms) #f)
153	(else cur)))
154    (define (find-dbginfo-for-user prc)
155      (fold-left step #f prc))
156    (define (user-proc? h)
157      (let ((loc (cadr h)))
158        (cond
159          (loc #f) ; mosh baselib
160          (else (find-dbginfo-for-user (car h))))))
161    (let ((id (cadr e))
162          (param (cddr e)))
163      (case id
164        ((*proc*)
165         (user-proc? param))
166        ((*cproc*) #f)
167        (else #f))))
168  (define (printer t)
169    (define (itr i cur)
170      (when (pair? cur)
171	(case (cadar cur)
172	  ((*unknown-proc*)
173	   (itr i (cdr cur)))
174	  (else
175	    (print i (car cur))
176	    (itr (+ i 1) (cdr cur))))))
177    (itr 1 t))
178  (define (strip t)
179    (define (do-strip cur)
180      (if (pair? cur)
181        (if (user-code? (car cur))
182          cur
183          (do-strip (cdr cur)))
184        '()))
185    (cond
186      ((guru-mode?) t)
187      (else
188        (do-strip t))))
189  (let* ((disp-a (reverse (strip trace)))
190         (disp-t (if (pair? disp-a) (cdr disp-a) '())))
191    (unless (= 0 (length disp-t))
192      (disp "TRACE!! :\n")
193      (printer disp-t))))
194
195(define minidebug-key #f)
196
197(define (stacktrace-printer/deco trace)
198  (when (and (pair? trace) (pair? (cdr trace)))
199    (fallback-trace-printer/deco (cdr trace))))
200
201(define (load-symbols)
202  (set! intsyms (load-intsyms))
203  (set! libsyms (load-symfiles)))
204
205(define (debugger c trace)
206  (condition-printer/deco c)
207  (when minidebug-key
208    (display "!!! DOUBLE FAULT!\n" (current-error-port))
209    (exit -1))
210  (set! minidebug-key #t)
211  (load-symbols)
212  (stacktrace-printer/deco trace)
213  (exit -1))
214
215)
216