1 |
|
;;Copyright William F. Schelter 1990, All Rights Reserved |
2 |
|
|
3 |
|
|
4 |
|
(In-package "SYSTEM") |
5 |
|
(import 'sloop::sloop) |
6 |
|
|
7 |
|
(eval-when (compile eval) |
8 |
|
(proclaim '(optimize (safety 2) (space 3))) |
9 |
|
|
10 |
|
(defmacro f (op &rest args) |
11 |
|
`(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) |
12 |
|
|
13 |
|
(defmacro fb (op &rest args) |
14 |
|
`(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) |
15 |
|
|
16 |
|
) |
17 |
|
|
18 |
|
;;; Some debugging features: |
19 |
|
;;; Search-stack : |
20 |
|
;;; (:s "cal") or (:s 'cal) searches the stack for a frame whose function or |
21 |
|
;;; special form has a name containing "cal", moves there to display the local |
22 |
|
;;; data. |
23 |
|
;;; |
24 |
|
;;; Break-locals : |
25 |
|
;;; :bl displays the args and locals of the current function. |
26 |
|
;;; (:bl 4) does this for 4 functions. |
27 |
|
;;; |
28 |
|
;;; (si:loc i) accesses the local(i): slot. |
29 |
|
;;; the *print-level* and *print-depth* are bound to *debug-print-level* |
30 |
|
|
31 |
|
;;; Note you must have space < 3 in your optimize proclamation, in order for |
32 |
|
;;; the local variable names to be saved by the compiler. |
33 |
|
|
34 |
|
;;; With BSD You may also use the function write-debug-symbols to |
35 |
|
;;; obtain an object file with the correct symbol information for using a |
36 |
|
;;; c debugger, on translated lisp code. You should have used the :debug |
37 |
|
;;; t keyword when compiling the file. |
38 |
|
|
39 |
|
;;; To Do: add setf method for si:loc. |
40 |
|
;;; add restart capability from various spots on the stack. |
41 |
|
|
42 |
|
(defun show-break-variables (&optional (n 1)) |
43 |
|
(loop |
44 |
|
;(break-current) |
45 |
|
(dolist (v (reverse(car *break-env*))) |
46 |
|
(format *debug-io* "~%~9a: ~s" (car v) (second v))) |
47 |
|
(or (fb > (incf n -1) 0) (return (values))) |
48 |
|
(break-previous) |
49 |
|
)) |
50 |
|
|
51 |
|
(defun show-environment (ihs) |
52 |
|
(let ((lis (vs (ihs-vs ihs)))) |
53 |
|
(if (listp lis) |
54 |
|
(dolist (v (reverse (vs (ihs-vs ihs)))) |
55 |
|
(format *debug-io* "~%~9a: ~s" (car v) (second v)))))) |
56 |
|
|
57 |
|
(putprop :a 'show-break-variables 'break-command) |
58 |
|
|
59 |
|
;;make hack in compiler to remember the local variable names for the |
60 |
|
;;vs variables and associate it with the function name |
61 |
|
|
62 |
|
(defun search-stack (sym &aux string) |
63 |
|
(setq string (cond((symbolp sym)(symbol-name sym)) |
64 |
|
(t sym))) |
65 |
|
(sloop |
66 |
|
for ihs downfrom (ihs-top) above 2 |
67 |
|
for fun = (ihs-fun ihs) with name |
68 |
|
do |
69 |
|
(cond ((compiled-function-p fun) |
70 |
|
(setq name (compiled-function-name fun))) |
71 |
|
((symbolp fun ) (setq name fun)) |
72 |
|
((and (listp fun) |
73 |
|
(member (car fun) '(lambda lambda-block))) |
74 |
|
(setq name (second fun))) |
75 |
|
(t (setq name '||))) |
76 |
|
when (search string (symbol-name name) :test 'equal) |
77 |
|
do (return (progn (break-go ihs)(terpri) (break-locals))) |
78 |
|
finally (format *debug-io* "~%Search for ~a failed" string) |
79 |
|
)) |
80 |
|
|
81 |
|
(defvar *debug-print-level* 3) |
82 |
|
|
83 |
|
(defun break-locals (&optional (n 1) |
84 |
|
&aux (ihs *current-ihs*) |
85 |
|
(base (ihs-vs ihs)) |
86 |
|
(*print-level* *debug-print-level*) |
87 |
|
*print-circle* |
88 |
|
(*print-length* *debug-print-level*) |
89 |
|
(current-ihs *current-ihs*) |
90 |
|
(fun (ihs-fun ihs)) name args) |
91 |
|
(cond ((fb > n 1) |
92 |
|
(sloop for i below n |
93 |
|
for ihs downfrom current-ihs above 2 |
94 |
|
do (let ((*current-ihs* ihs)) |
95 |
|
(break-locals) (terpri)(terpri) |
96 |
|
))) |
97 |
|
(t |
98 |
|
(cond ((compiled-function-p fun) |
99 |
|
(setq name (compiled-function-name fun))) |
100 |
|
(t (setq name fun))) |
101 |
|
(if (symbolp name)(setq args (get name 'debug))) |
102 |
|
(let ((next (ihs-vs (f + 1 *current-ihs*)))) |
103 |
|
(cond (next |
104 |
|
(format *debug-io* ">> ~a():" name) |
105 |
|
(cond ((symbolp name) |
106 |
|
(sloop for i from base below next for j from 0 |
107 |
|
for u = nil |
108 |
|
do |
109 |
|
(cond ((member 0 args);;old debug info. |
110 |
|
(setf u (getf args j))) |
111 |
|
(t (setf u (nth j args)))) |
112 |
|
(cond (u |
113 |
|
(format t |
114 |
|
"~%Local~a(~a): ~a" j u (vs i))) |
115 |
|
(t |
116 |
|
(format *debug-io* "~%Local(~d): ~a" |
117 |
|
j (vs i)))))) |
118 |
|
((listp name) |
119 |
|
(show-environment ihs)) |
120 |
|
(t (format *debug-io* "~%Which case is this??"))))))))) |
121 |
|
|
122 |
|
(defun loc (&optional (n 0)) |
123 |
|
(let ((base (ihs-vs *current-ihs*))) |
124 |
|
(unless (and (fb >= n 0) |
125 |
|
(fb < n (f - (ihs-vs |
126 |
|
(min (ihs-top) (f + 1 *current-ihs*))) |
127 |
|
base))) |
128 |
|
(error "Not in current function")) |
129 |
|
(vs (f + n base)))) |
130 |
|
|
131 |
|
(putprop :bl 'break-locals 'break-command) |
132 |
|
(putprop :s 'search-stack 'break-command) |
133 |
|
|
134 |
|
(defvar *record-line-info* (make-hash-table :test 'eq)) |
135 |
|
|
136 |
|
(defvar *at-newline* nil) |
137 |
|
|
138 |
|
(defvar *standard-readtable* *readtable*) |
139 |
|
|
140 |
|
(defvar *line-info-readtable* (copy-readtable)) |
141 |
|
|
142 |
|
(defvar *left-parenthesis-reader* (get-macro-character #\( )) |
143 |
|
|
144 |
|
(defvar *quotation-reader* (get-macro-character #\" )) |
145 |
|
|
146 |
|
(defvar *stream-alist* nil) |
147 |
|
|
148 |
|
(defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t)) |
149 |
|
|
150 |
|
(defvar *step-next* nil) |
151 |
|
|
152 |
|
(defvar *last-dbl-break* nil) |
153 |
|
|
154 |
|
#-gcl |
155 |
|
(eval-when (compile eval load) |
156 |
|
|
157 |
|
(defvar *places* '(|*mv0*| |*mv1*| |*mv2*| |*mv3*| |*mv4*| |*mv5*| |*mv6*| |*mv7*| |
158 |
|
|*mv8*| |*mv9*|)) |
159 |
|
|
160 |
|
(defmacro set-mv (i val) `(setf ,(nth i *places*) ,val)) |
161 |
|
|
162 |
|
(defmacro mv-ref (i) (nth i *places*)) |
163 |
|
) |
164 |
|
|
165 |
|
(defmacro mv-setq (lis form) |
166 |
|
`(prog1 (setf ,(car lis) ,form) |
167 |
|
,@ (do ((v (cdr lis) (cdr v)) |
168 |
|
(i 0 (1+ i)) |
169 |
|
(res)) |
170 |
|
((null v)(reverse res)) |
171 |
|
(push `(setf ,(car v) (mv-ref ,i)) res)))) |
172 |
|
|
173 |
|
(defmacro mv-values (&rest lis) |
174 |
|
`(prog1 ,(car lis) |
175 |
|
,@ (do ((v (cdr lis) (cdr v)) |
176 |
|
(i 0 (1+ i)) |
177 |
|
(res)) |
178 |
|
((null v)(reverse res)) |
179 |
|
(push `(set-mv ,i ,(car v)) res)))) |
180 |
|
|
181 |
|
;;start a lisp debugger loop. Exit it by using :step |
182 |
|
|
183 |
|
(defun dbl () |
184 |
|
(break-level nil nil)) |
185 |
|
|
186 |
|
(defstruct instream stream (line 0 :type fixnum) stream-name) |
187 |
|
|
188 |
|
|
189 |
|
(eval-when (eval compile) |
190 |
|
|
191 |
|
(defstruct (bkpt (:type list)) form file file-line function) |
192 |
|
) |
193 |
|
|
194 |
|
(defun cleanup () |
195 |
|
(dolist (v *stream-alist*) |
196 |
|
(if (closedp (instream-stream v)) |
197 |
|
(setq *stream-alist* (delete v *stream-alist*))))) |
198 |
|
|
199 |
|
(defun get-instream (str) |
200 |
|
(or (dolist (v *stream-alist*) |
201 |
|
(cond ((eq str (instream-stream v)) |
202 |
|
(return v)))) |
203 |
|
(car (setq *stream-alist* |
204 |
|
(cons (make-instream :stream str |
205 |
|
:stream-name (if (streamp str) |
206 |
|
(stream-name str)) |
207 |
|
) *stream-alist*))))) |
208 |
|
|
209 |
|
(defun newline (str ch) ch |
210 |
|
(let ((in (get-instream str))) |
211 |
|
(setf (instream-line in) (the fixnum (f + 1 (instream-line in))))) |
212 |
|
;; if the next line begins with '(', then record all cons's eg arglist ) |
213 |
|
(setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) |
214 |
|
(values)) |
215 |
|
|
216 |
|
(defun quotation-reader (str ch) |
217 |
|
(let ((tem (funcall *quotation-reader* str ch)) |
218 |
|
(instr (get-instream str))) |
219 |
|
(incf (instream-line instr) (count #\newline tem)) |
220 |
|
tem)) |
221 |
|
|
222 |
|
(defvar *old-semicolon-reader* (get-macro-character #\;)) |
223 |
|
|
224 |
|
(defun new-semi-colon-reader (str ch) |
225 |
|
(let ((in (get-instream str)) |
226 |
|
(next (peek-char nil str nil nil))) |
227 |
|
(setf (instream-line in) (the fixnum (f + 1 (instream-line in)))) |
228 |
|
(cond ((eql next #\!) |
229 |
|
(read-char str) |
230 |
|
(let* ((*readtable* *standard-readtable*) |
231 |
|
(command (read-from-string (read-line str nil nil)))) |
232 |
|
(cond ((and (consp command) |
233 |
|
(eq (car command) :line) |
234 |
|
(stringp (second command)) |
235 |
|
(typep (third command) 'fixnum)) |
236 |
|
(setf (instream-stream-name in) (second command)) |
237 |
|
(setf (instream-line in) (third command)))) |
238 |
|
)) |
239 |
|
(t (funcall *old-semicolon-reader* str ch))) |
240 |
|
(setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) |
241 |
|
(values))) |
242 |
|
|
243 |
|
(defun setup-lineinfo () |
244 |
|
(set-macro-character #\newline #'newline nil *line-info-readtable*) |
245 |
|
(set-macro-character #\; #'new-semi-colon-reader nil *line-info-readtable*) |
246 |
|
(set-macro-character #\( 'left-parenthesis-reader nil *line-info-readtable*) |
247 |
|
(set-macro-character #\" 'quotation-reader nil *line-info-readtable*) |
248 |
|
|
249 |
|
) |
250 |
|
|
251 |
|
(defun nload (file &rest args ) |
252 |
|
(clrhash *record-line-info*) |
253 |
|
(cleanup) |
254 |
|
(setq file (truename file)) |
255 |
|
(setup-lineinfo) |
256 |
|
(let ((*readtable* *line-info-readtable*)) |
257 |
|
(apply 'load file args))) |
258 |
|
|
259 |
|
(eval-when (compile eval) |
260 |
|
|
261 |
|
(defmacro break-data (name line) `(cons ,name ,line)) |
262 |
|
) |
263 |
|
|
264 |
|
(defun left-parenthesis-reader (str ch &aux line(flag *at-newline*)) |
265 |
|
(if (eq *at-newline* t) (setq *at-newline* nil)) |
266 |
|
(when flag |
267 |
|
(setq flag (get-instream str)) |
268 |
|
(setq line (instream-line flag)) |
269 |
|
) |
270 |
|
(let ((tem (funcall *left-parenthesis-reader* str ch))) |
271 |
|
(when flag |
272 |
|
(setf (gethash tem *record-line-info*) |
273 |
|
(break-data (instream-name flag) |
274 |
|
line))) |
275 |
|
tem)) |
276 |
|
|
277 |
|
(defvar *fun-array* (make-array 50 :fill-pointer 0 :adjustable t)) |
278 |
|
|
279 |
|
(defun walk-through (body &aux tem) |
280 |
|
(tagbody |
281 |
|
top |
282 |
|
(cond ((consp body) |
283 |
|
(when (setq tem (gethash body *record-line-info*)) |
284 |
|
;; lines beginning with ((< u v)..) |
285 |
|
;; aren't eval'd but are part of a special form |
286 |
|
(cond ((and (consp (car body)) |
287 |
|
(not (eq (caar body) 'lambda))) |
288 |
|
(remhash body *record-line-info*) |
289 |
|
(setf (gethash (car body) *record-line-info*) |
290 |
|
tem)) |
291 |
|
(t (vector-push-extend (cons tem body) *fun-array*)))) |
292 |
|
(walk-through (car body)) |
293 |
|
(setq body (cdr body)) |
294 |
|
(go top)) |
295 |
|
(t nil)))) |
296 |
|
|
297 |
|
(defun compiler::compiler-def-hook (name body &aux (ar *fun-array*) |
298 |
|
(min most-positive-fixnum) |
299 |
|
(max -1)) |
300 |
|
(declare (fixnum min max)) |
301 |
|
;; (cond ((and (boundp '*do-it*) |
302 |
|
;; (eq (car body) 'lambda-block)) |
303 |
|
;; (setf (cdr body) (cdr (walk-top body))))) |
304 |
|
|
305 |
|
(cond ((atom body) |
306 |
|
(remprop name 'line-info)) |
307 |
|
((eq *readtable* *line-info-readtable*) |
308 |
|
(setf (fill-pointer *fun-array*) 0) |
309 |
|
(walk-through body) |
310 |
|
(dotimes (i (length ar)) |
311 |
|
(declare (fixnum i)) |
312 |
|
(let ((n (cdar (aref ar i)))) |
313 |
|
(declare (fixnum n)) |
314 |
|
(if (fb > n max) (setf max n)) |
315 |
|
(if (fb < n min) (setf min n)))) |
316 |
|
(cond ((fb > (length *fun-array*) 0) |
317 |
|
(let ((new (make-array (f + (f - max min) 2) |
318 |
|
:initial-element :blank-line)) |
319 |
|
(old-info (get name 'line-info))) |
320 |
|
(setf (aref new 0) |
321 |
|
(cons (caar (aref ar 0)) min)) |
322 |
|
(setq min (f - min 1)) |
323 |
|
(dotimes (i (length ar)) |
324 |
|
(let ((y (aref ar i))) |
325 |
|
(setf (aref new (f - (cdar y) min)) |
326 |
|
(cdr y)))) |
327 |
|
(setf (get name 'line-info) new) |
328 |
|
(when |
329 |
|
old-info |
330 |
|
(let ((tem (get name 'break-points)) |
331 |
|
(old-begin (cdr (aref old-info 0)))) |
332 |
|
(dolist (bptno tem) |
333 |
|
(let* ((bpt (aref *break-points* bptno)) |
334 |
|
(fun (bkpt-function bpt)) |
335 |
|
(li (f - (bkpt-file-line bpt) old-begin))) |
336 |
|
(setf (aref *break-points* bptno) |
337 |
|
(make-break-point fun new li)))))))) |
338 |
|
(t (let ((tem (get name 'break-points))) |
339 |
|
(iterate-over-bkpts tem :delete))))))) |
340 |
|
|
341 |
|
(defun instream-name (instr) |
342 |
|
(or (instream-stream-name instr) |
343 |
|
(stream-name (instream-stream instr)))) |
344 |
|
|
345 |
|
(eval-when (eval) |
346 |
|
|
347 |
|
(defun stream-name (str) (namestring (pathname str))) |
348 |
|
) |
349 |
|
(clines "static object stream_name(str) object str;{ |
350 |
|
if (str->sm.sm_object1 != 0 && type_of(str->sm.sm_object1)==t_string) |
351 |
|
return str->sm.sm_object1; else return Cnil; }") |
352 |
|
|
353 |
|
(defentry stream-name (object) (object "stream_name")) |
354 |
|
|
355 |
|
(clines "static object closedp(str) object str;{return (str->sm.sm_fp==0 ? Ct :Cnil); }") |
356 |
|
|
357 |
|
(defentry closedp (object) (object "closedp")) |
358 |
|
|
359 |
|
(defun find-line-in-fun (form env fun counter &aux tem) |
360 |
|
(setq tem (get fun 'line-info)) |
361 |
|
(if tem |
362 |
|
(let ((ar tem)) |
363 |
|
(declare (type (array (t)) ar)) |
364 |
|
(when ar |
365 |
|
(dotimes |
366 |
|
(i (length ar)) |
367 |
|
(cond ((eq form (aref ar i)) |
368 |
|
(when counter |
369 |
|
(decf (car counter)) |
370 |
|
(cond ((fb > (car counter) 0) |
371 |
|
;silent |
372 |
|
(return-from find-line-in-fun :break)))) |
373 |
|
(break-level |
374 |
|
(setq *last-dbl-break* (make-break-point fun ar i)) env |
375 |
|
) |
376 |
|
(return-from find-line-in-fun :break)))))))) |
377 |
|
|
378 |
|
;; get the most recent function on the stack with step info. |
379 |
|
|
380 |
|
(defun current-step-fun ( &optional (ihs (ihs-top)) ) |
381 |
|
(do ((i (1- ihs) (f - i 1))) |
382 |
|
((fb <= i 0)) |
383 |
|
(let ((na (ihs-fname i))) |
384 |
|
(if (get na 'line-info) (return na))))) |
385 |
|
|
386 |
|
(defun init-break-points () |
387 |
|
(setf (fill-pointer *break-point-vector*) 0) |
388 |
|
(setf *break-points* *break-point-vector*)) |
389 |
|
|
390 |
|
(defun step-into (&optional (n 1)) |
391 |
|
;(defun step-into () |
392 |
|
(declare (ignore n)) |
393 |
|
;;FORM is the next form about to be evaluated. |
394 |
|
(or *break-points* (init-break-points)) |
395 |
|
(setq *break-step* 'break-step-into) |
396 |
|
:resume) |
397 |
|
|
398 |
|
(defun step-next ( &optional (n 1)) |
399 |
|
(let ((fun (current-step-fun))) |
400 |
|
(setq *step-next* (cons n fun)) |
401 |
|
(or *break-points* (init-break-points)) |
402 |
|
(setq *break-step* 'break-step-next) |
403 |
|
:resume)) |
404 |
|
|
405 |
|
(defun maybe-break (form line-info fun env &aux pos) |
406 |
|
(cond ((setq pos (position form line-info)) |
407 |
|
(setq *break-step* nil) |
408 |
|
(or (> (length *break-points*) 0) |
409 |
|
(setf *break-points* nil)) |
410 |
|
(break-level (make-break-point fun line-info pos) env) |
411 |
|
t))) |
412 |
|
|
413 |
|
;; These following functions, when they are the value of *break-step* |
414 |
|
;; are invoked by an inner hook in eval. They may choose to stop |
415 |
|
;; things. |
416 |
|
|
417 |
|
(defun break-step-into (form env) |
418 |
|
(let ((fun (current-step-fun))) |
419 |
|
(let ((line-info (get fun 'line-info))) |
420 |
|
(maybe-break form line-info fun env)))) |
421 |
|
|
422 |
|
(defun break-step-next (form env) |
423 |
|
(let ((fun (current-step-fun))) |
424 |
|
(cond ((eql (cdr *step-next*) fun) |
425 |
|
(let ((line-info (get fun 'line-info))) |
426 |
|
(maybe-break form line-info fun env)))))) |
427 |
|
|
428 |
|
(setf (get :next 'break-command) 'step-next) |
429 |
|
(setf (get :step 'break-command) 'step-into) |
430 |
|
(setf (get :loc 'break-command) 'loc) |
431 |
|
|
432 |
|
|
433 |
|
(defun *break-points* (form env) |
434 |
|
(let ((pos(position form *break-points* :key 'car))) |
435 |
|
(format t "Bkpt ~a:" pos) |
436 |
|
(break-level (aref *break-points* pos) env))) |
437 |
|
|
438 |
|
|
439 |
|
(defun dwim (fun) |
440 |
|
(dolist (v (list-all-packages)) |
441 |
|
(multiple-value-bind |
442 |
|
(sym there) |
443 |
|
(intern (symbol-name fun) v) |
444 |
|
(cond ((get sym 'line-info) |
445 |
|
(return-from dwim sym)) |
446 |
|
(t (or there (unintern sym)))))) |
447 |
|
(format t "~a has no line information" fun)) |
448 |
|
|
449 |
|
(defun break-function (fun &optional (li 1) absolute &aux fun1) |
450 |
|
(let ((ar (get fun 'line-info))) |
451 |
|
(when (null ar) (setq fun1 (dwim fun)) |
452 |
|
(if fun1 (return-from break-function |
453 |
|
(break-function fun1 li absolute)))) |
454 |
|
(or (arrayp ar)(progn (format t "~%No line info for ~a" fun) |
455 |
|
(return-from break-function nil))) |
456 |
|
(let ((beg (cdr (aref ar 0)))) |
457 |
|
(if absolute (setq li (f - li beg))) |
458 |
|
(or (and (fb >= li 1) (fb < li (length ar))) |
459 |
|
(progn (format t "~%line out of bounds for ~a" fun)) |
460 |
|
(return-from break-function nil)) |
461 |
|
(if (eql li 1) |
462 |
|
(let ((tem (symbol-function fun))) |
463 |
|
(cond ((and (consp tem) |
464 |
|
(eq (car tem) 'lambda-block) |
465 |
|
(third tem)) |
466 |
|
(setq li 2))))) |
467 |
|
(dotimes (i (f - (length ar) li)) |
468 |
|
(when (not (eq (aref ar i) :blank-line)) |
469 |
|
(show-break-point (insert-break-point |
470 |
|
(make-break-point fun ar (f + li i)))) |
471 |
|
(return-from break-function (values)))) |
472 |
|
(format t "~%Beyond code for ~a ")))) |
473 |
|
|
474 |
|
(defun insert-break-point (bpt &aux at) |
475 |
|
(or *break-points* (init-break-points)) |
476 |
|
(setq at (or (position nil *break-points*) |
477 |
|
(prog1 (length *break-points*) |
478 |
|
(vector-push-extend nil *break-points*) |
479 |
|
))) |
480 |
|
(let ((fun (bkpt-function bpt))) |
481 |
|
(push at (get fun 'break-points))) |
482 |
|
(setf (aref *break-points* at) bpt) |
483 |
|
at) |
484 |
|
|
485 |
|
(defun short-name (name) |
486 |
|
(let ((Pos (position #\/ name :from-end t))) |
487 |
|
(if pos (subseq name (f + 1 pos)) name))) |
488 |
|
|
489 |
|
(defun show-break-point (n &aux disabled) |
490 |
|
(let ((bpt (aref *break-points* n))) |
491 |
|
(when bpt |
492 |
|
(when (eq (car bpt) nil) |
493 |
|
(setq disabled t) |
494 |
|
(setq bpt (cdr bpt))) |
495 |
|
(format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]" |
496 |
|
n (short-name (second bpt)) |
497 |
|
(third bpt) disabled) |
498 |
|
(let ((fun (fourth bpt))) |
499 |
|
(format t "(line ~a of ~a)" (relative-line fun (nth 2 bpt)) |
500 |
|
fun |
501 |
|
))))) |
502 |
|
|
503 |
|
(defun iterate-over-bkpts (l action) |
504 |
|
(dotimes (i (length *break-points*)) |
505 |
|
(if (or (member i l) |
506 |
|
(null l)) |
507 |
|
(let ((tem (aref *break-points* i))) |
508 |
|
(setf (aref *break-points* i) |
509 |
|
(case action |
510 |
|
(:delete |
511 |
|
(if tem (setf (get (bkpt-function tem) 'break-points) |
512 |
|
(delete i (get (bkpt-function tem) 'break-points)))) |
513 |
|
nil) |
514 |
|
(:enable |
515 |
|
(if (eq (car tem) nil) (cdr tem) nil)) |
516 |
|
(:disable |
517 |
|
(if (and tem (not (eq (car tem) nil))) |
518 |
|
(cons nil tem) |
519 |
|
tem)) |
520 |
|
(:show |
521 |
|
(when tem (show-break-point i) |
522 |
|
(terpri)) |
523 |
|
tem |
524 |
|
))))))) |
525 |
|
|
526 |
|
(setf (get :info 'break-command) |
527 |
|
'(lambda (type) |
528 |
|
(case type |
529 |
|
(:bkpt (iterate-over-bkpts nil :show)) |
530 |
|
(otherwise |
531 |
|
(format t "usage: :info :bkpt -- show breakpoints") |
532 |
|
)))) |
533 |
|
|
534 |
|
(defun complete-prop (sym package prop &optional return-list) |
535 |
|
(cond ((and (symbolp sym)(get sym prop)(equal (symbol-package sym) |
536 |
|
(find-package package))) |
537 |
|
(return-from complete-prop sym))) |
538 |
|
(sloop for v in-package package |
539 |
|
when (and (get v prop) |
540 |
|
(eql (string-match sym v) 0)) |
541 |
|
collect v into all |
542 |
|
finally |
543 |
|
|
544 |
|
(cond (return-list (return-from complete-prop all)) |
545 |
|
((> (length all) 1) |
546 |
|
(format t "~&Not unique with property ~(~a: ~{~s~^, ~}~)." |
547 |
|
prop all)) |
548 |
|
|
549 |
|
((null all) |
550 |
|
(format t "~& ~a is not break command" sym)) |
551 |
|
(t (return-from complete-prop |
552 |
|
(car all)))))) |
553 |
|
|
554 |
|
(setf (get :delete 'break-command) |
555 |
|
'(lambda (&rest l) (iterate-over-bkpts l :delete)(values))) |
556 |
|
(setf (get :disable 'break-command) |
557 |
|
'(lambda (&rest l) (iterate-over-bkpts l :disable)(values))) |
558 |
|
(setf (get :enable 'break-command) |
559 |
|
'(lambda (&rest l) (iterate-over-bkpts l :enable)(values))) |
560 |
|
(setf (get :break 'break-command) |
561 |
|
'(lambda (&rest l) |
562 |
|
(print l) |
563 |
|
(cond (l |
564 |
|
(apply 'si::break-function l)) |
565 |
|
(*last-dbl-break* |
566 |
|
(let ((fun (nth 3 *last-dbl-break*))) |
567 |
|
(si::break-function fun (nth 2 *last-dbl-break*) t)))))) |
568 |
|
|
569 |
|
(setf (get :fr 'break-command) |
570 |
|
'(lambda (&rest l ) |
571 |
|
(dbl-up (or (car l) 0) *ihs-top*) |
572 |
|
(values))) |
573 |
|
|
574 |
|
(setf (get :up 'break-command) |
575 |
|
'(lambda (&rest l ) |
576 |
|
(dbl-up (or (car l) 1) *current-ihs*) |
577 |
|
(values))) |
578 |
|
|
579 |
|
(setf (get :down 'break-command) |
580 |
|
'(lambda (&rest l ) |
581 |
|
(dbl-up ( - (or (car l) 1)) *current-ihs*) |
582 |
|
(values))) |
583 |
|
|
584 |
|
;; in other common lisps this should be a string output stream. |
585 |
|
|
586 |
|
(defvar *display-string* |
587 |
|
(make-array 100 :element-type 'string-char :fill-pointer 0 :adjustable t)) |
588 |
|
|
589 |
|
(defun display-env (n env) |
590 |
|
(do ((v (reverse env) (cdr v))) |
591 |
|
((or (not (consp v)) (fb > (fill-pointer *display-string*) n))) |
592 |
|
(or (and (consp (car v)) |
593 |
|
(listp (cdar v))) |
594 |
|
(return)) |
595 |
|
(format *display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))) |
596 |
|
|
597 |
|
(defun apply-display-fun (display-fun n lis) |
598 |
|
(let ((*print-length* *debug-print-level*) |
599 |
|
(*print-level* *debug-print-level*) |
600 |
|
(*print-pretty* nil) |
601 |
|
(*PRINT-CASE* :downcase) |
602 |
|
(*print-circle* t) |
603 |
|
) |
604 |
|
(setf (fill-pointer *display-string*) 0) |
605 |
|
(format *display-string* "{") |
606 |
|
(funcall display-fun n lis) |
607 |
|
(when (fb > (fill-pointer *display-string*) n) |
608 |
|
(setf (fill-pointer *display-string*) n) |
609 |
|
(format *display-string* "...")) |
610 |
|
|
611 |
|
(format *display-string* "}") |
612 |
|
) |
613 |
|
*display-string* |
614 |
|
) |
615 |
|
|
616 |
|
(setf (get :bt 'break-command) 'dbl-backtrace) |
617 |
|
(setf (get '*break-points* 'dbl-invisible) t) |
618 |
|
|
619 |
|
(defun get-line-of-form (form line-info) |
620 |
|
(let ((pos (position form line-info))) |
621 |
|
(if pos (f + pos (cdr (aref line-info 0)))))) |
622 |
|
|
623 |
|
(defun get-next-visible-fun (ihs) |
624 |
|
(do ((j ihs (f - j 1))) |
625 |
|
((fb < j *ihs-base*) |
626 |
|
(mv-values nil j)) |
627 |
|
(let |
628 |
|
((na (ihs-fname j))) |
629 |
|
(cond ((special-form-p na)) |
630 |
|
((get na 'dbl-invisible)) |
631 |
|
((fboundp na)(return (mv-values na j))))))) |
632 |
|
|
633 |
|
(defun dbl-what-frame (ihs &aux (j *ihs-top*) (i 0) na) |
634 |
|
(declare (fixnum ihs j i)) |
635 |
|
(loop |
636 |
|
(mv-setq (na j) (get-next-visible-fun j)) |
637 |
|
(cond ((fb <= j ihs) (return i))) |
638 |
|
(setq i (f + i 1)) |
639 |
|
(setq j (f - j 1)))) |
640 |
|
|
641 |
|
(defun dbl-up (n ihs &aux m fun line file env ) |
642 |
|
(setq m (dbl-what-frame ihs)) |
643 |
|
(cond ((fb >= n 0) |
644 |
|
(mv-setq (*current-ihs* n fun line file env) |
645 |
|
(nth-stack-frame n ihs)) |
646 |
|
(set-env) |
647 |
|
(print-stack-frame (f + m n) t *current-ihs* fun line file env)) |
648 |
|
(t (setq n (f + m n)) |
649 |
|
(or (fb >= n 0) (setq n 0)) |
650 |
|
(dbl-up n *ihs-top*)))) |
651 |
|
|
652 |
|
(dolist (v '( break-level universal-error-handler terminal-interrupt |
653 |
|
break-level evalhook find-line-in-fun)) |
654 |
|
(setf (get v 'dbl-invisible) t)) |
655 |
|
|
656 |
|
(defun next-stack-frame (ihs &aux line-info li i k na) |
657 |
|
(cond |
658 |
|
((fb < ihs *ihs-base*) (mv-values nil nil nil nil nil )) |
659 |
|
(t (let (fun) |
660 |
|
;; next lower visible ihs |
661 |
|
(mv-setq (fun i) (get-next-visible-fun ihs)) |
662 |
|
(setq na fun) |
663 |
|
(cond |
664 |
|
((and |
665 |
|
(setq line-info (get fun 'line-info)) |
666 |
|
(do ((j (f + ihs 1) (f - j 1)) |
667 |
|
(form )) |
668 |
|
((<= j i) nil) |
669 |
|
(setq form (ihs-fun j)) |
670 |
|
(cond ((setq li (get-line-of-form (ihs-fun j) line-info)) |
671 |
|
(return-from next-stack-frame |
672 |
|
(mv-values |
673 |
|
i fun li |
674 |
|
;; filename |
675 |
|
(car (aref line-info 0)) |
676 |
|
;;environment |
677 |
|
(list (vs (setq k (ihs-vs j))) |
678 |
|
(vs (1+ k)) |
679 |
|
(vs (+ k 2))) |
680 |
|
))))))) |
681 |
|
((special-form-p na) nil) |
682 |
|
((get na 'dbl-invisible)) |
683 |
|
((fboundp na) |
684 |
|
(mv-values i na nil nil |
685 |
|
(if (ihs-not-interpreted-env i) |
686 |
|
nil |
687 |
|
(let ((i (ihs-vs i))) |
688 |
|
(list (vs i) (vs (1+ i)) (vs (f + i 2)))))))) |
689 |
|
)))) |
690 |
|
|
691 |
|
(defun nth-stack-frame (n &optional (ihs *ihs-top*) |
692 |
|
&aux name line file env next) |
693 |
|
(or (fb >= n 0) (setq n 0)) |
694 |
|
(dotimes (i (f + n 1)) |
695 |
|
(setq next (next-stack-frame ihs)) |
696 |
|
(cond (next |
697 |
|
(mv-setq (ihs name line file env) next) |
698 |
|
(setq ihs (f - next 1))) |
699 |
|
(t (return (setq n (f - i 1)))))) |
700 |
|
|
701 |
|
(setq ihs (f + ihs 1) name (ihs-fname ihs)) |
702 |
|
(mv-values ihs n name line file env )) |
703 |
|
|
704 |
|
(defun dbl-backtrace (&optional (m 1000) (ihs *ihs-top*) &aux fun file |
705 |
|
line env (i 0)) |
706 |
|
(loop |
707 |
|
(mv-setq (ihs fun line file env) (next-stack-frame ihs)) |
708 |
|
(or fun (return nil)) |
709 |
|
(print-stack-frame i nil ihs fun line file env) |
710 |
|
(incf i) |
711 |
|
(cond ((fb >= i m) (return (values)))) |
712 |
|
(setq ihs (f - ihs 1)) |
713 |
|
) |
714 |
|
(values)) |
715 |
|
|
716 |
|
(defun display-compiled-env ( plength ihs &aux |
717 |
|
(base (ihs-vs ihs)) |
718 |
|
(end (min (ihs-vs (1+ ihs)) (vs-top)))) |
719 |
|
(format *display-string* "") |
720 |
|
(do ((i base ) |
721 |
|
(v (get (ihs-fname ihs) 'debug) (cdr v))) |
722 |
|
((or (fb >= i end)(fb > (fill-pointer *display-string*) plength))) |
723 |
|
(format *display-string* "~a~@[~d~]=~s~@[,~]" |
724 |
|
(or (car v) 'loc) (if (not (car v)) (f - i base)) (vs i) |
725 |
|
(fb < (setq i (f + i 1)) end))) |
726 |
|
) |
727 |
|
|
728 |
|
(defun computing-args-p (ihs) |
729 |
|
;; When running interpreted we want a line like |
730 |
|
;; (list joe jane) to get recorded in the invocation |
731 |
|
;; history while joe and jane are being evaluated, |
732 |
|
;; even though list has not yet been invoked. We put |
733 |
|
;; it in the history, but with the previous lexical environment. |
734 |
|
(and (consp (ihs-fun ihs)) |
735 |
|
(> ihs 3) |
736 |
|
(not (member (car (ihs-fun ihs)) '(lambda-block lambda))) |
737 |
|
;(<= (ihs-vs ihs) (ihs-vs (- ihs 1))) |
738 |
|
) |
739 |
|
) |
740 |
|
|
741 |
|
|
742 |
|
(defun print-stack-frame (i auto-display ihs fun &optional line file env) |
743 |
|
(declare (ignore env)) |
744 |
|
(when (and auto-display line) |
745 |
|
(format *debug-io* "~a:~a:0:beg~%" file line)) |
746 |
|
(let ((computing-args (computing-args-p ihs))) |
747 |
|
(format *debug-io* "~&#~d ~@[~a~] ~a ~@[~a~] " i |
748 |
|
(and computing-args "Computing args for ") |
749 |
|
fun |
750 |
|
(if (not (ihs-not-interpreted-env ihs)) |
751 |
|
(apply-display-fun 'display-env 80 |
752 |
|
(car (vs (ihs-vs ihs)))) |
753 |
|
(apply-display-fun 'display-compiled-env 80 ihs))) |
754 |
|
(if file (format *debug-io* "(~a line ~a)" file line)) |
755 |
|
(format *debug-io* "[ihs=~a]" ihs) |
756 |
|
)) |
757 |
|
|
758 |
|
(defun make-break-point (fun ar i) |
759 |
|
(list ;make-bkpt ;:form |
760 |
|
(aref ar i) |
761 |
|
;:file |
762 |
|
(car (aref ar 0)) |
763 |
|
;:file-line |
764 |
|
(f + (cdr (aref ar 0)) i) |
765 |
|
;:function |
766 |
|
fun) |
767 |
|
) |
768 |
|
|
769 |
|
(defun relative-line (fun l) |
770 |
|
(let ((info (get fun 'line-info))) |
771 |
|
(if info (f - l (cdr (aref info 0))) |
772 |
|
0))) |
773 |
|
|
774 |
|
(defvar *step-display* nil) |
775 |
|
|
776 |
|
(defvar *null-io* (make-broadcast-stream)) |
777 |
|
;; should really use serror to evaluate this inside. |
778 |
|
;; rather than just quietening it. It prints a long stack |
779 |
|
;; which is time consuming. |
780 |
|
|
781 |
|
(defun safe-eval (form env &aux *break-enable*) |
782 |
|
(let ((*error-output* *null-io*) |
783 |
|
(*debug-io* *null-io*)) |
784 |
|
(cond ((symbolp form) |
785 |
|
(unless (or (boundp form) |
786 |
|
(assoc form (car env))) |
787 |
|
(return-from safe-eval :<error>)))) |
788 |
|
(multiple-value-bind (er val) |
789 |
|
(si::error-set |
790 |
|
`(evalhook ',form nil nil ',env)) |
791 |
|
(if er :<error> val)))) |
792 |
|
|
793 |
|
(defvar *no-prompt* nil) |
794 |
|
|
795 |
|
(defun set-back (at env &aux (i *current-ihs*)) |
796 |
|
(setq *no-prompt* nil) |
797 |
|
(setq *current-ihs* i) |
798 |
|
(cond (env (setq *break-env* env)) |
799 |
|
(t (list (vs (ihs-vs i))))) |
800 |
|
|
801 |
|
(when at |
802 |
|
(format *debug-io* "~a:~a:0:beg~%" (second at) (third at)) |
803 |
|
(format *debug-io* "(~a line ~a) " |
804 |
|
(second at) (third at)) |
805 |
|
) |
806 |
|
(dolist (v *step-display*) |
807 |
|
(let ((res (safe-eval v env))) |
808 |
|
(or (eq res :<error>) |
809 |
|
(format t "(~s=~s)" v res))))) |
810 |
|
|
811 |
|
|
812 |
|
(eval-when (load eval) |
813 |
|
(pushnew :sdebug *features* ) |
814 |
|
;(use-fast-links nil) |
815 |
|
) |
816 |
|
|
817 |
|
|
818 |
|
|
819 |
|
|
820 |
|
|
821 |
|
|
822 |
|
|
823 |
|
|
824 |
|
|