From d0712ceee237ee1469f4b4c19d4adbaf0a176bc0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 10 Oct 2012 19:11:36 -0400 Subject: [PATCH] make macro stepper recover from jumps within expansion original commit: 678fc4d6f894df87c79a4277eb41c46ace1ea9b3 --- collects/macro-debugger/model/deriv-c.rkt | 1 + .../macro-debugger/model/deriv-parser.rkt | 15 ++++-- .../macro-debugger/model/deriv-tokens.rkt | 6 ++- collects/macro-debugger/model/reductions.rkt | 13 ++++- collects/macro-debugger/model/trace.rkt | 48 +++++++++++++++++-- .../tests/macro-debugger/tests/regression.rkt | 13 +++++ 6 files changed, 84 insertions(+), 12 deletions(-) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 43dcc83..e7342ef 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -47,6 +47,7 @@ (define-struct track-origin (before after) #:transparent) (define-struct local-remark (contents) #:transparent) ;; contents : (listof (U string syntax)) +(define-struct local-mess (events) #:transparent) ;; A PrimDeriv is one of (define-struct (prule base) () #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index 045f421..7b7a36c 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -42,7 +42,7 @@ enter-list exit-list enter-check exit-check local-post exit-local exit-local/expr - local-bind enter-bind exit-bind + local-bind enter-bind exit-bind exit-local-bind local-value-result local-value-binding phase-up module-body renames-lambda @@ -173,8 +173,9 @@ (#:args e1 rs next) [(enter-macro ! macro-pre-transform (? LocalActions) macro-post-transform ! exit-macro) - (make mrule e1 (and next (wderiv-e2 next)) rs $2 - $3 $4 $5 $6 $7 next)]) + (let ([e2 (and next (wderiv-e2 next))]) + (make mrule e1 e2 rs $2 + $3 $4 (and $5 (car $5)) $6 $7 next))]) ;; Keyword resolution (Resolves @@ -202,9 +203,9 @@ (make local-lift-require (car $1) (cadr $1) (cddr $1))] [(lift-provide) (make local-lift-provide $1)] - [(local-bind ! rename-list next) + [(local-bind ! rename-list exit-local-bind) (make local-bind $1 $2 $3 #f)] - [(local-bind rename-list (? BindSyntaxes) next) + [(local-bind rename-list (? BindSyntaxes) exit-local-bind) (make local-bind $1 #f $2 $3)] [(track-origin) (make track-origin (car $1) (cdr $1))] @@ -224,6 +225,10 @@ before null after #f mafter (make p:stop mafter mafter null #f)) #f after #f))] + [(local-mess) + ;; Represents subsequence of event stream incoherent due to + ;; jump (eg, macro catches exn raised from within local-expand). + (make local-mess $1)] ;; -- Not really local actions, but can occur during evaluation ;; called 'expand' (not 'local-expand') within transformer [(start (? EE)) #f] diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 25edb6d..89a1100 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -15,6 +15,7 @@ EOF ; . enter-bind ; . exit-bind ; . + exit-local-bind ; . IMPOSSIBLE ; useful for error-handling clauses that have no ; NoError counterpart top-non-begin ; . @@ -26,7 +27,7 @@ resolve ; identifier enter-macro ; syntax macro-pre-transform ; syntax - macro-post-transform ; syntax + macro-post-transform ; (cons syntax syntax) exit-macro ; syntax enter-prim ; syntax exit-prim ; syntax @@ -73,6 +74,7 @@ local-value ; identifier local-value-result ; boolean local-value-binding ; result of identifier-binding; added by trace.rkt, not expander + local-mess ; (listof event) )) (define-tokens renames-tokens @@ -113,6 +115,7 @@ (#f local-remark ,token-local-remark) (#f local-artificial-step ,token-local-artificial-step) (#f local-value-binding ,token-local-value-binding) + (#f local-mess ,token-local-mess) ;; Standard signals (0 visit ,token-visit) @@ -198,6 +201,7 @@ (157 prepare-env) (158 prim-submodule) (159 prim-submodule*) + (160 exit-local-bind) )) (define (signal->symbol sig) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 6757bdf..fdc88b0 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -1,6 +1,7 @@ #lang racket/base (require (for-syntax racket/base) racket/match + racket/format syntax/stx "../util/eomap.rkt" "deriv-util.rkt" @@ -505,7 +506,17 @@ ]] [(struct local-remark (contents)) (R [#:reductions (list (walk/talk 'remark contents))])] - + [(struct local-mess (events)) + ;; FIXME: While it is not generally possible to parse tokens as one or more + ;; interrupted derivations (possibly interleaved with successful derivs), + ;; it should be possible to recover *some* information and display it. + (R [#:reductions + (let ([texts + (list (~a "Some expansion history has been lost due to a jump " + "within expansion.") + (~a "For example, a macro may have caught an " + "exception coming from within a call to `local-expand'."))]) + (list (walk/talk 'remark texts)))])] [#f (R)])) diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt index a2e98a8..1d1a515 100644 --- a/collects/macro-debugger/model/trace.rkt +++ b/collects/macro-debugger/model/trace.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/promise + racket/list syntax/modcode syntax/modresolve parser-tools/lex @@ -76,20 +77,58 @@ ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) (define (expand/events sexpr expander) (define events null) + ;; Problem: jumps within expansion (eg, macro catches error thrown from within + ;; call to 'local-expand') can result in ill-formed event stream. + ;; In general, not possible to detect jump endpoints, but we can at least isolate + ;; the bad parts by watching for mismatched bracketing events + ;; (eg, macro-{pre,post}-transform). + (define counter 0) ;; = (length events) + (define macro-stack null) ;; (listof (cons (U stx 'local-bind) nat)) (define (add! x y) + (set! counter (add1 counter)) (set! events (cons (cons (signal->symbol x) y) events))) (define add!/check (let ([limit (trace-macro-limit)] [handler (trace-limit-handler)] - [counter 0] + [limit-counter 0] [last-local-value-id #f]) (lambda (x y) (add! x y) (case x ((8) ;; enter-macro - (set! counter (add1 counter)) - (when (>= counter limit) - (set! limit (handler counter)))) + (set! limit-counter (add1 limit-counter)) + (when (>= limit-counter limit) + (set! limit (handler limit-counter)))) + ((21) ;; macro-pre-transform + (let ([rec (cons y counter)]) + (set! macro-stack (cons rec macro-stack)))) + ((22) ;; macro-post-transform + (cond [(and (pair? macro-stack) + (eq? (car (car macro-stack)) (cdr y))) + (set! macro-stack (cdr macro-stack))] + [else ;; Jumped! + (let loop ([ms macro-stack]) + (let ([top (car ms)]) + (cond [(eq? (car top) (cdr y)) + (let* ([reset-to (cdr top)] + [len (- counter reset-to 1)] + [pfx (take (cdr events) len)] + [sfx (drop (cdr events) len)]) + (set! macro-stack (cdr ms)) + (set! events sfx) + (set! counter (cdr top)) + (add! 'local-mess (reverse pfx)) + (add! 'macro-post-transform y))] + [else (loop (cdr ms))])))])) + ((143) ;; local-bind + (let ([rec (cons 'local-bind counter)]) + (set! macro-stack (cons rec macro-stack)))) + ((160) ;; exit-local-bind + (let ([top (car macro-stack)]) + (cond [(eq? (car top) 'local-bind) + (set! macro-stack (cdr macro-stack))] + [else ;; Jumped! + (error 'trace "internal error: cannot handle catch within bind")]))) ((153) ;; local-value (set! last-local-value-id y)) ((154) ;; local-value-result @@ -107,7 +146,6 @@ (values result (reverse events))))) - (require syntax/stx syntax/kerncase) diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt index 3b1a1ac..78748de 100644 --- a/collects/tests/macro-debugger/tests/regression.rkt +++ b/collects/tests/macro-debugger/tests/regression.rkt @@ -223,4 +223,17 @@ (define-values (y) 2))))]) (check-pred deriv? d) (check-pred ok-node? d))) + + ;; Added 10/11/2012 based on bug from mflatt,shriram + (test-case "recover from jump" + (let ([d (trace '(module m racket/base + (require (for-syntax racket/base)) + (define-syntax (convert-error stx) + (syntax-case stx () + [(convert-error expr) + (with-handlers ([exn? (lambda (e) #'(quote error))]) + (local-expand #'expr 'expression null))])) + (convert-error (lambda))))]) + (check-pred deriv? d) + (check-pred ok-node? d))) ))