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

macro-stepper: add support for #%stratified-body

Browse Source 
original commit: b8bf5c571ac8d51014f4b03c8dfcd30d621add77
This commit is contained in:
Ryan Culpepper 2010-07-12 15:06:08 -06:00
parent feeb478dde
commit 0c1ea4fc7b
9 changed files with 144 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -94,6 +94,9 @@
;; (make-p:require <Base> (listof LocalAction))
(define-struct (p:require prule) (locals) #:transparent)
;; (make-p:#%stratified-body <Base> BDeriv)
(define-struct (p:#%stratified-body prule) (bderiv) #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)

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

@ -260,7 +260,8 @@
[((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
[((? PrimRequire)) ($1 e1 e2 rs)]
[((? PrimProvide)) ($1 e1 e2 rs)]
[((? PrimVarRef)) ($1 e1 e2 rs)])
[((? PrimVarRef)) ($1 e1 e2 rs)]
[((? PrimStratifiedBody)) ($1 e1 e2 rs)])
(PrimModule
(#:args e1 e2 rs)
@ -472,6 +473,10 @@
(#:args e1 e2 rs)
[(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
(PrimStratifiedBody
(#:args e1 e2 rs)
[(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
(PrimSet
(#:args e1 e2 rs)
;; Unrolled to avoid shift/reduce

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

@ -83,6 +83,7 @@
prim-set!
prim-expression
prim-varref
prim-#%stratified-body
))
;; ** Signals to tokens
@ -174,6 +175,7 @@
(149 prim-varref)
(150 lift-require ,token-lift-require)
(151 lift-provide ,token-lift-provide)
(155 prim-#%stratified-body)
))
(define (signal->symbol sig)

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

@ -229,6 +229,15 @@
[#:pattern ?form]
[LocalActions ?form locals])]
[(Wrap p:#%stratified-body (e1 e2 rs ?1 bderiv))
(R [! ?1]
[#:pass1]
[#:pattern (?sb . ?body)]
[Block ?body bderiv]
[#:pass2]
[#:pattern ?form]
[#:walk e2 'macro])]
[(Wrap p:stop (e1 e2 rs ?1))
(R [! ?1])]

18
collects/tests/macro-debugger/all-tests.rkt
View File

@ -1,7 +1,6 @@
#lang scheme/base
(require rackunit
rackunit/gui)
(require macro-debugger/model/debug
macro-debugger/model/debug
"gentest-framework.ss"
"gentests.ss"
"test-setup.ss"
@ -12,11 +11,16 @@
"tests/hiding.ss"
"tests/regression.ss"
"tests/policy.ss"
"tests/collects.ss")
(provide go)
;;"tests/collects.ss"
)
(provide all-tests)
#|
(require rackunit/gui)
(define (go) (test/gui all-tests))
(define (collects) (test/gui big-libs-tests))
(provide go)
|#
(define protos
(list proto:kernel-forms
@ -30,6 +34,11 @@
(define hiding-deriv-test (mk-hidden-deriv-test protos))
(define hiding-steps-test (mk-hidden-steps-test protos))
(provide deriv-test
steps-test
hiding-deriv-test
hiding-steps-test)
(define all-tests
(test-suite "All tests"
deriv-test
@ -38,5 +47,4 @@
hiding-steps-test
specialized-hiding-tests
regression-tests
#;seek-tests
policy-tests))

57
collects/tests/macro-debugger/gentests.rkt
View File

@ -41,23 +41,25 @@
(define (checker-for-deriv label form attrs)
(cond [(assq '#:ok-deriv? attrs)
=> (lambda (key+expect-ok?)
(test-case label
(let ([d (trace/ns form (assq '#:kernel attrs))])
(check-pred deriv? d)
(if (cdr key+expect-ok?)
(check-pred ok-node? d)
(check-pred interrupted-node? d)))))]
(delay-test
(test-case label
(let ([d (trace/ns form (assq '#:kernel attrs))])
(check-pred deriv? d)
(if (cdr key+expect-ok?)
(check-pred ok-node? d)
(check-pred interrupted-node? d))))))]
[else #f]))
(define (checker-for-hidden-deriv label form attrs)
(cond [(assq '#:ok-deriv? attrs)
=> (lambda (key+expect-ok?)
(test-case label
(let ([d (trace/ns form (assq '#:kernel attrs))]
[expect-ok? (cdr key+expect-ok?)])
(check-hide d hide-none-policy expect-ok?)
(check-hide d hide-all-policy expect-ok?)
(check-hide d T-policy expect-ok?))))]
(delay-test
(test-case label
(let ([d (trace/ns form (assq '#:kernel attrs))]
[expect-ok? (cdr key+expect-ok?)])
(check-hide d hide-none-policy expect-ok?)
(check-hide d hide-all-policy expect-ok?)
(check-hide d T-policy expect-ok?)))))]
[else #f]))
(define (check-hide d policy expect-ok?)
@ -74,28 +76,31 @@
(define (checker-for-steps label form attrs)
(cond [(assq '#:steps attrs)
=> (lambda (key+expected)
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (reductions d)])
(check-steps (cdr key+expected) rs))))]
(delay-test
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (reductions d)])
(check-steps (cdr key+expected) rs)))))]
[else #f]))
(define (checker-for-hidden-steps label form attrs)
(cond [(assq '#:same-hidden-steps attrs)
(unless (assq '#:steps attrs)
(error 'checker-for-hidden-steps "no steps given for ~s" label))
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:steps attrs)) rs)))]
(delay-test
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:steps attrs)) rs))))]
[(assq '#:hidden-steps attrs)
=> (lambda (key+expected)
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
(delay-test
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:hidden-steps attrs)) rs)))))]
[else #f]))
(define (check-steps expected actual)

3
collects/tests/macro-debugger/tests/collects.rkt
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require rackunit
rackunit/gui)
(require rackunit)
(require macro-debugger/model/debug
scheme/path
scheme/gui)

55
collects/tests/macro-debugger/tests/syntax-basic.rkt
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require "../gentest-framework.ss")
(provide proto:kernel-forms
@ -88,7 +87,7 @@
#:no-steps)]
[#:suite
"Binding forms and blocks"
"Binding forms"
(testK "lambda (simple)"
(lambda (x) x)
[#:steps (rename-lambda (lambda (x) x))]
@ -123,7 +122,50 @@
#:same-hidden-steps)]
[#:suite
"Internal definitions"
"Internal definitions within #%stratified-body"
(testK "internal begin (empty)"
(#%stratified-body (begin) 'a)
[#:steps (splice-block (#%stratified-body 'a))
(macro 'a)]
[#:hidden-steps (splice-block (#%stratified-body 'a))])
(testK "internal begin (solo)"
(#%stratified-body (begin 'b))
[#:steps (splice-block (#%stratified-body 'b))
(macro 'b)]
[#:hidden-steps (splice-block (#%stratified-body 'b))])
(testK "internal begin"
(#%stratified-body (begin 'a) 'b)
[#:steps (splice-block (#%stratified-body 'a 'b))
(macro (begin 'a 'b))]
[#:hidden-steps (splice-block (#%stratified-body 'a 'b))])
(testK "internal define-values"
(#%stratified-body (define-values (x) 'a) 'b)
[#:steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(macro (letrec-values ([(x) 'a]) 'b))]
[#:hidden-steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
(testK "internal define-values in begin"
(#%stratified-body (begin (define-values (x) 'a)) 'b)
[#:steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(macro (letrec-values ([(x) 'a]) 'b))]
[#:hidden-steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
(testK "internal begin, then define-values"
(#%stratified-body (begin) (define-values (x) 'a) 'b)
[#:steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(macro (letrec-values ([(x) 'a]) 'b))])]
[#:suite
"Internal definitions (mixed defs and exprs)"
(testK "internal begin (empty)"
(lambda () (begin) 'a)
[#:steps (rename-lambda (lambda () (begin) 'a))
@ -165,6 +207,13 @@
(splice-block (lambda () (define-values (x) 'a) 'b))
(block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
#:same-hidden-steps)
(testK "define-values after expr"
(lambda () 'a (define-values (x) 'b) 'c)
[#:steps
(rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
(block->letrec (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))
(rename-letrec-values (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))]
#:same-hidden-steps)]
[#:suite

43
collects/tests/macro-debugger/tests/syntax-errors.rkt
View File

@ -206,28 +206,27 @@
(define-values (x) 1)
(define-values (x) 2)
3)
[#:rename+error-step rename-lambda])
(testKE (lambda (x)
(define-values (x) 'a)
'b
(define-values (y) 'c)
'd)
[#:steps (rename-lambda (lambda (x)
(define-values (x) 'a)
'b
(define-values (y) 'c)
'd))
(block->letrec (lambda (x)
(letrec-values ([(x) 'a])
'b
(define-values (y) 'c)
'd)))
(rename-letrec-values (lambda (x)
(letrec-values ([(x) 'a])
'b
(define-values (y) 'c)
'd)))
error])]
[#:rename+error-step rename-lambda])]
[#:suite
"#%stratified-body"
(testKE (#%stratified-body
(define-values (x) 'a)
'b
(define-values (y) 'c)
'd)
[#:steps (block->letrec (#%stratified-body
(letrec-values ([(x) 'a])
'b
(define-values (y) 'c)
'd)))
(rename-letrec-values (#%stratified-body
(letrec-values ([(x) 'a])
'b
(define-values (y) 'c)
'd)))
error])
(testKE (#%stratified-body (define-values (x) 'a))
[#:steps error])]
[#:suite
"bad internal begin"
(testKE (lambda () (begin . 1))