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

refactored contract opters so they return structs instead

Browse Source 
of (8!) multiple values

original commit: 7221d01483eb92086ae98a16c63ae716e97ae267
This commit is contained in:
Robby Findler 2012-05-08 11:29:14 -05:00
parent d8e0ca691a
commit 71d054cc1f
1 changed files with 0 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -377,154 +377,3 @@
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
;;
;; arrow opter
;;
(define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null]
[chaperone? #t])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs
chaperone?)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)
(and chaperone? this-chaperone?)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rngs-chaperone?)
(let loop ([vars rng-vars]
[rngs rngs]
[next-rngs null]
[lifts-rngs null]
[superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null]
[chaperone? #t])
(cond
[(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs
chaperone?)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
(opt/i opt/info (car rngs))])
(loop (cdr vars)
(cdr rngs)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-rngs)
(append lifts-rngs lift)
(append superlifts-rngs superlift)
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)
(and this-chaperone? chaperone?)))]))])
(values
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len 0 '() '() #| keywords |# blame)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
#f
#f
(append stronger-ribs-dom stronger-ribs-rng)
(and rngs-chaperone? doms-chaperone?))))
(define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null]
[chaperone? #t])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs
chaperone?)]
[else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)
(and chaperone? this-chaperone?)))]))])
(values
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len 0 '() '() #|keywords|# blame)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
superlifts-doms
partials-doms
#f
#f
stronger-ribs-dom
doms-chaperone?)))
(syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...))
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...)))))]
[(-> dom ... any)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
[(-> dom ... rng)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng)))]))