commit d0712ceee237ee1469f4b4c19d4adbaf0a176bc0
parent b3dd6bfbaef6aba8f105408733d3d43e62f7da27
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 10 Oct 2012 19:11:36 -0400
make macro stepper recover from jumps within expansion
original commit: 678fc4d6f894df87c79a4277eb41c46ace1ea9b3
Diffstat:
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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)))
))
