1 |
|
|
2 |
|
(in-package "CONDITIONS") |
3 |
|
|
4 |
|
(import '(with-simple-restart abort continue compute-restarts |
5 |
|
*debug-level* *debug-restarts* *number-of-debug-restarts* |
6 |
|
*debug-abort* *debug-continue* *debug-condition* *debug-eval* |
7 |
|
find-restart invoke-restart invoke-restart-interactively |
8 |
|
restart-name ignore-errors show-restarts conditionp) |
9 |
|
"SYSTEM") |
10 |
|
|
11 |
|
(in-package "SYSTEM") |
12 |
|
|
13 |
|
(defvar *abort-restarts* nil) |
14 |
|
|
15 |
|
(defmacro with-clcs-break-level-bindings (&body forms) |
16 |
|
`(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) |
17 |
|
(debug-level *DEBUG-LEVEL*) |
18 |
|
(*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) |
19 |
|
(*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) |
20 |
|
(*DEBUG-ABORT* (FIND-RESTART 'ABORT)) |
21 |
|
(*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) |
22 |
|
(IF (OR (NOT *DEBUG-CONTINUE*) |
23 |
|
(NOT (EQ *DEBUG-CONTINUE* C))) |
24 |
|
C NIL)) |
25 |
|
(LET ((C (IF *DEBUG-RESTARTS* |
26 |
|
(FIRST *DEBUG-RESTARTS*) NIL))) |
27 |
|
(IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) |
28 |
|
(*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*)) |
29 |
|
(*abort-restarts* (let ((abort-list nil)) |
30 |
|
(dolist (restart *DEBUG-RESTARTS*) |
31 |
|
(when (eq 'abort (restart-name restart)) |
32 |
|
(push restart abort-list))) |
33 |
|
(nreverse abort-list)))) |
34 |
|
,@forms)) |
35 |
|
|
36 |
|
(defun clcs-break-level-invoke-restart (-) |
37 |
|
(COND ((AND (PLUSP -) |
38 |
|
(< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) |
39 |
|
(LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*))) |
40 |
|
(INVOKE-RESTART-INTERACTIVELY RESTART))) |
41 |
|
(T |
42 |
|
(FORMAT T "~&No such restart.")))) |
43 |
|
|
44 |
|
;; From akcl-1-530, changes marked with ;*** |
45 |
|
(defun clcs-break-level (at &optional env) |
46 |
|
(let* ((*break-message* (if (or (stringp at) (conditionp at)) ;*** |
47 |
|
at *break-message*)) ;*** |
48 |
|
(*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;*** |
49 |
|
(*quit-tag* nil) ;*** |
50 |
|
(*break-level* (if (conditionp at) (cons t *break-level*) *break-level*)) |
51 |
|
(*ihs-base* (1+ *ihs-top*)) |
52 |
|
(*ihs-top* (1- (ihs-top))) |
53 |
|
(*current-ihs* *ihs-top*) |
54 |
|
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) |
55 |
|
(*frs-top* (frs-top)) |
56 |
|
(*break-env* nil) |
57 |
|
;;(be *break-enable*) ;*** |
58 |
|
;;(*break-enable* ;*** |
59 |
|
;;(progn ;*** |
60 |
|
;;(if (stringp at) nil be))) ;*** |
61 |
|
;;(*standard-input* *terminal-io*) |
62 |
|
(*readtable* (or *break-readtable* *readtable*)) |
63 |
|
(*read-suppress* nil) |
64 |
|
(+ +) (++ ++) (+++ +++) |
65 |
|
(- -) |
66 |
|
(* *) (** **) (*** ***) |
67 |
|
(/ /) (// //) (/// ///) |
68 |
|
) |
69 |
|
;;(terpri *error-output*) |
70 |
|
(with-clcs-break-level-bindings ;*** |
71 |
|
(if (consp at) |
72 |
|
(set-back at env) |
73 |
|
(with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** |
74 |
|
(format *debug-io* "~&~A~2%" *break-message*) ;*** |
75 |
|
(when (> (length *link-array*) 0) |
76 |
|
(format *debug-io* |
77 |
|
"Fast links are on: do (use-fast-links nil) for debugging~%")) |
78 |
|
(set-current) ;*** |
79 |
|
(setq *no-prompt* nil) |
80 |
|
(show-restarts))) ;*** |
81 |
|
(catch-fatal 1) |
82 |
|
(setq *interrupt-enable* t) |
83 |
|
(loop |
84 |
|
(setq +++ ++ ++ + + -) |
85 |
|
(cond (*no-prompt* (setq *no-prompt* nil)) |
86 |
|
(t |
87 |
|
(format *debug-io* "~&~a~a>~{~*>~}" |
88 |
|
(if (stringp at) "" "dbl:") |
89 |
|
(if (eq *package* (find-package 'user)) "" |
90 |
|
(package-name *package*)) |
91 |
|
*break-level*))) |
92 |
|
(unless ;*** |
93 |
|
(with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** |
94 |
|
(not |
95 |
|
(catch 'step-continue |
96 |
|
(setq - (locally (declare (notinline read)) |
97 |
|
(dbl-read *debug-io* nil *top-eof*))) |
98 |
|
(when (eq - *top-eof*) (bye)) |
99 |
|
(let* ( break-command |
100 |
|
(values |
101 |
|
(multiple-value-list |
102 |
|
(LOCALLY (declare (notinline break-call evalhook)) |
103 |
|
(if (or (keywordp -) (integerp -)) ;*** |
104 |
|
(setq - (cons - nil))) |
105 |
|
(cond ((and (consp -) (keywordp (car -))) |
106 |
|
(setq break-command t) |
107 |
|
(break-call (car -) (cdr -))) |
108 |
|
((and (consp -) (integerp (car -))) ;*** |
109 |
|
(setq break-command t) ;*** |
110 |
|
(clcs-break-level-invoke-restart (car -))) ;*** |
111 |
|
(t (evalhook - nil nil *break-env*))))))) ;*** |
112 |
|
(setq /// // // / / values *** ** ** * * (car /)) |
113 |
|
(fresh-line *debug-io*) |
114 |
|
(dolist (val /) |
115 |
|
(locally (declare (notinline prin1)) (prin1 val *debug-io*)) |
116 |
|
(terpri *debug-io*))) |
117 |
|
nil))) ;*** |
118 |
|
(terpri *debug-io*) |
119 |
|
(break-current)))))) |
120 |
|
|
121 |
|
(defun clcs-terminal-interrupt (correctablep) |
122 |
|
(if correctablep |
123 |
|
(cerror "Continues execution." "Console interrupt.") |
124 |
|
(error "Console interrupt -- cannot continue."))) |
125 |
|
|
126 |
|
(defun clcs-break-quit (&optional (level 0)) |
127 |
|
(let ((abort (nth level (cons (find-restart 'conditions::gcl-top-restart) (reverse *abort-restarts*))))) |
128 |
|
(when abort (invoke-restart-interactively abort))) |
129 |
|
(break-current)) |
130 |
|
|
131 |
|
(setq conditions::*debugger-function* 'break-level) |
132 |
|
(setq conditions::*debug-command-prefix* "") |
133 |
|
|
134 |
|
(defun break-resume () |
135 |
|
(and *debug-continue* (invoke-restart *debug-continue*))) |
136 |
|
|
137 |
|
(putprop :r 'break-resume 'break-command) |
138 |
|
(putprop :s 'show-restarts 'break-command) |
139 |
|
|
140 |
|
(defun break-help () |
141 |
|
(format *debug-io* " |
142 |
|
Break-loop Command Summary ([] indicates optional arg) |
143 |
|
-------------------------- |
144 |
|
|
145 |
|
:bl [j] show local variables and their values, or segment of vs if compiled |
146 |
|
in j stack frames starting at the current one. |
147 |
|
:bt [n] BACKTRACE [n steps] |
148 |
|
:down [i] DOWN i frames (one if no i) |
149 |
|
:env describe ENVIRONMENT of this stack frame (for interpreted). |
150 |
|
:fr [n] show frame n |
151 |
|
:loc [i] return i'th local of this frame if its function is compiled (si::loc i) |
152 |
|
:r RESUME (return from the current break loop). |
153 |
|
:up [i] UP i frames (one if no i) |
154 |
|
|
155 |
|
Example: print a bactrace of the last 4 frames |
156 |
|
|
157 |
|
>>:bt 4 |
158 |
|
|
159 |
|
Note: (use-fast-links nil) makes all non system function calls |
160 |
|
be recorded in the stack. (use-fast-links t) is the default |
161 |
|
|
162 |
|
|
163 |
|
Low level commands: |
164 |
|
------------------ |
165 |
|
:p [i] make current the i'th PREVIOUS frame (in list show by :b) |
166 |
|
:n [i] make current the i'th NEXT frame (in list show by :b) |
167 |
|
:go [ihs-index] make current the frame corresponding ihs-index |
168 |
|
:m print the last break message. |
169 |
|
:s show restarts. |
170 |
|
:c show function of the current ihs frame. |
171 |
|
:q [i] quit to top level |
172 |
|
:r resume from this break loop. |
173 |
|
:b full backtrace of all functions and special forms. |
174 |
|
:bs [name] backward search for frame named 'name' |
175 |
|
:fs [name] search for frame named 'name' |
176 |
|
:vs [from] [to] Show value stack between FROM and TO |
177 |
|
:ihs [from] [to] Show Invocation History Stack |
178 |
|
:bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 |
179 |
|
|
180 |
|
") |
181 |
|
(values) |
182 |
|
) |