source: project/release/4/debugger-protocol/tags/0.1/debugger-protocol.scm @ 33091

Last change on this file since 33091 was 33091, checked in by felix winkelmann, 4 years ago

added debugger-protocol egg

File size: 4.9 KB
Line 
1;;;; debugger api
2
3
4(module debugger-protocol (debugger-connection-in
5                           debugger-connection-out
6                           debugger-connection?
7                           dbg-info?
8                           dbg-info-event
9                           dbg-info-location
10                           dbg-info-value
11                           dbg-info-c-location
12                           dbg-info-data
13                           wait
14                           terminate
15                           continue
16                           list-events
17                           get-arguments
18                           set-event-mask
19                           set-breakpoint
20                           clear-breakpoint
21                           get-global
22                           get-bytes
23                           get-slots
24                           get-statistics
25                           get-trace)
26
27(import scheme chicken matchable)
28(use tcp extras)
29
30(define C_DEBUG_REPLY_UNUSED 0)
31(define C_DEBUG_REPLY_SETMASK 1)         
32(define C_DEBUG_REPLY_TERMINATE 2)       
33(define C_DEBUG_REPLY_CONTINUE 3)         
34(define C_DEBUG_REPLY_SET_BREAKPOINT 4)   
35(define C_DEBUG_REPLY_CLEAR_BREAKPOINT 5)
36(define C_DEBUG_REPLY_LIST_EVENTS 6)
37(define C_DEBUG_REPLY_GET_BYTES 7)
38(define C_DEBUG_REPLY_GET_AV 8)
39(define C_DEBUG_REPLY_GET_SLOTS 9)
40(define C_DEBUG_REPLY_GET_GLOBAL 10)
41(define C_DEBUG_REPLY_GET_STATS 11)
42(define C_DEBUG_REPLY_GET_TRACE 12)
43
44(define default-tcp-port 9999)
45(define default-listener #f)
46
47(define-record debugger-connection in out)
48(define-record dbg-info event location value c-location data)
49
50(define event-names
51  '((call 0)
52    (global-assign 1)
53    (gc 2) 
54    (entry 3) 
55    (signal 4) 
56    (connect 5) 
57    (listen 6) 
58    (interrupted 7)))
59
60(define-record-printer (dbg-info dinfo port)
61  (fprintf port "#<dbg-info ~S ~S ~S ~S>"
62    (dbg-info-event dinfo)
63    (dbg-info-location dinfo)
64    (dbg-info-value dinfo)
65    (dbg-info-data dinfo)))
66
67(define (wait #!optional (listener default-listener))
68  (unless listener 
69    (set! listener (tcp-listen default-tcp-port))
70    (set! default-listener listener))
71  (parameterize ((tcp-read-timeout #f))
72    (let-values (((in out) (tcp-accept listener)))
73      (let ((con (make-debugger-connection in out)))
74        ;; read initial event (connect)
75        (match (read in)
76          ((5 . _) 
77            (let-values (((us them) (tcp-addresses in)))
78               (fprintf (current-error-port) "; client connected from ~A~%"
79                 them)
80               con))
81          (evt (error "unexpected connection event" evt)))))))
82
83(define (send-reply con reply)
84  (let ((in (debugger-connection-in con))
85        (out (debugger-connection-out con)))
86    (write reply out)
87    (newline out)
88    (flush-output out)
89    (let ((evt (read in)))
90      (process-event con evt '()))))
91
92(define (process-event con evt pdata)
93  (match evt
94    ((? eof-object?) 
95      (fprintf (current-error-port) "; client closed connection~%")
96      (reverse pdata))
97    (('* data ...) 
98      (let ((more (read (debugger-connection-in con))))
99        (process-event con more (cons data pdata))))
100    (((? number? e) loc val cloc)
101      (make-dbg-info 
102        (car (list-ref event-names e) )
103        loc
104        val
105        cloc
106        (reverse pdata)))
107    (_ (error "corrupted debug event" evt))))
108
109(define (terminate con)
110  (send-reply con (list C_DEBUG_REPLY_TERMINATE))
111  (close-input-port (debugger-connection-in con))
112  (close-output-port (debugger-connection-out con)))
113
114(define (continue con)
115  (send-reply con (list C_DEBUG_REPLY_CONTINUE)))
116
117(define (list-events con #!optional (mstr ""))
118  (send-reply con (list C_DEBUG_REPLY_LIST_EVENTS mstr)))
119
120(define (get-arguments con) 
121  (send-reply con (list C_DEBUG_REPLY_GET_AV)))
122
123(define (set-event-mask con mask)
124  (send-reply 
125    con 
126    (list C_DEBUG_REPLY_SETMASK
127          (apply bitwise-ior
128            (map (lambda (x)
129                   (cond ((integer? x) x)
130                         ((assq x event-names) =>
131                           (lambda (a)
132                             (arithmetic-shift 1 (cadr a))))
133                         (else
134                           (print "bad event: " x)
135                           0)))
136                 mask)))))
137
138(define (set-breakpoint con . nums)
139  (for-each
140    (lambda (num)
141      (send-reply con (list C_DEBUG_REPLY_SET_BREAKPOINT num)))
142    nums))
143
144(define (clear-breakpoint con . nums)
145  (for-each
146    (lambda (num)
147      (send-reply con (list C_DEBUG_REPLY_CLEAR_BREAKPOINT num)))
148    nums))
149
150(define (get-global con name)
151  (assert (symbol? name))
152  (send-reply con (list C_DEBUG_REPLY_GET_GLOBAL name)))
153
154(define (get-bytes con addr num)
155  (send-reply con (list C_DEBUG_REPLY_GET_BYTES addr num)))
156
157(define (get-slots con val)
158  (send-reply con (list C_DEBUG_REPLY_GET_SLOTS val)))
159
160(define (get-statistics con)
161  (send-reply con (list C_DEBUG_REPLY_GET_STATS)))
162
163(define (get-trace con)
164  (send-reply con (list C_DEBUG_REPLY_GET_TRACE)))
165
166)
Note: See TracBrowser for help on using the repository browser.