commit 3385d5bc0dff49197e7b553425251b6ffbe07d02
parent 7baa54e6b1c65e4881430bf95c9ff975748e7948
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 15 Mar 2012 06:49:06 -0600
macro-debugger: internal debugging improvements
original commit: 71772ba6c0399ed006f609dba0d2f60672d4b1dd
Diffstat:
2 files changed, 57 insertions(+), 25 deletions(-)
diff --git a/collects/macro-debugger/stepper-text.rkt b/collects/macro-debugger/stepper-text.rkt
@@ -1,30 +1,29 @@
#lang racket/base
(require racket/pretty
+ racket/promise
"model/trace.rkt"
"model/reductions.rkt"
"model/reductions-config.rkt"
"model/steps.rkt"
"syntax-browser/partition.rkt"
- "syntax-browser/pretty-helper.rkt")
+ "syntax-browser/pretty-helper.rkt"
+ "view/debug-format.rkt")
(provide expand/step-text
stepper-text)
-(define expand/step-text
- (case-lambda
- [(stx) (expand/step-text stx #f)]
- [(stx show)
- (define s (stepper-text stx (->show-function show)))
- (s 'all)]))
+(define (expand/step-text stx [show #f]
+ #:internal-error-file [error-file #f])
+ (let ([s (stepper-text stx (->show-function show) #:internal-error-file error-file)])
+ (s 'all)))
-(define stepper-text
- (case-lambda
- [(stx) (internal-stepper stx #f)]
- [(stx show) (internal-stepper stx (->show-function show))]))
+(define (stepper-text stx [show #f]
+ #:internal-error-file [error-file #f])
+ (internal-stepper stx (->show-function show) error-file))
;; internal procedures
-(define (internal-stepper stx show?)
- (define steps (get-steps stx show?))
+(define (internal-stepper stx show? error-file)
+ (define steps (get-steps stx show? error-file))
(define used-steps null)
(define partition (new-bound-partition))
(define dispatch
@@ -50,14 +49,20 @@
(dispatch 'all))))]))
dispatch)
-(define (get-steps stx show?)
- (define deriv (trace stx))
- (define steps
- (parameterize ((macro-policy show?))
- (reductions deriv)))
- (define (ok? x)
- (or (rewrite-step? x) (misstep? x)))
- (filter ok? steps))
+(define (get-steps stx show? error-file)
+ (let-values ([(_result events derivp) (trace* stx)])
+ (with-handlers ([exn:fail?
+ (lambda (exn)
+ (when error-file
+ (write-debug-file error-file exn events))
+ (raise exn))])
+ (define deriv (force derivp))
+ (define steps
+ (parameterize ((macro-policy show?))
+ (reductions deriv)))
+ (define (ok? x)
+ (or (rewrite-step? x) (misstep? x)))
+ (filter ok? steps))))
(define (show-step step partition)
(cond [(step? step)
diff --git a/collects/macro-debugger/view/debug-format.rkt b/collects/macro-debugger/view/debug-format.rkt
@@ -2,16 +2,21 @@
(require racket/pretty)
(provide write-debug-file
load-debug-file
- serialize-datum)
+ serialize-datum
+ approx-parse-state)
(define (write-debug-file file exn events)
(with-output-to-file file
(lambda ()
- (pretty-write (serialize-datum events))
+ (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-print
+ (pretty-write
(map serialize-context-frame
(continuation-mark-set->context
(exn-continuation-marks exn)))))
@@ -77,5 +82,27 @@
(let* ([events-expr (read)]
[exnmsg (read)]
[ctx (read)])
- (let ([events (eval events-expr)])
+ (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))))
