← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/electric/intrepid

« back to all changes in this revision

Viewing changes to lib/lisp/debug

  • Committer: Bazaar Package Importer
  • Author(s): Chris Ruffin
  • Date: 2002-03-23 11:02:56 UTC
  • Revision ID: james.westby@ubuntu.com-20020323110256-mx008emo1nb2k11i
Tags: 6.05-1
http://bugs.debian.org/128765
* new upstream release
* added menu hints (closes: #128765)
* changed doc-base to go into Technical section per menu-policy

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/lisp/debug
 
1
;;; -*-Scheme-*-
 
2
;;;
 
3
;;; A simple debugger (needs much work)
 
4
 
 
5
(define (backtrace . args)
 
6
  (if (> (length args) 1)
 
7
      (error 'backtrace "too many arguments"))
 
8
  (if (not (null? args))
 
9
      (if (not (eq? (type (car args)) 'control-point))
 
10
          (error 'backtrace "argument must be a control point")))
 
11
  (let ((trace
 
12
         (apply backtrace-list args))
 
13
        (maxlen 28))
 
14
    (if (null? args)
 
15
        (set! trace (cdddr trace)))
 
16
    (for-each
 
17
     (lambda (frame)
 
18
       (let* ((func
 
19
              (format #f "~s" (vector-ref frame 0)))
 
20
             (indent 
 
21
              (- maxlen (string-length func))))
 
22
         (display func)
 
23
         (if (negative? indent)
 
24
             (begin
 
25
               (newline)
 
26
               (set! indent maxlen)))
 
27
         (do ((i indent (1- i)))
 
28
             ((> 0 i))
 
29
           (display " ")))
 
30
       (fluid-let
 
31
           ((print-depth 2)
 
32
            (print-length 3))
 
33
         (display (vector-ref frame 1)))
 
34
       (newline))
 
35
     trace))
 
36
  #v)
 
37
 
 
38
(define (show env)
 
39
  (fluid-let
 
40
      ((print-length 2)
 
41
       (print-depth 2))
 
42
    (do ((f (environment->list env) (cdr f)))
 
43
        ((null? f))
 
44
      (do ((b (car f) (cdr b)))
 
45
          ((null? b))
 
46
        (format #t "~s\t~s~%" (caar b) (cdar b)))
 
47
      (print '-------)))
 
48
  #v)
 
49
 
 
50
(define inspect)
 
51
 
 
52
(let ((frame)
 
53
      (trace)
 
54
      (help-text
 
55
       '("q   -- quit inspector"
 
56
         "f   -- print current frame"
 
57
         "u   -- go up one frame"
 
58
         "d   -- go down one frame"
 
59
         "^   -- go to top frame"
 
60
         "$   -- go to bottom frame"
 
61
         "e   -- eval expressions in environment"
 
62
         "p   -- pretty-print procedure"
 
63
         "v   -- show environment"
 
64
         "<n> -- pretty-print n-th argument"
 
65
         "o   -- obarray information")))
 
66
  
 
67
  (define (inspect-command-loop)
 
68
    (let ((input) (done #f))
 
69
      (display "inspect> ")
 
70
      (set! input (read))
 
71
      (case input
 
72
        (q
 
73
         (set! done #t))
 
74
        (? 
 
75
         (for-each
 
76
          (lambda (msg)
 
77
            (display msg)
 
78
            (newline))
 
79
          help-text))
 
80
        (f
 
81
         (print-frame))
 
82
        (^
 
83
         (set! frame 0)
 
84
         (print-frame))
 
85
        ($
 
86
         (set! frame (1- (length trace)))
 
87
         (print-frame))
 
88
        (u
 
89
         (if (zero? frame)
 
90
             (format #t "Already on top frame.~%")
 
91
             (set! frame (1- frame))
 
92
           (print-frame)))
 
93
        (d
 
94
         (if (= frame (1- (length trace)))
 
95
             (format #t "Already on bottom frame.~%")
 
96
             (set! frame (1+ frame))
 
97
           (print-frame)))
 
98
        (v
 
99
         (show (vector-ref (list-ref trace frame) 2)))
 
100
        (e
 
101
         (format #t "Type ^D to return to Inspector.~%")
 
102
         (let loop ()
 
103
           (display "eval> ")
 
104
           (set! input (read))
 
105
           (if (not (eof-object? input))
 
106
               (begin
 
107
                 (write (eval input
 
108
                              (vector-ref (list-ref trace frame) 2)))
 
109
                 (newline)
 
110
                 (loop))))
 
111
         (newline))
 
112
        (p
 
113
         (pp (vector-ref (list-ref trace frame) 0))
 
114
         (newline))
 
115
        (o
 
116
         (let ((l (map length (oblist))))
 
117
           (let ((n 0))
 
118
             (for-each (lambda (x) (set! n (+ x n))) l)
 
119
             (format #t "~s symbols " n)
 
120
             (format #t "(maximum bucket: ~s).~%" (apply max l)))))
 
121
        (else
 
122
         (cond
 
123
          ((integer? input)
 
124
           (let ((args (vector-ref (list-ref trace frame) 1)))
 
125
             (if (or (< input 1) (> input (length args)))
 
126
                 (format #t "No such argument.~%")
 
127
                 (pp (list-ref args (1- input)))
 
128
               (newline))))
 
129
          ((eof-object? input)
 
130
           (set! done #t))
 
131
          (else
 
132
           (format #t "Invalid command.  Type ? for help.~%")))))
 
133
      (if (not done)
 
134
          (inspect-command-loop))))
 
135
 
 
136
  (define (print-frame)
 
137
    (format #t "~%Frame ~s of ~s:~%~%" (1+ frame) (length trace))
 
138
    (let* ((f (list-ref trace frame)) (args (vector-ref f 1)))
 
139
      (format #t "Procedure:    ~s~%" (vector-ref f 0))
 
140
      (format #t "Environment:  ~s~%" (vector-ref f 2))
 
141
      (if (null? args)
 
142
          (format #t "No arguments.~%")
 
143
          (fluid-let
 
144
              ((print-depth 2)
 
145
               (print-length 3))
 
146
            (do ((i 1 (1+ i)) (args args (cdr args))) ((null? args))
 
147
              (format #t "Argument ~s:   ~s~%" i (car args))))))
 
148
    (newline))
 
149
  
 
150
  (set! inspect
 
151
        (lambda ()
 
152
          (set! frame 0)
 
153
          (set! trace (backtrace-list))
 
154
          (set! trace (cddr trace))
 
155
          (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
 
156
            (if (not (null? (vector-ref (car t) 1)))
 
157
                (let ((last (last-pair (vector-ref (car t) 1))))
 
158
                  (if (not (null? (cdr last)))
 
159
                      (begin
 
160
                        (format #t
 
161
 "[inspector: fixing improper arglist in frame ~s]~%" f)
 
162
                        (set-cdr! last (cons (cdr last) '())))))))
 
163
          (format #t "Inspector (type ? for help):~%")
 
164
          (let loop ()
 
165
            (if (call-with-current-continuation
 
166
                 (lambda (control-point)
 
167
                   (push-frame control-point)
 
168
                   (inspect-command-loop)
 
169
                   #f))
 
170
                (begin
 
171
                  (pop-frame)
 
172
                  (loop))))
 
173
          (newline)
 
174
          (pop-frame)
 
175
          (let ((next-frame (car rep-frames)))
 
176
            (next-frame #t)))))
 
177