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

127
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 ...)
(define at-beginning '())
(define at-end '())
;; remove (and save) the provide/contract declarations ;; remove (and save) the provide/contract & contract-out
(define removed-bodies ;; declarations, switching their senses
(apply (define removed-bodies
append (apply
(for/list ([body (in-list bodies)]) append
(match body (for/list ([body (in-list bodies)])
[`(provide/contract . ,args) (match body
(set! at-beginning (cons `(provide (contract-out . ,args)) [`(provide/contract . ,args)
at-beginning)) (set! rewrote? #t)
(list)] (set! at-beginning (cons `(provide (contract-out . ,args))
[else at-beginning))
(list body)])))) (list)]
[`(provide (contract-out . ,args))
(set! rewrote? #t)
(set! at-end (cons `(provide/contract . ,args)
at-end))
(list)]
[else
(list body)]))))
;; insert the provide/contract (rewrite to contract-out) after the ;; insert the provide/contract (rewrite to contract-out) after the
;; first require that has 'contract' in it ;; first require that has 'contract' in it
(define inserted-bodies (define inserted-bodies
(apply (if (equal? lang 'racket)
append (append (reverse at-beginning)
(for/list ([body (in-list removed-bodies)]) removed-bodies)
(match body (apply
[`(require ,(? (λ (x) (and (symbol? x) (regexp-match #rx"contract" (symbol->string x)))) mod)) append
(cons body (reverse at-beginning))] (for/list ([body (in-list removed-bodies)])
[else (match body
(list 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 ,@inserted-bodies)] `(module ,modname ,lang
[(? list?) (void) ;; always insert this to work around bug in 'provide'
(map loop exp)] ,@inserted-bodies ,@(reverse at-end))]
[else exp]))) [(? 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,17 +14655,17 @@ 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)