[prev in list] [next in list] [prev in thread] [next in thread] 

List:       racket-dev
Subject:    [racket-dev] [plt] Push #21117: master branch updated
From:       robby () eecs ! northwestern ! edu (Robby Findler)
Date:       2010-09-18 12:39:49
Message-ID: AANLkTimfVF4Q1Qma+m+ZU8e7LAQmUU76-iJor=JdJMi+ () mail ! gmail ! com
[Download RAW message or body]

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
>

[prev in list] [next in list] [prev in thread] [next in thread]