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

Have unconstrained-domain-> do tail checks as well.

Browse Source
This commit is contained in:
Stevie Strickland 2010-10-21 15:20:04 -07:00
parent 1a9dffe78d
commit b272c02548
2 changed files with 37 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/racket/contract/private/arrow.rkt
View File

@ -51,6 +51,19 @@ v4 todo:
#:property prop:procedure 0 #:property prop:procedure 0
#:property prop:contracted 1) #:property prop:contracted 1)
(define contract-key (gensym 'contract-key))
(define-for-syntax (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen)
#`(call-with-immediate-continuation-mark
contract-key
(λ (m)
(cond
[(and m
(= (length m) #,num-rng-ctcs)
(andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
#,(call-gen #'())]
[else #,(call-gen rng-checkers)]))))
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
@ -58,7 +71,7 @@ v4 todo:
[(proj-x ...) (generate-temporaries #'(rngs ...))] [(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(define name (define name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)) (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
@ -73,10 +86,19 @@ v4 todo:
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(apply values res-checker kwd-vals args)) #,(check-tail-contract
(length (syntax->list #'(rngs ...)))
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))
(λ args (λ args
(apply values res-checker args))) #,(check-tail-contract
proxy-prop:contracted ctc))))) (length (syntax->list #'(rngs ...)))
#'(p-app-x ...)
(list #'res-checker)
(λ (s) #`(apply values #,@s args)))))
proxy-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list p-app-x ...)))))))
(define ctc (define ctc
(if (and (chaperone-contract? rngs-x) ...) (if (and (chaperone-contract? rngs-x) ...)
(make-chaperone-contract (make-chaperone-contract
@ -110,19 +132,7 @@ v4 todo:
(let-values ([(vr va) (procedure-keywords val)]) (let-values ([(vr va) (procedure-keywords val)])
(and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds))))) (and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds)))))
(define contract-key (gensym 'contract-key))
(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) (define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs)
(define (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen)
#`(call-with-immediate-continuation-mark
contract-key
(λ (m)
(cond
[(and m
(= (length m) #,num-rng-ctcs)
(andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
#,(call-gen #'())]
[else #,(call-gen rng-checkers)]))))
(with-syntax ([blame blame] (with-syntax ([blame blame]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)

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

@ -9794,6 +9794,17 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (c)))
(ctest 1
'tail-unconstrained-domain-arrow
(let ([c (counter)])
(letrec ([f
(contract (unconstrained-domain-> c)
(λ (x) (if (zero? x) x (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 2 (ctest 2
'tail-multiple-value-arrow 'tail-multiple-value-arrow
(let ([c (counter)]) (let ([c (counter)])