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

25
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 ...)])
(let ([basic-lambda-name basic-lambda])
(if (matches-arity-exactly? val contract-arity null null) (if (matches-arity-exactly? val contract-arity null null)
basic-lambda-name basic-lambda-name
(let-values ([(vr va) (procedure-keywords val)] (let-values ([(vr va) (procedure-keywords val)]
[(basic-checker-name) basic-checker]) [(basic-checker-name) basic-checker])
(if (or (not va) (pair? vr) (pair? va)) (if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name) (make-keyword-procedure kwd-checker basic-checker-name)
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 ...)])
(let ([kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...)) (if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...))
kwd-lambda-name kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker)))] (make-keyword-procedure kwd-checker basic-checker))))]
[else [else
#`(let ([basic-lambda-name basic-lambda] #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...)) (if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
kwd-lambda-name 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. ;; 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.