109 lines
3.5 KiB
Racket
109 lines
3.5 KiB
Racket
#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))))
|