From 0c1ea4fc7b9d17d0d814dd4eb197c74e75cdb88d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 12 Jul 2010 15:06:08 -0600 Subject: [PATCH] macro-stepper: add support for #%stratified-body original commit: b8bf5c571ac8d51014f4b03c8dfcd30d621add77 --- collects/macro-debugger/model/deriv-c.rkt | 3 + .../macro-debugger/model/deriv-parser.rkt | 7 +- .../macro-debugger/model/deriv-tokens.rkt | 2 + collects/macro-debugger/model/reductions.rkt | 9 +++ collects/tests/macro-debugger/all-tests.rkt | 18 +++-- collects/tests/macro-debugger/gentests.rkt | 57 ++++++++-------- .../tests/macro-debugger/tests/collects.rkt | 3 +- .../macro-debugger/tests/syntax-basic.rkt | 65 ++++++++++++++++--- .../macro-debugger/tests/syntax-errors.rkt | 45 +++++++------ 9 files changed, 144 insertions(+), 65 deletions(-) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 2ab5dc6..c155e64 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -94,6 +94,9 @@ ;; (make-p:require (listof LocalAction)) (define-struct (p:require prule) (locals) #:transparent) +;; (make-p:#%stratified-body BDeriv) +(define-struct (p:#%stratified-body prule) (bderiv) #:transparent) + ;; (make-p:stop ) ;; (make-p:unknown ) ;; (make-p:#%top Stx) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index c24e0d2..a140435 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -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 diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index d33e3c2..3c5cb9d 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -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) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index ba5503f..34f23c0 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -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])] diff --git a/collects/tests/macro-debugger/all-tests.rkt b/collects/tests/macro-debugger/all-tests.rkt index ec20b78..f742952 100644 --- a/collects/tests/macro-debugger/all-tests.rkt +++ b/collects/tests/macro-debugger/all-tests.rkt @@ -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)) diff --git a/collects/tests/macro-debugger/gentests.rkt b/collects/tests/macro-debugger/gentests.rkt index 5d4e1c1..dad2542 100644 --- a/collects/tests/macro-debugger/gentests.rkt +++ b/collects/tests/macro-debugger/gentests.rkt @@ -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) diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt index d4f6531..ca882ec 100644 --- a/collects/tests/macro-debugger/tests/collects.rkt +++ b/collects/tests/macro-debugger/tests/collects.rkt @@ -1,6 +1,5 @@ #lang scheme/base -(require rackunit - rackunit/gui) +(require rackunit) (require macro-debugger/model/debug scheme/path scheme/gui) diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/collects/tests/macro-debugger/tests/syntax-basic.rkt index a474e29..f5a95a6 100644 --- a/collects/tests/macro-debugger/tests/syntax-basic.rkt +++ b/collects/tests/macro-debugger/tests/syntax-basic.rkt @@ -1,4 +1,3 @@ - #lang scheme/base (require "../gentest-framework.ss") (provide proto:kernel-forms @@ -43,7 +42,7 @@ (testK "require for-template" (#%require (for-template mzscheme)) #:no-steps)] - + [#:suite "Definitions" (testK "define-values" @@ -52,7 +51,7 @@ (testK "define-syntaxes" (define-syntaxes (x) 'a) #:no-steps)] - + [#:suite "Simple expressions" (testK "if" @@ -64,7 +63,7 @@ (testK "set!" (set! x 'a) #:no-steps)] - + [#:suite "Sequence-containing expressions" (testK "begin" @@ -86,9 +85,9 @@ (testK "#%app (explicit)" (#%app + '1 '2 '3) #: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,8 +207,15 @@ (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 "Top-level begin" (testK "begin (top-level)" diff --git a/collects/tests/macro-debugger/tests/syntax-errors.rkt b/collects/tests/macro-debugger/tests/syntax-errors.rkt index 57c9721..1ddb4e1 100644 --- a/collects/tests/macro-debugger/tests/syntax-errors.rkt +++ b/collects/tests/macro-debugger/tests/syntax-errors.rkt @@ -183,7 +183,7 @@ #:error-step) (testKE (letrec-values ([(x) 1] [(x) 2]) 3) #:error-step)] - + [#:suite "Internal definitions" [#:suite @@ -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))