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

adjust contract test suite to do more provide/contract => contract-out

Browse Source 
rewriting in order to test contract-out more
This commit is contained in:
Robby Findler 2013-05-15 09:26:05 -05:00
parent 09cf079453
commit c981c55768
1 changed files with 83 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
collects/tests/racket/contract-test.rktl
View File

@ -73,7 +73,7 @@
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
(list ',expression '(void)))) (list ',expression '(void))))
(let ([new-expression (rewrite-out expression)]) (let ([new-expression (rewrite-out expression)])
(unless (equal? new-expression expression) (when new-expression
(contract-eval (contract-eval
`(,test `(,test
(void) (void)
@ -88,51 +88,80 @@
(list ',(rewrite expression k) '(void)))))) (list ',(rewrite expression k) '(void))))))
(define (test/spec-passed/result name expression result) (define (test/spec-passed/result name expression result)
(printf "testing: ~s\n" name) (parameterize ([compile-enforce-module-constants #f])
(contract-eval `(,test ',result eval ',expression)) (printf "testing: ~s\n" name)
(let/ec k (contract-eval `(,test ',result eval ',expression))
(contract-eval (let/ec k
`(,test (contract-eval
',result `(,test
eval ',result
',(rewrite expression k))))) eval
',(rewrite expression k))))
(let ([new-expression (rewrite-out expression)])
(when new-expression
(printf "testing contract-out rewritten: ~s\n" name)
(contract-eval
`(,test
',result
eval
',new-expression))))))
;; rewrites `provide/contract' to use `contract-out' ;; rewrites `provide/contract' to use `contract-out'
(define (rewrite-out orig-exp) (define (rewrite-out orig-exp)
(let loop ([exp orig-exp]) (define rewrote? #f)
(match exp (define maybe-rewritten?
[`(module ,modname ,lang ,bodies ...) (let loop ([exp orig-exp])
(define at-beginning '()) (match exp
[`(module ,modname ,lang ,bodies ...)
;; remove (and save) the provide/contract declarations (define at-beginning '())
(define removed-bodies (define at-end '())
(apply
append ;; remove (and save) the provide/contract & contract-out
(for/list ([body (in-list bodies)]) ;; declarations, switching their senses
(match body (define removed-bodies
[`(provide/contract . ,args) (apply
(set! at-beginning (cons `(provide (contract-out . ,args)) append
at-beginning)) (for/list ([body (in-list bodies)])
(list)] (match body
[else [`(provide/contract . ,args)
(list body)])))) (set! rewrote? #t)
(set! at-beginning (cons `(provide (contract-out . ,args))
;; insert the provide/contract (rewrite to contract-out) after the at-beginning))
;; first require that has 'contract' in it (list)]
(define inserted-bodies [`(provide (contract-out . ,args))
(apply (set! rewrote? #t)
append (set! at-end (cons `(provide/contract . ,args)
(for/list ([body (in-list removed-bodies)]) at-end))
(match body (list)]
[`(require ,(? (λ (x) (and (symbol? x) (regexp-match #rx"contract" (symbol->string x)))) mod)) [else
(cons body (reverse at-beginning))] (list body)]))))
[else
(list body)])))) ;; insert the provide/contract (rewrite to contract-out) after the
;; first require that has 'contract' in it
`(module ,modname ,lang ,@inserted-bodies)] (define inserted-bodies
[(? list?) (if (equal? lang 'racket)
(map loop exp)] (append (reverse at-beginning)
[else exp]))) removed-bodies)
(apply
append
(for/list ([body (in-list removed-bodies)])
(match body
[`(require . ,(? (λ (l)
(for/or ([x (in-list l)])
(and (symbol? x)
(regexp-match #rx"contract" (symbol->string x)))))))
(cons body (reverse at-beginning))]
[else
(list body)])))))
`(module ,modname ,lang
(void) ;; always insert this to work around bug in 'provide'
,@inserted-bodies ,@(reverse at-end))]
[(? list?)
(map loop exp)]
[else exp])))
(and rewrote? maybe-rewritten?))
;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. ;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test.
(define (rewrite exp k) (define (rewrite exp k)
@ -14626,18 +14655,18 @@ so that propagation occurs.
'provide/contract38 'provide/contract38
'(begin '(begin
(eval (eval
'(module provide/contract38-a racket '(module provide/contract38-a racket
(define-struct s () #:transparent) (define-struct s () #:transparent)
(provide/contract [struct s ()]))) (provide/contract [struct s ()])))
(eval (eval
'(module provide/contract38-b racket '(module provide/contract38-b racket
(require 'provide/contract38-a) (require 'provide/contract38-a)
(define a-struct (make-s)) (define a-struct (make-s))
(define-values (type _) (struct-info a-struct)) (define-values (type _) (struct-info a-struct))
(provide the-answer) (provide the-answer)
(define the-answer (eq? type struct:s)))) (define the-answer (eq? type struct:s))))
(dynamic-require ''provide/contract38-b 'the-answer)) (dynamic-require ''provide/contract38-b 'the-answer))
#t) #t)