From 71d054cc1f09c4403161bdd63c7fc4319918fd27 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 May 2012 11:29:14 -0500 Subject: [PATCH] refactored contract opters so they return structs instead of (8!) multiple values original commit: 7221d01483eb92086ae98a16c63ae716e97ae267 --- collects/mzlib/private/contract-arrow.rkt | 151 ---------------------- 1 file changed, 151 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 7afee3e..c3a8aa8 100644 --- a/collects/mzlib/private/contract-arrow.rkt +++ b/collects/mzlib/private/contract-arrow.rkt @@ -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)))]))