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

missed a spot in the addition of chaperone info for opt/c

Browse Source 
original commit: 7820db9f8d37f2a65ebda21402bd551886494d64
This commit is contained in:
Robby Findler 2011-07-21 09:31:48 -05:00
parent 9ea5db6645
commit fd0971909b
1 changed files with 28 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/mzlib/private/contract-arrow.rkt
View File

@ -384,22 +384,24 @@
(define (opt/arrow-ctc doms rngs) (define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))] (generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
(let loop ([vars dom-vars] (let loop ([vars dom-vars]
[doms doms] [doms doms]
[next-doms null] [next-doms null]
[lifts-doms null] [lifts-doms null]
[superlifts-doms null] [superlifts-doms null]
[partials-doms null] [partials-doms null]
[stronger-ribs null]) [stronger-ribs null]
[chaperone? #t])
(cond (cond
[(null? doms) (values (reverse next-doms) [(null? doms) (values (reverse next-doms)
lifts-doms lifts-doms
superlifts-doms superlifts-doms
partials-doms partials-doms
stronger-ribs)] stronger-ribs
chaperone?)]
[else [else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs) (let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
(opt/i (opt/info-swap-blame opt/info) (car doms))]) (opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars) (loop (cdr vars)
(cdr doms) (cdr doms)
@ -410,23 +412,26 @@
(append lifts-doms lift) (append lifts-doms lift)
(append superlifts-doms superlift) (append superlifts-doms superlift)
(append partials-doms partial) (append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))] (append this-stronger-ribs stronger-ribs)
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) (and chaperone? this-chaperone?)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rngs-chaperone?)
(let loop ([vars rng-vars] (let loop ([vars rng-vars]
[rngs rngs] [rngs rngs]
[next-rngs null] [next-rngs null]
[lifts-rngs null] [lifts-rngs null]
[superlifts-rngs null] [superlifts-rngs null]
[partials-rngs null] [partials-rngs null]
[stronger-ribs null]) [stronger-ribs null]
[chaperone? #t])
(cond (cond
[(null? rngs) (values (reverse next-rngs) [(null? rngs) (values (reverse next-rngs)
lifts-rngs lifts-rngs
superlifts-rngs superlifts-rngs
partials-rngs partials-rngs
stronger-ribs)] stronger-ribs
chaperone?)]
[else [else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs) (let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
(opt/i opt/info (car rngs))]) (opt/i opt/info (car rngs))])
(loop (cdr vars) (loop (cdr vars)
(cdr rngs) (cdr rngs)
@ -437,7 +442,8 @@
(append lifts-rngs lift) (append lifts-rngs lift)
(append superlifts-rngs superlift) (append superlifts-rngs superlift)
(append partials-rngs partial) (append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)
(and this-chaperone? chaperone?)))]))])
(values (values
(with-syntax ((blame (opt/info-blame opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
@ -455,26 +461,29 @@
(append partials-doms partials-rngs) (append partials-doms partials-rngs)
#f #f
#f #f
(append stronger-ribs-dom stronger-ribs-rng)))) (append stronger-ribs-dom stronger-ribs-rng)
(and rngs-chaperone? doms-chaperone?))))
(define (opt/arrow-any-ctc doms) (define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)] (let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
(let loop ([vars dom-vars] (let loop ([vars dom-vars]
[doms doms] [doms doms]
[next-doms null] [next-doms null]
[lifts-doms null] [lifts-doms null]
[superlifts-doms null] [superlifts-doms null]
[partials-doms null] [partials-doms null]
[stronger-ribs null]) [stronger-ribs null]
[chaperone? #t])
(cond (cond
[(null? doms) (values (reverse next-doms) [(null? doms) (values (reverse next-doms)
lifts-doms lifts-doms
superlifts-doms superlifts-doms
partials-doms partials-doms
stronger-ribs)] stronger-ribs
chaperone?)]
[else [else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs) (let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
(opt/i (opt/info-swap-blame opt/info) (car doms))]) (opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars) (loop (cdr vars)
(cdr doms) (cdr doms)
@ -485,7 +494,8 @@
(append lifts-doms lift) (append lifts-doms lift)
(append superlifts-doms superlift) (append superlifts-doms superlift)
(append partials-doms partial) (append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)
(and chaperone? this-chaperone?)))]))])
(values (values
(with-syntax ((blame (opt/info-blame opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
@ -500,7 +510,8 @@
partials-doms partials-doms
#f #f
#f #f
stronger-ribs-dom))) stronger-ribs-dom
doms-chaperone?)))
(syntax-case* stx (-> values any) module-or-top-identifier=? (syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...)) [(-> dom ... (values rng ...))