[racket-dev] [plt] Push #21117: master branch updated

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,  <sstrickl at racket-lang.org> 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 <sstrickl at racket-lang.org> 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
>