1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
#lang racket/base
(require racket/pretty)
(provide write-debug-file
load-debug-file
serialize-datum
approx-parse-state)
(define (write-debug-file file exn events)
(with-output-to-file file
(lambda ()
(write-string "`(\n")
(for ([event (in-list events)])
(let ([event (list (car event) (cdr event))])
(pretty-write (serialize-datum* event))))
(write-string ")\n")
(newline)
(write (exn-message exn))
(newline)
(pretty-write
(map serialize-context-frame
(continuation-mark-set->context
(exn-continuation-marks exn)))))
#:exists 'replace))
(define (quoted? x) (and (pair? x) (eq? (car x) 'quote)))
(define (serialize-datum d)
(list 'quasiquote (serialize-datum* d)))
(define (serialize-datum* d)
(define (UNQUOTE x) (list 'unquote x))
(cond [(number? d) d]
[(boolean? d) d]
[(symbol? d)
(case d
((unquote) (UNQUOTE '(quote unquote)))
((unquote-splicing) (UNQUOTE '(quote unquote-splicing)))
(else d))]
[(string? d) d]
[(bytes? d) d]
[(null? d) d]
[(pair? d)
(cons (serialize-datum* (car d)) (serialize-datum* (cdr d)))]
[(exn? d) (UNQUOTE `(make-exn ,(exn-message d) (current-continuation-marks)))]
[(syntax? d) (UNQUOTE `(datum->syntax #f ',(syntax->datum d)))]
[(module-path-index? d)
(define-values (path rel)
(module-path-index-split d))
(UNQUOTE `(module-path-index-join
,(serialize-datum path)
,(serialize-datum rel)))]
[(resolved-module-path? d)
(UNQUOTE `(make-resolved-module-path
,(serialize-datum
(resolved-module-path-name d))))]
[(path? d)
(UNQUOTE `(bytes->path
,(serialize-datum (path->bytes d))
,(serialize-datum (path-convention-type d))))]
[else
(eprintf "unserializable value: ~e" d)
`(UNSERIALIZABLE ,(format "~s" d))]))
(define (serialize-context-frame frame)
(cons (car frame)
(if (cdr frame)
(serialize-srcloc (cdr frame))
null)))
(define (serialize-srcloc s)
(list (let ([src (srcloc-source s)])
(cond [(path? src) (path->string src)]
[(string? src) src]
[else '?]))
(srcloc-line s)
(srcloc-column s)))
(define (load-debug-file file)
(parameterize ((read-accept-compiled #t))
(with-input-from-file file
(lambda ()
(let* ([events-expr (read)]
[exnmsg (read)]
[ctx (read)])
(let* ([events (eval events-expr)]
[events
(if (andmap (lambda (e) (and (list? e) (= 2 (length e)))) events)
(map (lambda (l) (cons (car l) (cadr l))) events)
events)])
(values events exnmsg ctx)))))))
(define (approx-parse-state events N)
(for/fold ([state null]) ([event (in-list events)] [index (in-range N)])
(define (pop expect)
(let ([top (car state)])
(unless (eq? (cadr top) expect)
(error "bad state on ~e: ~e" (car event) state))
(cdr state)))
(case (car event)
((enter-macro enter-prim enter-local)
(cons (cons index event) state))
((exit-macro)
(pop 'enter-macro))
((exit-prim)
(pop 'enter-prim))
((exit-local)
(pop 'enter-local))
(else state))))
|
