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

Fix tail call behavior for ->, ->* contracts.

Browse Source
This commit is contained in:
Stevie Strickland 2010-10-19 15:45:25 -07:00
parent 8835f2f470
commit 1a9dffe78d
1 changed files with 195 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -110,7 +110,19 @@ v4 todo:
(let-values ([(vr va) (procedure-keywords val)])
(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 (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]
[val val])
(with-syntax ([(pre ...)
@ -137,13 +149,15 @@ v4 todo:
[([opt-kwd opt-kwd-ctc opt-kwd-x] ...)
(for/list ([d (in-list opt-kwds)])
(list (car d) (cadr d) (gensym 'opt-kwds)))]
[(rng-checker ...)
[([rng-ctc rng-x] ...)
(if rngs
(for/list ([r (in-list rngs)])
(list r (gensym 'rng)))
null)])
(with-syntax ([(rng-checker ...)
(if rngs
(with-syntax ([rng-len (length rngs)]
[rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")]
[([rng-ctc rng-x] ...)
(for/list ([r (in-list rngs)])
(list r (gensym 'rng)))])
[rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")])
(with-syntax ([rng-params
(if (null? rngs)
#'rest-x
@ -171,7 +185,8 @@ v4 todo:
[max-arity (+ min-arity (length opt-doms))]
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))])
[need-apply-values? (or dom-rest (not (null? opt-doms)))]
[no-rng-checking? (not rngs)])
(with-syntax ([args-len
(if (= min-method-arity min-arity)
#'(length args)
@ -227,27 +242,31 @@ v4 todo:
#'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ... . rest-x)
#'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ...))]
[basic-return
(let ([inner-stx-gen
(if need-apply-values?
#'(apply values rng-checker ... this-param ... (dom-ctc dom-x) ... opt+rest-uses)
(let* ([mand-params #'(rng-checker ... this-param ... (dom-ctc dom-x) ...)]
[params-no-stx (syntax->list mand-params)])
(if (and (pair? params-no-stx) (null? (cdr params-no-stx)))
(car params-no-stx)
#`(values . #,mand-params))))]
(λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses))
(λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))])
(if no-rng-checking?
(inner-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) inner-stx-gen)))]
[kwd-return
(let* ([inner-stx-gen
(if need-apply-values?
#'(let ([kwd-results kwd-stx])
(if (null? kwd-results)
(apply values rng-checker ... this-param ... (dom-ctc dom-x) ... opt+rest-uses)
(apply values rng-checker ... kwd-results this-param ... (dom-ctc dom-x) ... opt+rest-uses)))
(let* ([mand-params #'(rng-checker ... this-param ... (dom-ctc dom-x) ...)]
[params-no-stx (syntax->list mand-params)])
(λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses))
(λ (s k) #`(values #,@s #,@k this-param ... (dom-ctc dom-x) ...)))]
[outer-stx-gen
(if (null? req-keywords)
(λ (s)
#`(let ([kwd-results kwd-stx])
(if (null? kwd-results)
#,(if (and (pair? params-no-stx) (null? params-no-stx))
(car params-no-stx)
#`(values . #,mand-params))
(values rng-checker ... kwd-results this-param ... (dom-ctc dom-x) ...)))))])
#,(inner-stx-gen s #'())
#,(inner-stx-gen s #'(kwd-results)))))
(λ (s)
#`(let ([kwd-results kwd-stx])
#,(inner-stx-gen s #'(kwd-results)))))])
(if no-rng-checking?
(outer-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) outer-stx-gen)))])
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
[basic-lambda #'(λ basic-params pre ... basic-return)]
[kwd-lambda-name (gensym 'kwd-lambda)]
@ -311,7 +330,7 @@ v4 todo:
[kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker)))]))))))))))
(make-keyword-procedure kwd-checker basic-checker)))])))))))))))
;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one.
;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.
@ -576,7 +595,8 @@ v4 todo:
(syntax->list #'(kwd-names ...)))
null
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))))
proxy-prop:contracted ctc)))])
proxy-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list rng-names ...)))))])
(syntax-property
(syntax
(build--> '->
@ -900,7 +920,8 @@ v4 todo:
(map list (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom-kwd-proj ...)))
(if rng-ctc (syntax->list #'(rng-proj ...)) #f))
proxy-prop:contracted ctc))))))))))]))
proxy-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))]))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))