From b8bf5c571ac8d51014f4b03c8dfcd30d621add77 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 --- 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 +++++++------ src/racket/src/schexpobs.h | 4 +- src/racket/src/syntax.c | 2 + 11 files changed, 149 insertions(+), 66 deletions(-) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 2ab5dc603c..c155e64dfb 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 c24e0d2e76..a14043570e 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 d33e3c2412..3c5cb9d006 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 ba5503f065..34f23c0fa3 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 ec20b784ed..f742952cf6 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 5d4e1c13db..dad2542688 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 d4f6531193..ca882ecbac 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 a474e29ffa..f5a95a6917 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 57c972114a..1ddb4e11a6 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)) diff --git a/src/racket/src/schexpobs.h b/src/racket/src/schexpobs.h index 0f98d65e09..ba13079075 100644 --- a/src/racket/src/schexpobs.h +++ b/src/racket/src/schexpobs.h @@ -111,6 +111,8 @@ extern Scheme_Object *scheme_get_expand_observe(); #define SCHEME_EXPAND_OBSERVE_PRIM_VARREF(obs) \ _SCHEME_EXPOBS(obs,149,scheme_false) +#define SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(observer) \ + _SCHEME_EXPOBS(observer,155,scheme_false) #define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ _SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2)) @@ -174,6 +176,6 @@ extern Scheme_Object *scheme_get_expand_observe(); #define SCHEME_EXPAND_OBSERVE_RENAME_ONE(obs,val) \ _SCHEME_EXPOBS(obs,148,val) -/* next: 152 */ +/* next: 156 (skipped some) */ #endif diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index f7a8456bb5..6fcd1f169e 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -5473,6 +5473,8 @@ stratified_body_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_ { Scheme_Object *body; + SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(erec[drec].observer); + check_form(form, form); body = SCHEME_STX_CDR(form);