commit b2397e30923ca6147853799f38dca1856d38eef8
parent d19c2208c9b99c64f4b65e82c9ff4bd7af4c8633
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 18 Jul 2011 06:06:49 -0600
macro-stepper: update tests
original commit: 5cf2767e7ab4c094468d175f39f07f75e6be3321
Diffstat:
5 files changed, 50 insertions(+), 21 deletions(-)
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
@@ -135,7 +135,7 @@
[#:with-visible-form
[#:left-foot]
[#:set-syntax (stx-car (stx-cdr #'?form))]
- [#:step 'macro]]
+ [#:step 'macro]] ;; FIXME: 'untag-expr
[#:pass2]
[#:set-syntax (stx-car (stx-cdr oldform))]
[#:rename ?form untag])]
@@ -199,7 +199,8 @@
srenames
'rename-lsv]
[#:binders #'(?svars ... ?vvars ...)]
- [BindSyntaxes (?srhs ...) srhss]
+ [#:when (pair? srhss) ;; otherwise, we're coming from a block expansion
+ [BindSyntaxes (?srhs ...) srhss]]
;; If vrenames is #f, no var bindings to rename
[#:when vrenames
[#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]
diff --git a/collects/tests/macro-debugger/tests/hiding.rkt b/collects/tests/macro-debugger/tests/hiding.rkt
@@ -55,27 +55,29 @@
(test-trivial-hiding/id (let-values ([(x) *]) *))
(test-trivial-hiding/id (letrec-values ([(x) *]) *)))
(test-suite "Blocks"
+ ;; Internal definitions no longer expand into straightforward letrec exprs;
+ ;; now they can also produce multiple nested lets/letrec forms
(test-trivial-hiding/id (lambda (x y) x y))
(test-trivial-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
(test-trivial-hiding (lambda (x y z) x (begin y z))
(lambda (x y z) x y z))
(test-trivial-hiding (lambda (x) (define-values (y) x) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
+ (lambda (x) (let-values ([(y) x]) y)))
(test-trivial-hiding (lambda (x) (begin (define-values (y) x)) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
+ (lambda (x) (let-values ([(y) x]) y)))
(test-trivial-hiding (lambda (x) (begin (define-values (y) x) y) x)
- (lambda (x) (letrec-values ([(y) x]) y x)))
+ (lambda (x) (let-values ([(y) x]) y x)))
(test-trivial-hiding (lambda (x) (id (define-values (y) x)) x)
- (lambda (x) (letrec-values ([(y) x]) x)))
+ (lambda (x) (let-values ([(y) x]) x)))
(test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x)))
- (lambda (x) (letrec-values ([(y) x]) x)))
+ (lambda (x) (let-values ([(y) x]) x)))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
+ (lambda (x) (let-values ([(y) x]) y)))
(test-trivial-hiding (lambda (x y) x (id y))
(lambda (x y) x y))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
- (lambda (x) (letrec-values ([(y) x]) y))))
+ (lambda (x) (let-values ([(y) x]) y))))
#|
;; Old hiding mechanism never did letrec transformation (unless forced)
(test-suite "Block normalization"
@@ -123,17 +125,18 @@
(test-T-hiding (id (Tid x))
(id x)))
(test-suite "Blocks"
+ ;; See note about about internal definition expansion
(test-T-hiding/id (lambda (x y) x y))
(test-T-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
(test-T-hiding (lambda (x y z) x (begin y z))
(lambda (x y z) x y z))
(test-T-hiding (lambda (x) (define-values (y) x) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
+ (lambda (x) (let-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x)) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
+ (lambda (x) (let-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x) y) x)
- (lambda (x) (letrec-values ([(y) x]) y x)))
+ (lambda (x) (let-values ([(y) x]) y x)))
(test-T-hiding (lambda (x) (id x))
(lambda (x) (id x)))
(test-T-hiding (lambda (x) (Tid x))
diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt
@@ -115,21 +115,25 @@
;; Fixed 5/17/2007
(test-case "hiding: keeping lifts in sync"
(let ([freshname (gensym)])
- (eval `(module ,freshname mzscheme
- (require (lib "contract.rkt"))
- (provide/contract [f (integer? . -> . integer?)]
- [c integer?])
+ (eval `(module ,freshname racket/base
+ (require racket/contract)
+ (provide/contract
+ [f (-> integer? integer?)]
+ [c integer?])
(define (f x) (add1 x))
(define c 1)))
(let ([rs (parameterize ((macro-policy standard-policy))
(reductions
(trace `(module m mzscheme
- (require ',freshname)
+ (require (quote ,freshname))
(define (g y) c)
(define h c)
(add1 (g 2))))))])
+ (printf "not a step:\n~s\n"
+ (for/or ([s rs]) (and (not (step? s)) s)))
(check-pred list? rs)
- (check-true (andmap step? rs)))))
+ (for ([x (in-list rs)])
+ (check-true (not (misstep? x)))))))
;; Bug from samth (6/5/2007)
;; problem seems to come from define-syntax -> letrec-syntaxes+values
diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/collects/tests/macro-debugger/tests/syntax-basic.rkt
@@ -216,9 +216,17 @@
(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)]
+ (block->letrec (lambda () (letrec-values ([() (begin 'a (values))] [(x) 'b]) 'c)))
+ (rename-letrec-values
+ (lambda () (letrec-values ([() (begin 'a (values))] [(x) 'b]) 'c)))
+ (tag-app (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))
+ ;; FIXME: should have TAG step for transform to nested let-values
+ ]
+ [#:hidden-steps
+ (rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
+ (block->letrec (lambda () (letrec-values ([() (begin 'a (values))] [(x) 'b]) 'c)))
+ (rename-letrec-values
+ (lambda () (letrec-values ([() (begin 'a (values))] [(x) 'b]) 'c)))])]
[#:suite
"Top-level begin"
diff --git a/collects/tests/macro-debugger/tests/syntax-modules.rkt b/collects/tests/macro-debugger/tests/syntax-modules.rkt
@@ -282,6 +282,13 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(let-values ([(or-part) 'a])
+ (if or-part or-part (#%expression 'b)))
+ 'c)))
+ (macro ;; FIXME: 'untag-expr
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
(if or-part or-part 'b))
'c)))]
#:no-hidden-steps)
@@ -317,6 +324,12 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(let-values ([(or-part) 'a])
+ (if or-part or-part (#%expression 'b))))))
+ (macro ;; FIXME: 'untag-expr
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
(if or-part or-part 'b)))))])
;; FIXME: hidden steps for above, tricky
