suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make macro stepper recover from jumps within expansion

Browse Source 
original commit: 678fc4d6f894df87c79a4277eb41c46ace1ea9b3
This commit is contained in:
Ryan Culpepper 2012-10-10 19:11:36 -04:00
parent b3dd6bfbae
commit d0712ceee2
6 changed files with 84 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/macro-debugger/model/deriv-c.rkt
View File

@ -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)

15
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -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]

6
collects/macro-debugger/model/deriv-tokens.rkt
View File

@ -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)

13
collects/macro-debugger/model/reductions.rkt
View File

@ -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)]))

48
collects/macro-debugger/model/trace.rkt
View File

@ -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)

13
collects/tests/macro-debugger/tests/regression.rkt
View File

@ -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)))
))