You don't need that proxy-of test in there, right? The object-name test covers that, no?
Robby On Fri, Sep 17, 2010 at 10:18 PM, <[email protected]> wrote: > sstrickl has updated `master' from d92c4e44e2 to 05e714881d. > http://git.racket-lang.org/plt/d92c4e44e2..05e714881d > > =====[ 1 Commits ]====================================================== > > Directory summary: > 43.9% collects/mzlib/private/ > 56.0% collects/racket/contract/private/ > > ~~~~~~~~~~ > > 05e7148 Stevie Strickland <[email protected]> 2010-06-11 17:28 > : > | Convert unconstrained-domain-> to chaperones. > : > M collects/mzlib/private/contract-arrow.rkt | 41 +++++++++++++-------- > M collects/racket/contract/private/arrow.rkt | 48 +++++++++++++----------- > M collects/racket/contract/private/base.rkt | 1 + > > =====[ Overall Diff ]=================================================== > > collects/mzlib/private/contract-arrow.rkt > ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > --- OLD/collects/mzlib/private/contract-arrow.rkt > +++ NEW/collects/mzlib/private/contract-arrow.rkt > @@ -35,22 +35,33 @@ > [(res-x ...) (generate-temporaries #'(rngs ...))]) > #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) > (let ([proj-x (contract-projection rngs-x)] ...) > - (define ctc > - (make-contract > - #:name > - (build-compound-type-name 'unconstrained-domain-> > (contract-name rngs-x) ...) > - #:projection > - (位 (blame) > - (let ([p-app-x (proj-x blame)] ...) > - (位 (val) > - (if (procedure? val) > - (make-contracted-function > + (define name > + (build-compound-type-name 'unconstrained-domain-> > (contract-name rngs-x) ...)) > + (define (proj wrapper) > + (位 (blame) > + (let* ([p-app-x (proj-x blame)] ... > + [res-checker (位 (res-x ...) (values (p-app-x res-x) > ...))]) > + (位 (val) > + (if (procedure? val) > + (wrapper > + val > + (make-keyword-procedure > + (位 (kwds kwd-vals . args) > + (apply values res-checker kwd-vals args)) > (位 args > - (let-values ([(res-x ...) (apply val args)]) > - (values (p-app-x res-x) ...))) > - ctc) > - (raise-blame-error blame val "expected a > procedure"))))) > - #:first-order procedure?)) > + (apply values res-checker args))) > + proxy-prop:contracted ctc) > + (raise-blame-error blame val "expected a > procedure")))))) > + (define ctc > + (if (and (chaperone-contract? rngs-x) ...) > + (make-chaperone-contract > + #:name name > + #:projection (proj chaperone-procedure) > + #:first-order procedure?) > + (make-contract > + #:name name > + #:projection (proj proxy-procedure) > + #:first-order procedure?))) > ctc)))])) > > (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) > > collects/racket/contract/private/arrow.rkt > ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > --- OLD/collects/racket/contract/private/arrow.rkt > +++ NEW/collects/racket/contract/private/arrow.rkt > @@ -60,29 +60,33 @@ v4 todo: > [(res-x ...) (generate-temporaries #'(rngs ...))]) > #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) > (let ([proj-x (contract-projection rngs-x)] ...) > + (define name > + (build-compound-type-name 'unconstrained-domain-> > (contract-name rngs-x) ...)) > + (define (projection wrapper) > + (位 (blame) > + (let* ([p-app-x (proj-x blame)] ... > + [res-checker (位 (res-x ...) (values (p-app-x res-x) > ...))]) > + (位 (val) > + (unless (procedure? val) > + (raise-blame-error blame val "expected a procedure, > got ~v" val)) > + (wrapper > + val > + (make-keyword-procedure > + (位 (kwds kwd-vals . args) > + (apply values res-checker kwd-vals args)) > + (位 args > + (apply values res-checker args))) > + proxy-prop:contracted ctc))))) > (define ctc > - (make-contract > - #:name > - (build-compound-type-name 'unconstrained-domain-> > (contract-name rngs-x) ...) > - #:projection > - (位 (blame) > - (let ([p-app-x (proj-x blame)] ...) > - (位 (val) > - (if (procedure? val) > - (make-contracted-function > - (make-keyword-procedure > - (位 (kwds kwd-vals . args) > - (let-values ([(res-x ...) (keyword-apply val > kwds kwd-vals args)]) > - (values (p-app-x res-x) ...))) > - (位 args > - (let-values ([(res-x ...) (apply val args)]) > - (values (p-app-x res-x) ...)))) > - ctc) > - (raise-blame-error blame > - val > - "expected a procedure"))))) > - #:first-order > - procedure?)) > + (if (and (chaperone-contract? rngs-x) ...) > + (make-chaperone-contract > + #:name name > + #:projection (projection chaperone-procedure) > + #:first-order procedure?) > + (make-contract > + #:name name > + #:projection (projection proxy-procedure) > + #:first-order procedure?))) > ctc)))])) > > > > collects/racket/contract/private/base.rkt > ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > --- OLD/collects/racket/contract/private/base.rkt > +++ NEW/collects/racket/contract/private/base.rkt > @@ -51,6 +51,7 @@ improve method arity mismatch contract violation error > messages? > (if (and name > (not (parameter? new-val)) ;; when PR 11221 is fixed, remove > this line > (procedure? new-val) > + (not (proxy-of? new-val v)) ;; proxies/chaperones handle this > fine > (not (eq? name (object-name new-val)))) > (let ([name (if (symbol? name) > name > _________________________________________________ For list-related administrative tasks: http://lists.racket-lang.org/listinfo/dev
