« back to all changes in this revision
Viewing changes to ice-9/gds-client.scm
- browse files at revision 8
- compare with another revision
- download diff
- download tarball
- view history from revision 8
- Committer: Bazaar Package Importer
- Author(s): Rob Browning
- Date: 2008-05-10 12:18:50 UTC
- mfrom: (1.2.4 upstream)
- Revision ID: james.westby@ubuntu.com-20080510121850-mwi7tobbfkat03vr
Tags: 1.8.5+1-1
* Incorporate new upstream stable release.
* Fix gcc 4.3 compilation problems (fixed upstream now). Thanks to
Alexander Schmehl <tolimar@debian.org> for the previous, related
1.8.4+1-2.1 NMU, and to Maximiliano Curia and Daniel Schepler for the
original patch. (closes: #462384, #466778)
* Fix gcc 4.3 compilation problems (fixed upstream now). Thanks to
Alexander Schmehl <tolimar@debian.org> for the previous, related
1.8.4+1-2.1 NMU, and to Maximiliano Curia and Daniel Schepler for the
original patch. (closes: #462384, #466778)
added
removed
ice-9/gds-client.scm
1
(define-module (ice-9 gds-client)
2
#:use-module (oop goops)
3
#:use-module (oop goops describe)
4
#:use-module (ice-9 debugging trace)
5
#:use-module (ice-9 debugging traps)
6
#:use-module (ice-9 debugging trc)
7
#:use-module (ice-9 debugging steps)
8
#:use-module (ice-9 pretty-print)
9
#:use-module (ice-9 regex)
10
#:use-module (ice-9 session)
11
#:use-module (ice-9 string-fun)
12
#:export (gds-debug-trap
13
run-utility
14
gds-accept-input))
15
16
(cond ((string>=? (version) "1.7")
17
(use-modules (ice-9 debugger utils)))
18
(else
19
(define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
20
(module-export! the-ice-9-debugger-module
21
'(source-position
22
write-frame-short/application
23
write-frame-short/expression
24
write-frame-args-long
25
write-frame-long))))
26
27
(use-modules (ice-9 debugger))
28
29
(define gds-port #f)
30
31
;; Return an integer that somehow identifies the current thread.
32
(define (get-thread-id)
33
(let ((root (dynamic-root)))
34
(cond ((integer? root)
35
root)
36
((pair? root)
37
(object-address root))
38
(else
39
(error "Unexpected dynamic root:" root)))))
40
41
;; gds-debug-read is a high-priority read. The (debug-thread-id ID)
42
;; form causes the frontend to dismiss any reads from threads whose id
43
;; is not ID, until it receives the (thread-id ...) form with the same
44
;; id as ID. Dismissing the reads of any other threads (by sending a
45
;; form that is otherwise ignored) causes those threads to release the
46
;; read mutex, which allows the (gds-read) here to proceed.
47
(define (gds-debug-read)
48
(write-form `(debug-thread-id ,(get-thread-id)))
49
(gds-read))
50
51
(define (gds-debug-trap trap-context)
52
"Invoke the GDS debugger to explore the stack at the specified trap."
53
(connect-to-gds)
54
(start-stack 'debugger
55
(let* ((stack (tc:stack trap-context))
56
(flags1 (let ((trap-type (tc:type trap-context)))
57
(case trap-type
58
((#:return #:error)
59
(list trap-type
60
(tc:return-value trap-context)))
61
(else
62
(list trap-type)))))
63
(flags (if (tc:continuation trap-context)
64
(cons #:continuable flags1)
65
flags1))
66
(fired-traps (tc:fired-traps trap-context))
67
(special-index (and (= (length fired-traps) 1)
68
(is-a? (car fired-traps) <exit-trap>)
69
(eq? (tc:type trap-context) #:return)
70
(- (tc:depth trap-context)
71
(slot-ref (car fired-traps) 'depth)))))
72
;; Write current stack to the frontend.
73
(write-form (list 'stack
74
(if (and special-index (> special-index 0))
75
special-index
76
0)
77
(stack->emacs-readable stack)
78
(append (flags->emacs-readable flags)
79
(slot-ref trap-context
80
'handler-return-syms))))
81
;; Now wait for instruction.
82
(let loop ((protocol (gds-debug-read)))
83
;; Act on it.
84
(case (car protocol)
85
((tweak)
86
;; Request to tweak the handler return value.
87
(let ((tweaking (catch #t
88
(lambda ()
89
(list (with-input-from-string
90
(cadr protocol)
91
read)))
92
(lambda ignored #f))))
93
(if tweaking
94
(slot-set! trap-context
95
'handler-return-value
96
(cons 'instead (car tweaking)))))
97
(loop (gds-debug-read)))
98
((continue)
99
;; Continue (by exiting the debugger).
100
*unspecified*)
101
((evaluate)
102
;; Evaluate expression in specified frame.
103
(eval-in-frame stack (cadr protocol) (caddr protocol))
104
(loop (gds-debug-read)))
105
((info-frame)
106
;; Return frame info.
107
(let ((frame (stack-ref stack (cadr protocol))))
108
(write-form (list 'info-result
109
(with-output-to-string
110
(lambda ()
111
(write-frame-long frame))))))
112
(loop (gds-debug-read)))
113
((info-args)
114
;; Return frame args.
115
(let ((frame (stack-ref stack (cadr protocol))))
116
(write-form (list 'info-result
117
(with-output-to-string
118
(lambda ()
119
(write-frame-args-long frame))))))
120
(loop (gds-debug-read)))
121
((proc-source)
122
;; Show source of application procedure.
123
(let* ((frame (stack-ref stack (cadr protocol)))
124
(proc (frame-procedure frame))
125
(source (and proc (procedure-source proc))))
126
(write-form (list 'info-result
127
(if source
128
(sans-surrounding-whitespace
129
(with-output-to-string
130
(lambda ()
131
(pretty-print source))))
132
(if proc
133
"This procedure is coded in C"
134
"This frame has no procedure")))))
135
(loop (gds-debug-read)))
136
((traps-here)
137
;; Show the traps that fired here.
138
(write-form (list 'info-result
139
(with-output-to-string
140
(lambda ()
141
(for-each describe
142
(tc:fired-traps trap-context))))))
143
(loop (gds-debug-read)))
144
((step-into)
145
;; Set temporary breakpoint on next trap.
146
(at-step gds-debug-trap
147
1
148
#f
149
(if (memq #:return flags)
150
#f
151
(- (stack-length stack)
152
(cadr protocol)))))
153
((step-over)
154
;; Set temporary breakpoint on exit from
155
;; specified frame.
156
(at-exit (- (stack-length stack) (cadr protocol))
157
gds-debug-trap))
158
((step-file)
159
;; Set temporary breakpoint on next trap in same
160
;; source file.
161
(at-step gds-debug-trap
162
1
163
(frame-file-name (stack-ref stack
164
(cadr protocol)))
165
(if (memq #:return flags)
166
#f
167
(- (stack-length stack)
168
(cadr protocol)))))
169
(else
170
(safely-handle-nondebug-protocol protocol)
171
(loop (gds-debug-read))))))))
172
173
(define (connect-to-gds . application-name)
174
(or gds-port
175
(begin
176
(set! gds-port
177
(or (let ((s (socket PF_INET SOCK_STREAM 0))
178
(SOL_TCP 6)
179
(TCP_NODELAY 1))
180
(setsockopt s SOL_TCP TCP_NODELAY 1)
181
(catch #t
182
(lambda ()
183
(connect s AF_INET (inet-aton "127.0.0.1") 8333)
184
s)
185
(lambda _ #f)))
186
(let ((s (socket PF_UNIX SOCK_STREAM 0)))
187
(catch #t
188
(lambda ()
189
(connect s AF_UNIX "/tmp/.gds_socket")
190
s)
191
(lambda _ #f)))
192
(error "Couldn't connect to GDS by TCP or Unix domain socket")))
193
(write-form (list 'name (getpid) (apply client-name application-name))))))
194
195
(define (client-name . application-name)
196
(let loop ((args (append application-name (program-arguments))))
197
(if (null? args)
198
(format #f "PID ~A" (getpid))
199
(let ((arg (car args)))
200
(cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
201
(loop (cdr args)))
202
((string-match "^-" arg)
203
(loop (cdr args)))
204
(else
205
(format #f "~A (PID ~A)" arg (getpid))))))))
206
207
(if (not (defined? 'make-mutex))
208
(begin
209
(define (make-mutex) #f)
210
(define lock-mutex noop)
211
(define unlock-mutex noop)))
212
213
(define write-mutex (make-mutex))
214
215
(define (write-form form)
216
;; Write any form FORM to GDS.
217
(lock-mutex write-mutex)
218
(write form gds-port)
219
(newline gds-port)
220
(force-output gds-port)
221
(unlock-mutex write-mutex))
222
223
(define (stack->emacs-readable stack)
224
;; Return Emacs-readable representation of STACK.
225
(map (lambda (index)
226
(frame->emacs-readable (stack-ref stack index)))
227
(iota (min (stack-length stack)
228
(cadr (memq 'depth (debug-options)))))))
229
230
(define (frame->emacs-readable frame)
231
;; Return Emacs-readable representation of FRAME.
232
(if (frame-procedure? frame)
233
(list 'application
234
(with-output-to-string
235
(lambda ()
236
(display (if (frame-real? frame) " " "t "))
237
(write-frame-short/application frame)))
238
(source->emacs-readable frame))
239
(list 'evaluation
240
(with-output-to-string
241
(lambda ()
242
(display (if (frame-real? frame) " " "t "))
243
(write-frame-short/expression frame)))
244
(source->emacs-readable frame))))
245
246
(define (source->emacs-readable frame)
247
;; Return Emacs-readable representation of the filename, line and
248
;; column source properties of SOURCE.
249
(or (frame->source-position frame) 'nil))
250
251
(define (flags->emacs-readable flags)
252
;; Return Emacs-readable representation of trap FLAGS.
253
(let ((prev #f))
254
(map (lambda (flag)
255
(let ((erf (if (and (keyword? flag)
256
(not (eq? prev #:return)))
257
(keyword->symbol flag)
258
(format #f "~S" flag))))
259
(set! prev flag)
260
erf))
261
flags)))
262
263
(define (eval-in-frame stack index expr)
264
(write-form
265
(list 'eval-result
266
(format #f "~S"
267
(catch #t
268
(lambda ()
269
(local-eval (with-input-from-string expr read)
270
(memoized-environment
271
(frame-source (stack-ref stack
272
index)))))
273
(lambda args
274
(cons 'ERROR args)))))))
275
276
(set! (behaviour-ordering gds-debug-trap) 100)
277
278
;;; Code below here adds support for interaction between the GDS
279
;;; client program and the Emacs frontend even when not stopped in the
280
;;; debugger.
281
282
;; A mutex to control attempts by multiple threads to read protocol
283
;; back from the frontend.
284
(define gds-read-mutex (make-mutex))
285
286
;; Read a protocol instruction from the frontend.
287
(define (gds-read)
288
;; Acquire the read mutex.
289
(lock-mutex gds-read-mutex)
290
;; Tell the front end something that identifies us as a thread.
291
(write-form `(thread-id ,(get-thread-id)))
292
;; Now read, then release the mutex and return what was read.
293
(let ((x (catch #t
294
(lambda () (read gds-port))
295
(lambda ignored the-eof-object))))
296
(unlock-mutex gds-read-mutex)
297
x))
298
299
(define (gds-accept-input exit-on-continue)
300
;; If reading from the GDS connection returns EOF, we will throw to
301
;; this catch.
302
(catch 'server-eof
303
(lambda ()
304
(let loop ((protocol (gds-read)))
305
(if (or (eof-object? protocol)
306
(and exit-on-continue
307
(eq? (car protocol) 'continue)))
308
(throw 'server-eof))
309
(safely-handle-nondebug-protocol protocol)
310
(loop (gds-read))))
311
(lambda ignored #f)))
312
313
(define (safely-handle-nondebug-protocol protocol)
314
;; This catch covers any internal errors in the GDS code or
315
;; protocol.
316
(catch #t
317
(lambda ()
318
(lazy-catch #t
319
(lambda ()
320
(handle-nondebug-protocol protocol))
321
save-lazy-trap-context-and-rethrow))
322
(lambda (key . args)
323
(write-form
324
`(eval-results (error . ,(format #f "~s" protocol))
325
,(if last-lazy-trap-context 't 'nil)
326
"GDS Internal Error
327
Please report this to <neil@ossau.uklinux.net>, ideally including:
328
- a description of the scenario in which this error occurred
329
- which versions of Guile and guile-debugging you are using
330
- the error stack, which you can get by clicking on the link below,
331
and then cut and paste into your report.
332
Thanks!\n\n"
333
,(list (with-output-to-string
334
(lambda ()
335
(write key)
336
(display ": ")
337
(write args)
338
(newline)))))))))
339
340
;; The key that is used to signal a read error changes from 1.6 to
341
;; 1.8; here we cover all eventualities by discovering the key
342
;; dynamically.
343
(define read-error-key
344
(catch #t
345
(lambda ()
346
(with-input-from-string "(+ 3 4" read))
347
(lambda (key . args)
348
key)))
349
350
(define (handle-nondebug-protocol protocol)
351
(case (car protocol)
352
353
((eval)
354
(set! last-lazy-trap-context #f)
355
(apply (lambda (correlator module port-name line column code)
356
(with-input-from-string code
357
(lambda ()
358
(set-port-filename! (current-input-port) port-name)
359
(set-port-line! (current-input-port) line)
360
(set-port-column! (current-input-port) column)
361
(let ((m (and module (resolve-module-from-root module))))
362
(catch read-error-key
363
(lambda ()
364
(let loop ((exprs '()) (x (read)))
365
(if (eof-object? x)
366
;; Expressions to be evaluated have all
367
;; been read. Now evaluate them.
368
(let loop2 ((exprs (reverse! exprs))
369
(results '())
370
(n 1))
371
(if (null? exprs)
372
(write-form `(eval-results ,correlator
373
,(if last-lazy-trap-context 't 'nil)
374
,@results))
375
(loop2 (cdr exprs)
376
(append results (gds-eval (car exprs) m
377
(if (and (null? (cdr exprs))
378
(= n 1))
379
#f n)))
380
(+ n 1))))
381
;; Another complete expression read; add
382
;; it to the list.
383
(loop (cons x exprs) (read)))))
384
(lambda (key . args)
385
(write-form `(eval-results
386
,correlator
387
,(if last-lazy-trap-context 't 'nil)
388
,(with-output-to-string
389
(lambda ()
390
(display ";;; Reading expressions")
391
(display " to evaluate\n")
392
(apply display-error #f
393
(current-output-port) args)))
394
("error-in-read")))))))))
395
(cdr protocol)))
396
397
((complete)
398
(let ((matches (apropos-internal
399
(string-append "^" (regexp-quote (cadr protocol))))))
400
(cond ((null? matches)
401
(write-form '(completion-result nil)))
402
(else
403
;;(write matches (current-error-port))
404
;;(newline (current-error-port))
405
(let ((match
406
(let loop ((match (symbol->string (car matches)))
407
(matches (cdr matches)))
408
;;(write match (current-error-port))
409
;;(newline (current-error-port))
410
;;(write matches (current-error-port))
411
;;(newline (current-error-port))
412
(if (null? matches)
413
match
414
(if (string-prefix=? match
415
(symbol->string (car matches)))
416
(loop match (cdr matches))
417
(loop (substring match 0
418
(- (string-length match) 1))
419
matches))))))
420
(if (string=? match (cadr protocol))
421
(write-form `(completion-result
422
,(map symbol->string matches)))
423
(write-form `(completion-result
424
,match))))))))
425
426
((debug-lazy-trap-context)
427
(if last-lazy-trap-context
428
(gds-debug-trap last-lazy-trap-context)
429
(error "There is no stack available to show")))
430
431
(else
432
(error "Unexpected protocol:" protocol))))
433
434
(define (resolve-module-from-root name)
435
(save-module-excursion
436
(lambda ()
437
(set-current-module the-root-module)
438
(resolve-module name))))
439
440
(define (gds-eval x m part)
441
;; Consumer to accept possibly multiple values and present them for
442
;; Emacs as a list of strings.
443
(define (value-consumer . values)
444
(if (unspecified? (car values))
445
'()
446
(map (lambda (value)
447
(with-output-to-string (lambda () (write value))))
448
values)))
449
;; Now do evaluation.
450
(let ((intro (if part
451
(format #f ";;; Evaluating expression ~A" part)
452
";;; Evaluating"))
453
(value #f))
454
(let* ((do-eval (if m
455
(lambda ()
456
(display intro)
457
(display " in module ")
458
(write (module-name m))
459
(newline)
460
(set! value
461
(call-with-values (lambda ()
462
(start-stack 'gds-eval-stack
463
(eval x m)))
464
value-consumer)))
465
(lambda ()
466
(display intro)
467
(display " in current module ")
468
(write (module-name (current-module)))
469
(newline)
470
(set! value
471
(call-with-values (lambda ()
472
(start-stack 'gds-eval-stack
473
(primitive-eval x)))
474
value-consumer)))))
475
(output
476
(with-output-to-string
477
(lambda ()
478
(catch #t
479
(lambda ()
480
(lazy-catch #t
481
do-eval
482
save-lazy-trap-context-and-rethrow))
483
(lambda (key . args)
484
(case key
485
((misc-error signal unbound-variable numerical-overflow)
486
(apply display-error #f
487
(current-output-port) args)
488
(set! value '("error-in-evaluation")))
489
(else
490
(display "EXCEPTION: ")
491
(display key)
492
(display " ")
493
(write args)
494
(newline)
495
(set! value
496
'("unhandled-exception-in-evaluation"))))))))))
497
(list output value))))
498
499
(define last-lazy-trap-context #f)
500
501
(define (save-lazy-trap-context-and-rethrow key . args)
502
(set! last-lazy-trap-context
503
(throw->trap-context key args save-lazy-trap-context-and-rethrow))
504
(apply throw key args))
505
506
(define (run-utility)
507
(connect-to-gds)
508
(write (getpid))
509
(newline)
510
(force-output)
511
(named-module-use! '(guile-user) '(ice-9 session))
512
(gds-accept-input #f))
513
514
(define-method (trap-description (trap <trap>))
515
(let loop ((description (list (class-name (class-of trap))))
516
(next 'installed?))
517
(case next
518
((installed?)
519
(loop (if (slot-ref trap 'installed)
520
(cons 'installed description)
521
description)
522
'conditional?))
523
((conditional?)
524
(loop (if (slot-ref trap 'condition)
525
(cons 'conditional description)
526
description)
527
'skip-count))
528
((skip-count)
529
(loop (let ((skip-count (slot-ref trap 'skip-count)))
530
(if (zero? skip-count)
531
description
532
(cons* skip-count 'skip-count description)))
533
'single-shot?))
534
((single-shot?)
535
(loop (if (slot-ref trap 'single-shot)
536
(cons 'single-shot description)
537
description)
538
'done))
539
(else
540
(reverse! description)))))
541
542
(define-method (trap-description (trap <procedure-trap>))
543
(let ((description (next-method)))
544
(set-cdr! description
545
(cons (procedure-name (slot-ref trap 'procedure))
546
(cdr description)))
547
description))
548
549
(define-method (trap-description (trap <source-trap>))
550
(let ((description (next-method)))
551
(set-cdr! description
552
(cons (format #f "~s" (slot-ref trap 'expression))
553
(cdr description)))
554
description))
555
556
(define-method (trap-description (trap <location-trap>))
557
(let ((description (next-method)))
558
(set-cdr! description
559
(cons* (slot-ref trap 'file-regexp)
560
(slot-ref trap 'line)
561
(slot-ref trap 'column)
562
(cdr description)))
563
description))
564
565
(define (gds-trace-trap trap-context)
566
(connect-to-gds)
567
(gds-do-trace trap-context)
568
(at-exit (tc:depth trap-context) gds-do-trace))
569
570
(define (gds-do-trace trap-context)
571
(write-form (list 'trace
572
(format #f
573
"~3@a: ~a"
574
(trace/stack-real-depth trap-context)
575
(trace/info trap-context)))))
576
577
(define (gds-trace-subtree trap-context)
578
(connect-to-gds)
579
(gds-do-trace trap-context)
580
(let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
581
(install-trap step-trap)
582
(at-exit (tc:depth trap-context)
583
(lambda (trap-context)
584
(uninstall-trap step-trap)))))
585
586
;;; (ice-9 gds-client) ends here.
Loggerhead is a web-based interface for Breezy
Version: 2.0.1