diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 7afee3ec7b..c3a8aa8e8b 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)))])) diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt index a487ac0bda..b2962605f9 100644 --- a/collects/racket/contract/private/basic-opters.rkt +++ b/collects/racket/contract/private/basic-opters.rkt @@ -12,20 +12,21 @@ ;; (define-for-syntax (opt/pred opt/info pred) (with-syntax ((pred pred)) - (values + (build-optres + #:exp (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) (blame (opt/info-blame opt/info))) (syntax (if (pred val) val (raise-opt/pred-error blame val 'pred)))) - null - null - null - (syntax (pred val)) - #f - null - #t))) + #:lifts null + #:superlifts null + #:partials null + #:flat (syntax (pred val)) + #:opt #f + #:stronger-ribs null + #:chaperone #t))) (define (raise-opt/pred-error blame val pred-name) (raise-blame-error @@ -52,15 +53,15 @@ ;; (define/opter (any/c opt/i opt/info stx) (syntax-case stx (any/c) - [any/c (values - (opt/info-val opt/info) - null - null - null - #'#t - #f - null - #t)])) + [any/c + (build-optres #:exp (opt/info-val opt/info) + #:lifts null + #:superlifts null + #:partials null + #:flat #'#t + #:opt #f + #:stronger-ribs null + #:chaperone #t)])) ;; ;; false/c @@ -86,26 +87,27 @@ (ctc (opt/info-contract opt/info)) (blame (opt/info-blame opt/info)) (lift-pred lift-pred)) - (values - (syntax (if (lift-pred val) - val - (raise-blame-error - blame - val - "expected: ~s, ~a: ~e" - (contract-name ctc) - (given/produced blame) - val))) + (build-optres + #:exp (syntax (if (lift-pred val) + val + (raise-blame-error + blame + val + "expected: ~s, ~a: ~e" + (contract-name ctc) + (given/produced blame) + val))) + #:lifts (interleave-lifts lift-vars (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]))) - null - null - (syntax (lift-pred val)) - #f - null - #t)))])) + #:superlifts null + #:partials null + #:flat (syntax (lift-pred val)) + #:opt #f + #:stronger-ribs null + #:chaperone #t)))])) ;; ;; flat-contract and friends diff --git a/collects/racket/contract/private/ds-helpers.rkt b/collects/racket/contract/private/ds-helpers.rkt index fffcf39576..930b4f91d0 100644 --- a/collects/racket/contract/private/ds-helpers.rkt +++ b/collects/racket/contract/private/ds-helpers.rkt @@ -147,15 +147,15 @@ which are then called when the contract's fields are explored (and (identifier? #'f) (opt/info-recf opt/info) (free-identifier=? (opt/info-recf opt/info) #'f)) - (values - #`(f #,id arg ...) - null - null - null - #f - #f - null - #f)] + (build-optres + #:exp #`(f #,id arg ...) + #:lifts null + #:superlifts null + #:partials null + #:flat #f + #:opt #f + #:stronger-ribs null + #:chaperone #f)] [else (opt/i (opt/info-change-val id opt/info) stx)])) @@ -193,8 +193,7 @@ which are then called when the contract's fields are explored [(id (x ...) ctc-exp) (and (identifier? (syntax id)) (andmap identifier? (syntax->list (syntax (x ...))))) - (let*-values ([(next lifts superlifts partials _ _2 _3 chaperone?) - (opt/enforcer-clause let-var (syntax ctc-exp))] + (let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))] [(maker-arg) (with-syntax ([val (opt/info-val opt/info)] [(new-let-bindings ...) @@ -204,11 +203,12 @@ which are then called when the contract's fields are explored arglist)]) #`(#,let-var #,(bind-lifts - superlifts + (optres-superlifts an-optres) #`(let (new-let-bindings ...) #,(bind-lifts - (append lifts partials) - next)))))]) + (append (optres-lifts an-optres) + (optres-partials an-optres)) + (optres-exp an-optres))))))]) (loop (cdr clauses) (cdr let-vars) (cdr arglists) @@ -227,23 +227,22 @@ which are then called when the contract's fields are explored (syntax->list (syntax (x ...)))))] [(id ctc-exp) (identifier? (syntax id)) - (let*-values ([(next lifts superlifts partials _ __ stronger-ribs chaperone?) - (opt/enforcer-clause let-var (syntax ctc-exp))] + (let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))] [(maker-arg) (with-syntax ((val (opt/info-val opt/info))) #`(#,let-var #,(bind-lifts - partials - next)))]) + (optres-partials an-optres) + (optres-exp an-optres))))]) (loop (cdr clauses) (cdr let-vars) (cdr arglists) (cdr ac-ids) (cons (car ac-ids) prior-ac-ids) (cons maker-arg maker-args) - (append lifts-ps lifts) - (append superlifts-ps superlifts) - (append stronger-ribs-ps stronger-ribs)))] + (append lifts-ps (optres-lifts an-optres)) + (append superlifts-ps (optres-superlifts an-optres)) + (append stronger-ribs-ps (optres-stronger-ribs an-optres))))] [(id ctc-exp) (raise-syntax-error name "expected identifier" stx (syntax id))]))])))) diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt index c253836f4c..9247cabedf 100644 --- a/collects/racket/contract/private/ds.rkt +++ b/collects/racket/contract/private/ds.rkt @@ -427,7 +427,8 @@ it around flattened out. (cons contract/info-var (syntax (make-opt-contract/info ctc enforcer-id id))))]) - (values + (build-optres + #:exp (syntax (cond [(opt-wrap-predicate val) @@ -462,15 +463,13 @@ it around flattened out. (contract-name ctc) (given/produced blame) val)])) - lifts - superlifts - partials - #f - #f - stronger-ribs - ;; opt'd struct contracts don't use chaperones yet - #f)))))))])) - ))))) + #:lifts lifts + #:superlifts superlifts + #:partials partials + #:flat #f + #:opt #f + #:stronger-ribs stronger-ribs + #:chaperone #f)))))))]))))))) (define-syntax (define-contract-struct stx) (syntax-case stx () diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index d99188c539..aa6736699b 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -23,7 +23,81 @@ opt/info-change-val opt/unknown - combine-two-chaperone?s) + combine-two-chaperone?s + + + optres-exp + optres-lifts + optres-superlifts + optres-partials + optres-flat + optres-opt + optres-stronger-ribs + optres-chaperone + build-optres) + +;; (define/opter ( opt/i opt/info stx) body) +;; +;; An opter is to a function with the following signature: +;; +;; opter : (syntax opt/info -> ) opt/info list-of-ids -> opt-res +;; +;; The first argument can be used to recursively process sub-contracts +;; It returns what an opter returns and its results should be accumulated +;; into the opter's results. +;; +;; The opt/info struct has a number of identifiers that get used to build +;; contracts; see opt-guts.rkt for the selectors. +;; +;; The last argument is a list of free-variables if the calling context +;; was define/opt, otherwise it is null. +;; +;; The fields of the optres struct are: +;; - the optimized syntax +;; - lifted variables: a list of (id, sexp) pairs +;; - super-lifted variables: functions or the such defined at the toplevel of the +;; calling context of the opt routine. +;; Currently this is only used for struct contracts. +;; - partially applied contracts: a list of (id, sexp) pairs +;; - if the contract being optimized is flat, +;; then an sexp that evals to bool, indicating if the contract passed or not, +;; else #f +;; This is used in conjunction with optimizing flat contracts into one boolean +;; expression when optimizing or/c. +;; - if the contract can be optimized, +;; then #f (that is, it is not unknown) +;; else the symbol of the lifted variable +;; This is used for contracts with subcontracts (like cons) doing checks. +;; - a list of stronger-ribs +;; - a boolean or a syntax object; if it is a boolean, +;; the boolean indicaties if this contract is a chaperone contract +;; if it is a syntax object, then evaluating its contents determines +;; if this is a chaperone contract + +(struct optres (exp + lifts + superlifts + partials + flat + opt + stronger-ribs + chaperone)) +(define (build-optres #:exp exp + #:lifts lifts + #:superlifts superlifts + #:partials partials + #:flat flat + #:opt opt + #:stronger-ribs stronger-ribs + #:chaperone chaperone) + (optres exp + lifts + superlifts + partials + flat + opt + stronger-ribs + chaperone)) ;; a hash table of opters (define opters-table @@ -169,7 +243,7 @@ [val (opt/info-val opt/info)] [uctc uctc] [blame (opt/info-blame opt/info)]) - (values + (optres #'(partial-var val) (list (cons #'lift-var #'(coerce-contract 'opt/c uctc))) @@ -200,4 +274,3 @@ (and chaperone-b? chaperone-a?)] [else #`(and #,chaperone-a? #,chaperone-b?)])) - diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 896971fb25..88abe51bcc 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -11,45 +11,6 @@ opt/direct begin-lifted) -;; (define/opter ( opt/i opt/info stx) body) -;; -;; An opter is to a function with the following signature: -;; -;; opter : (syntax opt/info -> ) opt/info list-of-ids -> -;; (values syntax syntax-list syntax-list -;; syntax-list (union syntax #f) (union syntax #f) syntax) -;; -;; The first argument can be used to recursively process sub-contracts -;; It returns what an opter returns and its results should be accumulated -;; into the opter's results. -;; -;; The opt/info struct has a number of identifiers that get used to build -;; contracts; see opt-guts.rkt for the selectors. -;; -;; The last argument is a list of free-variables if the calling context -;; was define/opt otherwise it is null. -;; -;; Every opter needs to return: -;; - the optimized syntax -;; - lifted variables: a list of (id, sexp) pairs -;; - super-lifted variables: functions or the such defined at the toplevel of the -;; calling context of the opt routine. -;; Currently this is only used for struct contracts. -;; - partially applied contracts: a list of (id, sexp) pairs -;; - if the contract being optimized is flat, -;; then an sexp that evals to bool, -;; else #f -;; This is used in conjunction with optimizing flat contracts into one boolean -;; expression when optimizing or/c. -;; - if the contract can be optimized, -;; then #f (that is, it is not unknown) -;; else the symbol of the lifted variable -;; This is used for contracts with subcontracts (like cons) doing checks. -;; - a list of stronger-ribs -;; - a boolean or a syntax object; if it is a boolean, -;; the boolean indicaties if this contract is a chaperone contract -;; if it is a syntax object, then evaluating its contents determines -;; if this is a chaperone contract (define-syntax (define/opter stx) (syntax-case stx () [(_ (for opt/i opt/info stx) expr ...) @@ -66,23 +27,20 @@ ;; ;; opt/recursive-call ;; -;; BUG: currently does not try to optimize the arguments, this requires changing -;; every opter to keep track of bound variables. -;; (define-for-syntax (opt/recursive-call opt/info stx) - (values - (with-syntax ((stx stx) - (val (opt/info-val opt/info)) - (blame (opt/info-blame opt/info))) - (syntax (let ((ctc stx)) - (((contract-projection ctc) blame) val)))) - null - null - null - #f - #f - null - null)) + (build-optres + #:exp (with-syntax ((stx stx) + (val (opt/info-val opt/info)) + (blame (opt/info-blame opt/info))) + (syntax (let ((ctc stx)) + (((contract-projection ctc) blame) val)))) + #:lifts null + #:superlifts null + #:partials null + #:flat #f + #:opt #f + #:stronger-ribs null + #:chaperone null)) ;; make-stronger : list-of-(union syntax #f) -> syntax (define-for-syntax (make-stronger strongers) @@ -122,17 +80,18 @@ [(number? konst) (values #`(and (number? #,v) (= #,konst #,v)) "=")])) - (values + (build-optres + #:exp #`(if #,predicate #,v (opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst)) - null - null - null - predicate - #f - null - #t)) + #:lifts null + #:superlifts null + #:partials null + #:flat predicate + #:opt #f + #:stronger-ribs null + #:chaperone #t)) (define (opt-constant-contract-failure blame val compare should-be) (raise-blame-error blame val "expected a value ~a to ~e" compare should-be)) @@ -144,7 +103,7 @@ ;; opt/i : id opt/info syntax -> ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) (define-for-syntax (opt/i opt/info stx) - ;; the case dispatch here must match what top-level-unknown? is doing + ;; te case dispatch here must match what top-level-unknown? is doing (syntax-case stx () [(ctc arg ...) (and (identifier? #'ctc) (opter #'ctc)) @@ -155,19 +114,20 @@ [(f arg ...) (and (identifier? #'f) (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f)))) - (values + (build-optres + #:exp #`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f)) #,(opt/info-contract opt/info) #,(opt/info-blame opt/info) #,(opt/info-val opt/info) arg ...) - null - null - null - #f - #f - null - #t)] + #:lifts null + #:superlifts null + #:partials null + #:flat #f + #:opt #f + #:stronger-ribs null + #:chaperone #t)] [konst (coerecable-constant? #'konst) (opt-constant-contract (syntax->datum #'konst) opt/info)] @@ -201,32 +161,24 @@ (define-syntax (opt/c stx) (syntax-case stx () [(_ e) - (let*-values ([(info) (make-opt/info #'ctc - #'val - #'blame - #f - '() - #f - #f - #'this - #'that)] - [(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)]) - (with-syntax ([next next]) - (bind-superlifts - superlifts - (bind-lifts - lifts - #`(make-opt-contract - (λ (ctc) - (λ (blame) - #,(bind-superlifts - partials - #`(λ (val) next)))) - (λ () e) - (λ (this that) #f) - (vector) - (begin-lifted (box #f)) - #,chaperone?)))))])) + (let () + (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that)) + (define an-optres (opt/i info #'e)) + (bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + #`(make-opt-contract + (λ (ctc) + (λ (blame) + #,(bind-superlifts + (optres-partials an-optres) + #`(λ (val) #,(optres-exp an-optres))))) + (λ () e) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)) + #,(optres-chaperone an-optres)))))])) ;; this macro optimizes 'e' as a contract, ;; using otherwise-id if it does not recognize 'e'. @@ -234,28 +186,21 @@ (syntax-case stx () [(_ e val-e blame-e otherwise-id) (identifier? #'otherwise-id) - (if (top-level-unknown? #'e) - #'(otherwise-id e val-e blame-e) - (let*-values ([(info) (make-opt/info #'ctc - #'val - #'blame - #f - '() - #f - #f - #'this - #'that)] - [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) - #`(let ([ctc e] ;;; hm... what to do about this?! - [val val-e] - [blame blame-e]) - #,(bind-superlifts - superlifts - (bind-lifts - lifts - (bind-superlifts - partials - next))))))])) + (cond + [(top-level-unknown? #'e) #'(otherwise-id e val-e blame-e)] + [else + (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that)) + (define an-optres (opt/i info #'e)) + #`(let ([ctc e] ;;; hm... what to do about this?! + [val val-e] + [blame blame-e]) + #,(bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + (bind-superlifts + (optres-partials an-optres) + (optres-exp an-optres)))))])])) (define-syntax (begin-lifted stx) (syntax-case stx () @@ -285,42 +230,34 @@ (define-syntax (opt/c-helper stx) (syntax-case stx () [(_ f1 f2 (id args ...) e) - (let*-values ([(info) (make-opt/info #'ctc - #'val - #'blame - #f - (syntax->list #'(args ...)) - #f - #f - #'this - #'that)] - [(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)]) - (with-syntax ([next next]) - #`(let () - (define (f2 ctc blame val args ...) - #,(bind-superlifts - superlifts - (bind-lifts - lifts - (bind-superlifts - partials - #'next)))) - (define (f1 args ...) - #,(bind-superlifts - superlifts - (bind-lifts - lifts - #`(make-opt-contract - (λ (ctc) - (λ (blame) - (λ (val) - (f2 ctc blame val args ...)))) - (λ () e) - (λ (this that) #f) - (vector) - (begin-lifted (box #f)) - #,chaperone?)))) - (values f1 f2))))])) + (let () + (define info (make-opt/info #'ctc #'val #'blame #f (syntax->list #'(args ...)) #f #f #'this #'that)) + (define an-optres (opt/i info #'e)) + #`(let () + (define (f2 ctc blame val args ...) + #,(bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + (bind-superlifts + (optres-partials an-optres) + (optres-exp an-optres))))) + (define (f1 args ...) + #,(bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + #`(make-opt-contract + (λ (ctc) + (λ (blame) + (λ (val) + (f2 ctc blame val args ...)))) + (λ () e) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)) + #,(optres-chaperone an-optres))))) + (values f1 f2)))])) ;; optimized contracts ;; diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index dcdfe63d6f..b2561b8407 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -18,24 +18,18 @@ (partial-var (car (generate-temporaries (syntax (partial)))))) (values (with-syntax ((partial-var partial-var) - (lift-var lift-var) - (uctc uctc) (val (opt/info-val opt/info))) (syntax (partial-var val))) (list (cons lift-var ;; FIXME needs to get the contract name somehow (with-syntax ((uctc uctc)) (syntax (coerce-contract 'opt/c uctc))))) - null + '() (list (cons partial-var (with-syntax ((lift-var lift-var) (blame (opt/info-blame opt/info))) - (syntax ((contract-projection lift-var) blame))))) - #f - lift-var - (list #f) - null))) + (syntax ((contract-projection lift-var) blame)))))))) (define (opt/or-ctc ps) (let ((lift-from-hos null) @@ -61,41 +55,41 @@ ho-ctc chaperone?)] [else - (let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) - (opt/i opt/info (car ps))]) - (if flat - (loop (cdr ps) - (cons flat next-ps) - (append lift-ps lift) - (append superlift-ps superlift) - (append partial-ps partial) - (append this-stronger-ribs stronger-ribs) - hos - ho-ctc - (combine-two-chaperone?s chaperone? this-chaperone?)) - (if (< (length hos) 1) - (loop (cdr ps) - next-ps - (append lift-ps lift) - (append superlift-ps superlift) - (append partial-ps partial) - (append this-stronger-ribs stronger-ribs) - (cons (car ps) hos) - next - (combine-two-chaperone?s chaperone? this-chaperone?)) - (loop (cdr ps) - next-ps - lift-ps - superlift-ps - partial-ps - stronger-ribs - (cons (car ps) hos) - ho-ctc - chaperone?))))]))]) + (define ps-optres (opt/i opt/info (car ps))) + (if (optres-flat ps-optres) + (loop (cdr ps) + (cons (optres-flat ps-optres) next-ps) + (append lift-ps (optres-lifts ps-optres)) + (append superlift-ps (optres-superlifts ps-optres)) + (append partial-ps (optres-partials ps-optres)) + (append (optres-stronger-ribs ps-optres) stronger-ribs) + hos + ho-ctc + (combine-two-chaperone?s chaperone? (optres-chaperone ps-optres))) + (if (< (length hos) 1) + (loop (cdr ps) + next-ps + (append lift-ps (optres-lifts ps-optres)) + (append superlift-ps (optres-superlifts ps-optres)) + (append partial-ps (optres-partials ps-optres)) + (append (optres-stronger-ribs ps-optres) stronger-ribs) + (cons (car ps) hos) + (optres-exp ps-optres) + (combine-two-chaperone?s chaperone? (optres-chaperone ps-optres))) + (loop (cdr ps) + next-ps + lift-ps + superlift-ps + partial-ps + stronger-ribs + (cons (car ps) hos) + ho-ctc + chaperone?)))]))]) (with-syntax ((next-ps (with-syntax (((opt-p ...) (reverse opt-ps))) (syntax (or opt-p ...))))) - (values + (build-optres + #:exp (cond [(null? hos) (with-syntax ([val (opt/info-val opt/info)] @@ -113,21 +107,22 @@ (if next-ps val ho-ctc)))] ;; FIXME something's not right with this case. [(> (length hos) 1) - (let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) - (opt/or-unknown stx)]) - (set! lift-from-hos lift-hos) - (set! superlift-from-hos superlift-hos) - (set! partial-from-hos partial-hos) - (with-syntax ((next-hos next-hos)) - (syntax - (if next-ps val next-hos))))]) + (define-values (exp new-lifts new-superlifts new-partials) (opt/or-unknown stx)) + (set! lift-from-hos new-lifts) + (set! superlift-from-hos new-superlifts) + (set! partial-from-hos new-partials) + #`(if next-ps val #,exp)]) + #:lifts (append lift-ps lift-from-hos) + #:superlifts (append superlift-ps superlift-from-hos) + #:partials (append partial-ps partial-from-hos) + #:flat (if (null? hos) (syntax next-ps) #f) - #f - stronger-ribs - chaperone?))))) + #:opt #f + #:stronger-ribs stronger-ribs + #:chaperone chaperone?))))) (syntax-case stx (or/c) [(or/c p ...) @@ -152,16 +147,18 @@ (blame (opt/info-blame opt/info)) (this (opt/info-this opt/info)) (that (opt/info-that opt/info))) - (values + (build-optres + #:exp (syntax (if (and (number? val) (<= n val m)) val (raise-opt-between/c-error blame val n m))) - lifts3 - null - null - (syntax (and (number? val) (<= n val m))) - #f + #:lifts lifts3 + #:superlifts null + #:partials null + #:flat (syntax (and (number? val) (<= n val m))) + #:opt #f + #:stronger-ribs (list (new-stronger-var lift-low (λ (this that) @@ -174,6 +171,7 @@ (with-syntax ([this this] [that that]) (syntax (<= this that)))))) + #:chaperone #t)))))])) (define (raise-opt-between/c-error blame val lo hi) @@ -195,23 +193,25 @@ (blame (opt/info-blame opt/info)) (this (opt/info-this opt/info)) (that (opt/info-that opt/info))) - (values + (build-optres + #:exp (syntax (if (and (real? val) (comparison val m)) val (raise-opt-single-comparison-opter-error blame val comparison m))) - lifts3 - null - null - (syntax (and (number? val) (comparison val m))) - #f + #:lifts lifts3 + #:superlifts null + #:partials null + #:flat (syntax (and (number? val) (comparison val m))) + #:opt #f + #:stronger-ribs (list (new-stronger-var lift-low (λ (this that) (with-syntax ([this this] [that that]) (syntax (comparison this that)))))) - #t))))))) + #:chaperone #t))))))) (define (raise-opt-single-comparison-opter-error blame val comparison m) (raise-blame-error @@ -286,89 +286,95 @@ (define/opter (cons/c opt/i opt/info stx) (define (opt/cons-ctc hdp tlp) - (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd hd-chaperone?) - (opt/i opt/info hdp)] - [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl tl-chaperone?) - (opt/i opt/info tlp)]) - (with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) - (syntax (pair? val))))) - (values - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (blame (opt/info-blame opt/info)) - (next-hdp next-hdp) - (next-tlp next-tlp)) - (syntax (if check - (cons (let ((val (car val))) next-hdp) - (let ((val (cdr val))) next-tlp)) - (raise-blame-error - blame - val - "expected: ~s, ~a: ~e" - (contract-name ctc) - (given/produced blame) - val)))) - (append lifts-hdp lifts-tlp) - (append superlifts-hdp superlifts-tlp) - (append partials-hdp partials-tlp) - (if (and flat-hdp flat-tlp) - (with-syntax ((val (opt/info-val opt/info)) - (flat-hdp flat-hdp) - (flat-tlp flat-tlp)) - (syntax (and check - (let ((val (car val))) flat-hdp) - (let ((val (cdr val))) flat-tlp)))) - #f) - #f - (append stronger-ribs-hd stronger-ribs-tl) - (combine-two-chaperone?s hd-chaperone? tl-chaperone?))))) + (define optres-hd (opt/i opt/info hdp)) + (define optres-tl (opt/i opt/info tlp)) + (with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) + (syntax (pair? val))))) + (build-optres + #:exp + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (blame (opt/info-blame opt/info)) + (next-hdp (optres-exp optres-hd)) + (next-tlp (optres-exp optres-tl))) + (syntax (if check + (cons (let ((val (car val))) next-hdp) + (let ((val (cdr val))) next-tlp)) + (raise-blame-error + blame + val + "expected: ~s, ~a: ~e" + (contract-name ctc) + (given/produced blame) + val)))) + #:lifts + (append (optres-lifts optres-hd) (optres-lifts optres-tl)) + #:superlifts + (append (optres-superlifts optres-hd) (optres-superlifts optres-tl)) + #:partials + (append (optres-partials optres-hd) (optres-partials optres-tl)) + #:flat + (if (and (optres-flat optres-hd) (optres-flat optres-tl)) + (with-syntax ((val (opt/info-val opt/info)) + (flat-hdp (optres-flat optres-hd)) + (flat-tlp (optres-flat optres-tl))) + (syntax (and check + (let ((val (car val))) flat-hdp) + (let ((val (cdr val))) flat-tlp)))) + #f) + #:opt #f + #:stronger-ribs + (append (optres-stronger-ribs optres-hd) (optres-stronger-ribs optres-tl)) + #:chaperone + (combine-two-chaperone?s (optres-chaperone optres-hd) (optres-chaperone optres-tl))))) (syntax-case stx (cons/c) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) (define-for-syntax (opt/listof-ctc content non-empty? opt/i opt/info) - (let-values ([(next lifts superlifts partials flat unknown stronger-ribs chaperone?) - (opt/i opt/info content)]) - (with-syntax ([check (with-syntax ((val (opt/info-val opt/info))) - (if non-empty? - #'(and (list? val) (pair? val)) - #'(list? val)))] - [val (opt/info-val opt/info)]) - - (values - (with-syntax ([blame (opt/info-blame opt/info)] - [next next]) - (with-syntax ([(non-empty-check ...) (if non-empty? - (list #'(pair? val)) - (list))]) - #`(if check - (for/list ([val (in-list val)]) - next) - (raise-blame-error - blame - val - #,(if non-empty? - "expected a non-empty list" - "expected a list"))))) - lifts - superlifts - partials - (if flat - (with-syntax ((val (opt/info-val opt/info)) - (flat flat)) - #`(and check - #,@(if non-empty? (list #'(pair? val)) '()) - (let loop ([lst val]) - (cond - [(null? lst) #t] - [else - (let ([val (car lst)]) - (and flat - (loop (cdr lst))))])))) - #f) - #f - stronger-ribs - chaperone?)))) + (define optres-ele (opt/i opt/info content)) + (with-syntax ([check (with-syntax ((val (opt/info-val opt/info))) + (if non-empty? + #'(and (list? val) (pair? val)) + #'(list? val)))] + [val (opt/info-val opt/info)]) + + (build-optres + #:exp + (with-syntax ([blame (opt/info-blame opt/info)] + [next (optres-exp optres-ele)]) + (with-syntax ([(non-empty-check ...) (if non-empty? + (list #'(pair? val)) + (list))]) + #`(if check + (for/list ([val (in-list val)]) + next) + (raise-blame-error + blame + val + #,(if non-empty? + "expected a non-empty list" + "expected a list"))))) + #:lifts (optres-lifts optres-ele) + #:superlifts (optres-superlifts optres-ele) + #:partials (optres-partials optres-ele) + #:flat + (if (optres-flat optres-ele) + (with-syntax ((val (opt/info-val opt/info)) + (flat (optres-flat optres-ele))) + #`(and check + #,@(if non-empty? (list #'(pair? val)) '()) + (let loop ([lst val]) + (cond + [(null? lst) #t] + [else + (let ([val (car lst)]) + (and flat + (loop (cdr lst))))])))) + #f) + #:opt #f + #:stronger-ribs (optres-stronger-ribs optres-ele) + #:chaperone (optres-chaperone optres-ele)))) (define/opter (listof opt/i opt/info stx) (syntax-case stx () @@ -403,20 +409,19 @@ 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)) - (val (opt/info-val opt/info))) - (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) - (combine-two-chaperone?s chaperone? this-chaperone?)))]))] + (define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms))) + (loop (cdr vars) + (cdr doms) + (cons (with-syntax ((next (optres-exp optres-dom)) + (car-vars (car vars)) + (val (opt/info-val opt/info))) + (syntax (let ((val car-vars)) next))) + next-doms) + (append lifts-doms (optres-lifts optres-dom)) + (append superlifts-doms (optres-superlifts optres-dom)) + (append partials-doms (optres-partials optres-dom)) + (append (optres-stronger-ribs optres-dom) stronger-ribs) + (combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))] [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?) (let loop ([vars rng-vars] [rngs rngs] @@ -434,20 +439,19 @@ 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)) - (val (opt/info-val opt/info))) - (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) - (combine-two-chaperone?s chaperone? this-chaperone?)))]))]) + (define optres-rng (opt/i opt/info (car rngs))) + (loop (cdr vars) + (cdr rngs) + (cons (with-syntax ((next (optres-exp optres-rng)) + (car-vars (car vars)) + (val (opt/info-val opt/info))) + (syntax (let ((val car-vars)) next))) + next-rngs) + (append lifts-rngs (optres-lifts optres-rng)) + (append superlifts-rngs (optres-superlifts optres-rng)) + (append partials-rngs (optres-partials optres-rng)) + (append (optres-stronger-ribs optres-rng) stronger-ribs) + (combine-two-chaperone?s chaperone? (optres-chaperone optres-rng)))]))]) (values (with-syntax ((val (opt/info-val opt/info)) (blame (opt/info-blame opt/info)) @@ -499,19 +503,16 @@ 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) - (combine-two-chaperone?s chaperone? this-chaperone?)))]))]) + (define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms))) + (loop (cdr vars) + (cdr doms) + (cons #`(let ([#,(opt/info-val opt/info) #,(car vars)]) #,(optres-exp optres-dom)) + next-doms) + (append lifts-doms (optres-lifts optres-dom)) + (append superlifts-doms (optres-superlifts optres-dom)) + (append partials-doms (optres-partials optres-dom)) + (append (optres-stronger-ribs optres-dom) stronger-ribs) + (combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))]) (values (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) @@ -536,45 +537,49 @@ (syntax-case* stx (-> values any any/c) module-or-top-identifier=? [(-> any/c ... any) (with-syntax ([n (- (length (syntax->list stx)) 2)]) - (values + (build-optres + #:exp (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) (blame (opt/info-blame opt/info))) (syntax (if (procedure-arity-includes? val n) val (raise-flat-arrow-err blame val n)))) - null - null - null - #'(procedure-arity-includes? val n) - #f - null - #t))] + #:lifts null + #:superlifts null + #:partials null + #:flat #'(procedure-arity-includes? val n) + #:opt #f + #:stronger-ribs null + #:chaperone #t))] [(-> 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 - (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?) (opt/arrow-ctc (syntax->list (syntax (dom ...))) (syntax->list (syntax (rng ...))))]) (if (eq? chaperone? #t) - (values next lift superlift partial flat _ stronger-ribs chaperone?) + (build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial + #:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?) (opt/unknown opt/i opt/info stx))))] [(-> 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 - (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?) (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]) (if (eq? chaperone? #t) - (values next lift superlift partial flat _ stronger-ribs chaperone?) + (build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial + #:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?) (opt/unknown opt/i opt/info stx))))] [(-> 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 - (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?) (opt/arrow-ctc (syntax->list (syntax (dom ...))) (list #'rng))]) (if (eq? chaperone? #t) - (values next lift superlift partial flat _ stronger-ribs chaperone?) + (build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial + #:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?) (opt/unknown opt/i opt/info stx))))])) (define (raise-flat-arrow-err blame val n) diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index 7a7e814855..c431133856 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -795,17 +795,12 @@ (define sub-val (car (generate-temporaries '(struct/dc)))) - (define-values (this-code - this-lifts this-super-lifts this-partially-applied - this-flat? this-can-be-optimized? this-stronger-ribs - this-chaperone?) - (opt/i (opt/info-change-val sub-val opt/info) - exp)) + (define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp)) (when dep-vars (for ([dep-var (in-list (syntax->list dep-vars))]) (free-identifier-mapping-put! depended-on-fields dep-var #t))) - (free-identifier-mapping-put! flat-fields sel-id this-flat?) + (free-identifier-mapping-put! flat-fields sel-id (optres-flat this-optres)) (define this-body-code (cond @@ -815,17 +810,17 @@ [(dep-var ...) dep-vars]) #`(let ([dep-var (sel #,(opt/info-val opt/info))] ...) #,(bind-superlifts - this-super-lifts + (optres-superlifts this-optres) (bind-lifts - this-lifts + (optres-lifts this-optres) (bind-lifts - this-partially-applied - this-code)))))] - [else this-code])) + (optres-partials this-optres) + (optres-exp this-optres))))))] + [else (optres-exp this-optres)])) (define this-chap-code - (and (or (not this-flat?) + (and (or (not (optres-flat this-optres)) lazy?) (with-syntax ([proc-name (string->symbol (format "~a-~a-chap" @@ -844,7 +839,7 @@ proc-name)))))) (define this-fo-code - (and (and this-flat? + (and (and (optres-flat this-optres) (not lazy?)) #`(let ([#,sub-val (#,(id->sel-id #'struct-id sel-id) @@ -857,12 +852,12 @@ (if this-chap-code (list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code) s-chap-code) - (if dep-vars s-lifts (append this-lifts s-lifts)) - (if dep-vars s-super-lifts (append this-super-lifts s-super-lifts)) - (if dep-vars s-partially-applied (append this-partially-applied s-partially-applied)) - (and this-can-be-optimized? can-be-optimized?) - (if dep-vars stronger-ribs (append this-stronger-ribs stronger-ribs)) - (combine-two-chaperone?s chaperone? this-chaperone?)))) + (if dep-vars s-lifts (append (optres-lifts this-optres) s-lifts)) + (if dep-vars s-super-lifts (append (optres-superlifts this-optres) s-super-lifts)) + (if dep-vars s-partially-applied (append (optres-partials this-optres) s-partially-applied)) + (and (optres-opt this-optres) can-be-optimized?) + (if dep-vars stronger-ribs (append (optres-stronger-ribs this-optres) stronger-ribs)) + (combine-two-chaperone?s chaperone? (optres-chaperone this-optres))))) ;; to avoid having to deal with indy-ness, just give up if any ;; of the fields that are depended on aren't flat @@ -879,33 +874,37 @@ [(free-var ...) (opt/info-free-vars opt/info)] [(index ...) (build-list (length (opt/info-free-vars opt/info)) values)] [pred? (list-ref info 2)]) - (values (if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here. - #`(if (pred? #,(opt/info-val opt/info)) - (begin - #,@s-fo-code - #,(opt/info-val opt/info)) - (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) - #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) - (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) - (and (eq? (vector-ref v index) free-var) ...))) + (build-optres + #:exp + (if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here. + #`(if (pred? #,(opt/info-val opt/info)) + (begin + #,@s-fo-code + #,(opt/info-val opt/info)) + (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) + #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) + (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) + (and (eq? (vector-ref v index) free-var) ...))) + #,(opt/info-val opt/info) + (if (pred? #,(opt/info-val opt/info)) + (begin + #,@s-fo-code + (chaperone-struct #,(opt/info-val opt/info) - (if (pred? #,(opt/info-val opt/info)) - (begin - #,@s-fo-code - (chaperone-struct - #,(opt/info-val opt/info) - #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here - stronger-prop-desc - (vector free-var ...))) - (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))) - s-lifts - s-super-lifts - s-partially-applied - #f ;; flat sexp - can-be-optimized? - stronger-ribs - #t ;;chaperone? - ))]))])) + #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here + stronger-prop-desc + (vector free-var ...))) + (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))) + #:lifts + s-lifts + #:superlifts + s-super-lifts + #:partials + s-partially-applied + #:flat #f + #:opt can-be-optimized? + #:stronger-ribs stronger-ribs + #:chaperone #t))]))])) (define (struct/dc-error blame obj what) (raise-blame-error blame obj