blob: ffbb1b70f06f6fb05da7d54660cce327c159eb36 (
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
|
(defmacro with-disabled-debugging (. forms)
(let ((state (gensym)))
^(let ((,state (dbg-clear dbg-all)))
(unwind-protect
(progn ,*forms)
(dbg-restore ,state)))))
(defun make-command-env (command-table)
(let ((env (make-env )))
(mapdo (ado env-vbind env @1 ^(,@2)) command-table)
env))
(defparml %dbg-commands% '((usr:? debugger-help "list command summary")
(usr:bt print-backtrace "print backtrace")))
(defparml %dbg-command-env% (make-command-env %dbg-commands%))
(defun debugger-help ()
(mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%))
(defmeth fcall-frame loc (fr)
(ignore fr))
(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix)
(ignore pr-fr)
(let* ((fun fr.fun)
(args fr.args)
(name (if (functionp fun)
(func-get-name fun)))
(loc (if nx-fr nx-fr.(loc)))
(kind
(cond
((interp-fun-p fun) "I")
((vm-fun-p fun) "V")
((functionp fun) "C")
(t "O"))))
(put-string `@prefix @kind:@(if loc `(@loc):`)`)
(prinl ^[,(or name fun) ,*args])))
(defmeth eval-frame loc (fr)
(source-loc-str fr.form))
(defmeth eval-frame print-trace (fr pr-fr nx-fr prefix)
(when (or (null nx-fr)
(and (typep pr-fr 'fcall-frame)
(not (interp-fun-p pr-fr.fun))
(not (vm-fun-p pr-fr.fun))))
(let* ((form fr.form)
(sym (if (consp form) (car form)))
(loc (source-loc-str form)))
(when sym
(put-string `@prefix E:@(if loc `(@loc):`)`)
(prinl (if (eq sym 'dwim)
^[,(cadr form)]
^(,sym)))))))
(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix)
(ignore pr-fr nx-fr)
(let* ((form fr.form)
(loc (source-loc-str form)))
(put-string `@prefix X:@(if loc `(@loc):`)`)
(prinl form)))
(defmeth expand-frame loc (fr)
(source-loc-str fr.form))
(defun print-backtrace (: (*stdout* *stdout*) (prefix ""))
(with-resources ((imode (set-indent-mode *stdout* indent-foff)
(set-indent-mode *stdout* imode))
(depth (set-max-depth *stdout* 2)
(set-max-depth *stdout* depth))
(length (set-max-length *stdout* 10)
(set-max-length *stdout* length)))
(window-mapdo 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix))
(find-frames-by-mask (logior uw-fcall uw-eval uw-expand)))))
(defun debugger ()
(with-disabled-debugging
(sys:repl nil *stdin* *stdout* %dbg-command-env%)))
|