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

macro-stepper: update tests

Browse Source 
original commit: 5cf2767e7ab4c094468d175f39f07f75e6be3321
This commit is contained in:
Ryan Culpepper 2011-07-18 06:06:49 -06:00
parent d19c2208c9
commit b2397e3092
5 changed files with 50 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -135,7 +135,7 @@
[#:with-visible-form [#:with-visible-form
[#:left-foot] [#:left-foot]
[#:set-syntax (stx-car (stx-cdr #'?form))] [#:set-syntax (stx-car (stx-cdr #'?form))]
[#:step 'macro]] [#:step 'macro]] ;; FIXME: 'untag-expr
[#:pass2] [#:pass2]
[#:set-syntax (stx-car (stx-cdr oldform))] [#:set-syntax (stx-car (stx-cdr oldform))]
[#:rename ?form untag])] [#:rename ?form untag])]
@ -199,7 +199,8 @@
srenames srenames
'rename-lsv] 'rename-lsv]
[#:binders #'(?svars ... ?vvars ...)] [#: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 ;; If vrenames is #f, no var bindings to rename
[#:when vrenames [#:when vrenames
[#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv] [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]

23
collects/tests/macro-debugger/tests/hiding.rkt
View File

@ -55,27 +55,29 @@
(test-trivial-hiding/id (let-values ([(x) *]) *)) (test-trivial-hiding/id (let-values ([(x) *]) *))
(test-trivial-hiding/id (letrec-values ([(x) *]) *))) (test-trivial-hiding/id (letrec-values ([(x) *]) *)))
(test-suite "Blocks" (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/id (lambda (x y) x y))
(test-trivial-hiding (lambda (x y z) (begin x y) z) (test-trivial-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z)) (lambda (x y z) x y z))
(test-trivial-hiding (lambda (x y z) x (begin y z)) (test-trivial-hiding (lambda (x y z) x (begin y z))
(lambda (x y z) x y z)) (lambda (x y z) x y z))
(test-trivial-hiding (lambda (x) (define-values (y) x) y) (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) (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) (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) (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))) (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) (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)) (test-trivial-hiding (lambda (x y) x (id y))
(lambda (x y) x y)) (lambda (x y) x y))
(test-trivial-hiding (lambda (x) (define-values (y) (id 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) ;; Old hiding mechanism never did letrec transformation (unless forced)
(test-suite "Block normalization" (test-suite "Block normalization"
@ -123,17 +125,18 @@
(test-T-hiding (id (Tid x)) (test-T-hiding (id (Tid x))
(id x))) (id x)))
(test-suite "Blocks" (test-suite "Blocks"
;; See note about about internal definition expansion
(test-T-hiding/id (lambda (x y) x y)) (test-T-hiding/id (lambda (x y) x y))
(test-T-hiding (lambda (x y z) (begin x y) z) (test-T-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z)) (lambda (x y z) x y z))
(test-T-hiding (lambda (x y z) x (begin y z)) (test-T-hiding (lambda (x y z) x (begin y z))
(lambda (x y z) x y z)) (lambda (x y z) x y z))
(test-T-hiding (lambda (x) (define-values (y) x) y) (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) (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) (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)) (test-T-hiding (lambda (x) (id x))
(lambda (x) (id x))) (lambda (x) (id x)))
(test-T-hiding (lambda (x) (Tid x)) (test-T-hiding (lambda (x) (Tid x))

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

@ -115,21 +115,25 @@
;; Fixed 5/17/2007 ;; Fixed 5/17/2007
(test-case "hiding: keeping lifts in sync" (test-case "hiding: keeping lifts in sync"
(let ([freshname (gensym)]) (let ([freshname (gensym)])
(eval `(module ,freshname mzscheme (eval `(module ,freshname racket/base
(require (lib "contract.rkt")) (require racket/contract)
(provide/contract [f (integer? . -> . integer?)] (provide/contract
[c integer?]) [f (-> integer? integer?)]
[c integer?])
(define (f x) (add1 x)) (define (f x) (add1 x))
(define c 1))) (define c 1)))
(let ([rs (parameterize ((macro-policy standard-policy)) (let ([rs (parameterize ((macro-policy standard-policy))
(reductions (reductions
(trace `(module m mzscheme (trace `(module m mzscheme
(require ',freshname) (require (quote ,freshname))
(define (g y) c) (define (g y) c)
(define h c) (define h c)
(add1 (g 2))))))]) (add1 (g 2))))))])
(printf "not a step:\n~s\n"
(for/or ([s rs]) (and (not (step? s)) s)))
(check-pred list? rs) (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) ;; Bug from samth (6/5/2007)
;; problem seems to come from define-syntax -> letrec-syntaxes+values ;; problem seems to come from define-syntax -> letrec-syntaxes+values

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

@ -216,9 +216,17 @@
(lambda () 'a (define-values (x) 'b) 'c) (lambda () 'a (define-values (x) 'b) 'c)
[#:steps [#:steps
(rename-lambda (lambda () 'a (define-values (x) 'b) 'c)) (rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
(block->letrec (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c))) (block->letrec (lambda () (letrec-values ([() (begin 'a (values))] [(x) 'b]) 'c)))
(rename-letrec-values (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))] (rename-letrec-values
#:same-hidden-steps)] (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 [#:suite
"Top-level begin" "Top-level begin"

13
collects/tests/macro-debugger/tests/syntax-modules.rkt
View File

@ -278,6 +278,13 @@
(if or-part or-part (or 'b))) (if or-part or-part (or 'b)))
'c))) 'c)))
(macro (macro
(module m mzscheme
(#%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 (module m mzscheme
(#%plain-module-begin (#%plain-module-begin
(#%require (for-syntax scheme/mzscheme)) (#%require (for-syntax scheme/mzscheme))
@ -313,6 +320,12 @@
(let-values ([(or-part) 'a]) (let-values ([(or-part) 'a])
(if or-part or-part (or 'b)))))) (if or-part or-part (or 'b))))))
(macro (macro
(module m mzscheme
(#%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 (module m mzscheme
(#%plain-module-begin (#%plain-module-begin
(#%require (for-syntax scheme/mzscheme)) (#%require (for-syntax scheme/mzscheme))