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

Improve ->* expansion in certain cases.

Browse Source 
In some expansions, the function used to check the results could appear
multiple times in the expansion.  Factor out the results checker so that
we expand into multiple references to the same name, instead of inlining
the same lambda multiple times.
This commit is contained in:
Stevie Strickland 2010-11-08 15:36:53 -05:00
parent f8ca8f3677
commit 0237050ae0
1 changed files with 27 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -164,7 +164,11 @@ v4 todo:
(for/list ([r (in-list rngs)]) (for/list ([r (in-list rngs)])
(list r (gensym 'rng))) (list r (gensym 'rng)))
null)]) null)])
(with-syntax ([(rng-checker ...) (with-syntax ([(rng-checker-name ...)
(if rngs
(list (gensym 'rng-checker))
null)]
[(rng-checker ...)
(if rngs (if rngs
(with-syntax ([rng-len (length rngs)] (with-syntax ([rng-len (length rngs)]
[rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")]) [rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")])
@ -258,7 +262,7 @@ v4 todo:
(λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))]) (λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))])
(if no-rng-checking? (if no-rng-checking?
(inner-stx-gen #'()) (inner-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) inner-stx-gen)))] (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
@ -276,7 +280,7 @@ v4 todo:
#,(inner-stx-gen s #'(kwd-results)))))]) #,(inner-stx-gen s #'(kwd-results)))))])
(if no-rng-checking? (if no-rng-checking?
(outer-stx-gen #'()) (outer-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) outer-stx-gen)))]) (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen)))])
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)] (with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
[basic-lambda #'(λ basic-params pre ... basic-return)] [basic-lambda #'(λ basic-params pre ... basic-return)]
[kwd-lambda-name (gensym 'kwd-lambda)] [kwd-lambda-name (gensym 'kwd-lambda)]
@ -322,25 +326,28 @@ v4 todo:
[else (cons #'list (build-list (add1 (- max-arity min-arity)) (λ (n) (+ min-arity n))))])]) [else (cons #'list (build-list (add1 (- max-arity min-arity)) (λ (n) (+ min-arity n))))])])
(cond (cond
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(let ([basic-lambda-name basic-lambda]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(if (matches-arity-exactly? val contract-arity null null) (let ([basic-lambda-name basic-lambda])
basic-lambda-name (if (matches-arity-exactly? val contract-arity null null)
(let-values ([(vr va) (procedure-keywords val)] basic-lambda-name
[(basic-checker-name) basic-checker]) (let-values ([(vr va) (procedure-keywords val)]
(if (or (not va) (pair? vr) (pair? va)) [(basic-checker-name) basic-checker])
(make-keyword-procedure kwd-checker basic-checker-name) (if (or (not va) (pair? vr) (pair? va))
basic-checker-name))))] (make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name)))))]
[(pair? req-keywords) [(pair? req-keywords)
#`(let ([kwd-lambda-name kwd-lambda]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...)) (let ([kwd-lambda-name kwd-lambda])
kwd-lambda-name (if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...))
(make-keyword-procedure kwd-checker basic-checker)))] kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker))))]
[else [else
#`(let ([basic-lambda-name basic-lambda] #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
[kwd-lambda-name kwd-lambda]) (let ([basic-lambda-name basic-lambda]
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...)) [kwd-lambda-name kwd-lambda])
kwd-lambda-name (if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
(make-keyword-procedure kwd-checker basic-checker)))]))))))))))) kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker))))])))))))))))
;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one. ;; 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. ;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.