/[gcl]/gcl/lsp/gcl_debug.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_debug.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:04 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26