Add support for collapsible contracts (#2367)
* Add support for space-efficient vector and arrow contracts. When an eleventh contract would be applied to a function or vector, switch representation for the wrapper and try eliding redundant checks. The resulting value keeps a constant number of chaperone/impersonator wrappers regardless of the number of contracts applied to it, and won't run any (provably) redundant checks. This avoids a pathological case where, e.g., a function crosses a boundary inside a loop, and gets wrapped N times (or worse, 2^N). The optimization for function contracts currently only applies for fixed-arity functions and contracts, and only for functions with known result-arity of 1. These limitations are not fundamental. Checking specific checks is not as optimized as for regular arrow contracts yet. (Specifically: arity-specific wrappers and tail-marks-match support is missing.) Again, not a fundamental limitation. Further described in the OOPSLA 2018 Paper: "Collapsible Contracts: Fixing a Pathology of Gradual Typing" In collaboration with Ben Greenman, Christophe Scholliers, Robby Findler, and Vincent St-Amour.
This commit is contained in:
Dan Feltey
GitHub
parent
15d0ccc2c0
commit
a0fdee59b4
|
|
@ -31,6 +31,7 @@ constraints.
|
|||
racket/contract/private/guts
|
||||
racket/contract/private/prop
|
||||
racket/contract/private/blame
|
||||
racket/contract/collapsible
|
||||
racket/contract/private/ds
|
||||
racket/contract/private/opt
|
||||
racket/contract/private/basic-opters
|
||||
|
|
@ -2012,14 +2013,15 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
pos-blame-party
|
||||
source-loc
|
||||
name-for-blame
|
||||
no-context)
|
||||
context-limit)
|
||||
#:grammar ([pos-blame-party (code:line)
|
||||
(code:line #:pos-source pos-source-expr)]
|
||||
[source-loc (code:line)
|
||||
(code:line #:srcloc srcloc-expr)]
|
||||
[name-for-blame (code:line)
|
||||
(code:line #:name-for-blame blame-id)]
|
||||
[name-for-blame (code:line)
|
||||
[name-for-blame
|
||||
(code:line)
|
||||
#:name-for-blame blame-id]
|
||||
[context-limit (code:line)
|
||||
(code:line #:context-limit limit-expr)])]{
|
||||
Defines @racket[id] to be @racket[orig-id], but with the contract
|
||||
@racket[contract-expr].
|
||||
|
|
@ -2133,6 +2135,10 @@ accepted by the third argument to @racket[datum->syntax].
|
|||
late-neg-proj
|
||||
(or/c #f (-> blame? (-> any/c any/c any/c)))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2161,6 +2167,10 @@ accepted by the third argument to @racket[datum->syntax].
|
|||
late-neg-proj
|
||||
(or/c #f (-> blame? (-> any/c any/c any/c)))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2189,6 +2199,10 @@ accepted by the third argument to @racket[datum->syntax].
|
|||
late-neg-proj
|
||||
(or/c #f (-> blame? (-> any/c any/c any/c)))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2213,7 +2227,7 @@ accepted by the third argument to @racket[datum->syntax].
|
|||
)]{
|
||||
|
||||
These functions build simple higher-order contracts, @tech{chaperone contracts},
|
||||
and @tech{flat contracts}, respectively. They both take the same set of three
|
||||
and @tech{flat contracts}, respectively. They all take the same set of three
|
||||
optional arguments: a name, a first-order predicate, and a blame-tracking projection.
|
||||
For @racket[make-flat-contract], see also @racket[flat-contract-with-explanation].
|
||||
|
||||
|
|
@ -2242,6 +2256,14 @@ The @racket[late-neg-proj] argument defines the behavior of applying
|
|||
contract), or signal a contract violation using @racket[raise-blame-error].
|
||||
The default is @racket[#f].
|
||||
|
||||
The @racket[collapsible-late-neg-proj] argument takes the place of the
|
||||
@racket[late-neg-proj] argument for contracts that support collapsing.
|
||||
If it is supplied, this argument accepts a @tech{blame object} that is
|
||||
missing one party. It must return two values. The first value must be
|
||||
a function that accepts both the value that is getting the contract and
|
||||
the name of the missing blame party, in that order. The second value should
|
||||
be a collapsible representation of the contract.
|
||||
|
||||
The projection @racket[proj] and @racket[val-first-proj] are older mechanisms for
|
||||
defining the behavior of applying the contract. The @racket[proj] argument
|
||||
is a curried function of two arguments: the first application accepts a blame
|
||||
|
|
@ -2322,7 +2344,8 @@ to determine if this is a contract that accepts only @racket[list?] values.
|
|||
]
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}
|
||||
#:changed "6.90.0.30" @list{Added the @racket[#:equivalent] argument.}]
|
||||
#:changed "6.90.0.30" @list{Added the @racket[#:equivalent] argument.}
|
||||
#:changed "7.1.0.10" @list{Added the @racket[#:collapsible-late-neg-projection] argument.}]
|
||||
}
|
||||
|
||||
@defproc[(build-compound-type-name [c/s any/c] ...) any]{
|
||||
|
|
@ -2562,7 +2585,6 @@ when @racket[context] is @racket[#f].
|
|||
an error message, if @racket[blame] is passed to @racket[raise-blame-error].
|
||||
}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(blame-positive [b blame?]) any/c]
|
||||
@defproc[(blame-negative [b blame?]) any/c]
|
||||
|
|
@ -2741,6 +2763,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
|
|||
late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2787,6 +2813,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
|
|||
late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2843,6 +2873,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
|
|||
late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
|
||||
#f]
|
||||
[#:collapsible-late-neg-projection
|
||||
collapsible-late-neg-proj
|
||||
(or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
|
||||
#f]
|
||||
[#:val-first-projection
|
||||
val-first-proj
|
||||
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
|
||||
|
|
@ -2901,6 +2935,10 @@ a contract. It is specified in terms of seven properties:
|
|||
defining the behavior of the contract (The @racket[get-projection]
|
||||
and @racket[val-first-proj] arguments also specify the projection,
|
||||
but using a different signature. They are here for backwards compatibility.);}
|
||||
@item{@racket[collapsible-late-neg-proj], similar to @racket[late-neg-proj]
|
||||
which produces a blame-tracking projection defining the behavior of the
|
||||
contract, this function additionally specifies the collapsible behavior
|
||||
of the contract;}
|
||||
@item{@racket[stronger], a predicate that determines whether this
|
||||
contract (passed in the first argument) is stronger than some other
|
||||
contract (passed in the second argument) and whose default always
|
||||
|
|
@ -2922,8 +2960,9 @@ a contract. It is specified in terms of seven properties:
|
|||
to determine if this contract accepts only @racket[list?]s.}
|
||||
]
|
||||
|
||||
At least one of the @racket[late-neg-proj], @racket[get-projection],
|
||||
@racket[val-first-proj], or @racket[get-first-order] must be non-@racket[#f].
|
||||
At least one of the @racket[late-neg-proj], @racket[collapsible-late-neg-proj],
|
||||
@racket[get-projection], @racket[val-first-proj], or @racket[get-first-order]
|
||||
must be non-@racket[#f].
|
||||
|
||||
These accessors are passed as (optional) keyword arguments to
|
||||
@racket[build-contract-property], and are applied to instances of the
|
||||
|
|
@ -2952,7 +2991,8 @@ arguments as @racket[build-contract-property]. The differences are:
|
|||
#:changed "6.1.1.4"
|
||||
@list{Allow @racket[generate] to return @racket[contract-random-generate-fail].}
|
||||
#:changed "6.90.0.30"
|
||||
@list{Added the @racket[#:equivalent] argument.}]
|
||||
@list{Added the @racket[#:equivalent] argument.}
|
||||
#:changed "7.1.0.10" @list{Added the @racket[#:collapsible-late-neg-projection] argument.}]
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
|
|
@ -3356,6 +3396,8 @@ and fix at some point, but have no concrete plans currently.
|
|||
Key used by continuation marks that are present during contract checking.
|
||||
The value of these marks are the @|blame-objects| that correspond to the contract
|
||||
currently being checked.
|
||||
|
||||
@history[#:added "6.4.0.4"]
|
||||
}
|
||||
|
||||
@defproc[(contract-custom-write-property-proc [c contract?]
|
||||
|
|
@ -3462,6 +3504,160 @@ add contracts to libraries that @racketmodname[racket/contract]
|
|||
uses to implement some of the more sophisticated
|
||||
parts of the contract system.
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section[#:tag "collapsible"]{Collapsible Contracts}
|
||||
@defmodule*/no-declare[(racket/contract/collapsible)]
|
||||
@declare-exporting-ctc[racket/contract/collapsible]
|
||||
@history[#:added "7.1.0.10"]
|
||||
|
||||
@deftech{Collapsible contracts} are an optimization in the contract system designed
|
||||
to avoid a particular pathological build up of contract wrappers on higher-order
|
||||
values. The @racket[vectorof], @racket[vector/c], and @racket[->] contract
|
||||
combinators support collapsing for vector contracts and function contracts for
|
||||
functions returning a single value.
|
||||
|
||||
@bold{Warning}: the features described in this section are experimental
|
||||
and may not be sufficient to implement new collapsible contracts. Implementing
|
||||
new collapsible contracts requires the use of unsafe chaperones and impersonators
|
||||
which are only supported for vector and procedure values. This documentation exists
|
||||
primarily to allow future maintenance of the @racket[racket/contract/collapsible] library/
|
||||
|
||||
@defproc[(get/build-collapsible-late-neg-projection [c contract?])
|
||||
(-> blame? (values (-> any/c any/c any/c) collapsible-contract?))]{
|
||||
Returns the @racket[_collapsible-late-neg] projection for @racket[c].
|
||||
|
||||
If @racket[c] does not have a @racket[_collapsible-late-neg] projection,
|
||||
then this function uses the original projection for it and constructs a leaf
|
||||
as its collapsible representation.
|
||||
}
|
||||
|
||||
@defthing[collapsible-contract-continuation-mark-key continuation-mark-key?]{
|
||||
Key used by continuation marks that are present during collapsible contract checking.
|
||||
The value of these marks are @racket[#t] if the current contract is collapsible.
|
||||
}
|
||||
|
||||
@defform[(with-collapsible-contract-continuation-mark body ...)]{
|
||||
Inserts a continuation mark that informs the contract profiler that the current contract
|
||||
is collapsible.
|
||||
}
|
||||
|
||||
@defthing[prop:collapsible-contract struct-type-property?]{
|
||||
Structures implementing this property are usable as collapsible contracts. The value
|
||||
associated with this property should be constructed by calling
|
||||
@racket[build-collapsible-contract-property].
|
||||
}
|
||||
|
||||
@defproc[(collapsible-contract? [v any/c]) boolean?]{
|
||||
A predicate recognizing structures with the @racket[prop:collapsible-contract] property.}
|
||||
|
||||
@defproc[(merge [new-cc collapsible-contract?]
|
||||
[new-neg any/c]
|
||||
[old-cc collapsible-contract?]
|
||||
[old-neg any/c])
|
||||
collapsible-contract?]{
|
||||
Combine two collapsible contracts into a single collapsible contract.
|
||||
The @racket[new-neg] and @racket[old-neg] arguments are expected to be
|
||||
blame parties similar to those passed to a @tech{late neg projection}.
|
||||
}
|
||||
|
||||
@defproc[(collapsible-guard [cc collapsible-contract?]
|
||||
[val any/c]
|
||||
[neg-party any/c])
|
||||
any/c]{
|
||||
Similar to a @tech{late neg projection}, this function guards the value @racket[val]
|
||||
with the collapsible contract @racket[cc].
|
||||
}
|
||||
|
||||
@defproc[(collapsible-contract-property? [v any/c]) boolean?]{
|
||||
This predicate indicates that a value can be used as the property for
|
||||
@racket[prop:collapsible-contract].
|
||||
}
|
||||
|
||||
@defproc[(build-collapsible-contract-property
|
||||
[#:try-merge try-merge
|
||||
(or/c #f
|
||||
(-> collapsible-contract?
|
||||
any/c
|
||||
collapsible-contract?
|
||||
any/c
|
||||
(or/c #f collapsible-contract?)))
|
||||
#f]
|
||||
[#:collapsible-guard collapsible-guard
|
||||
(-> collapsible-contract? any/c any/c any/c)
|
||||
(λ (cc v neg)
|
||||
(error
|
||||
"internal error: contract does not support `collapsible-guard`" ctc))])
|
||||
collapsible-contract-property?]{
|
||||
Constructs a @deftech{collapsible contract property} from a merging function and a guard.
|
||||
The @racket[try-merge] argument is similar to @racket[merge], but may return @racket[#f] instead
|
||||
of a collapsible contract and may be specialized to a particular collapsible contract.
|
||||
The @racket[collapsible-guard] argument should be specialized to the particular collapsible
|
||||
contract being implemented.
|
||||
}
|
||||
|
||||
@defstruct*[collapsible-ho/c
|
||||
([latest-blame blame?]
|
||||
[missing-party any/c]
|
||||
[latest-ctc contract?])]{
|
||||
A common parent structure for collapsible contracts for higher-order values.
|
||||
The @racket[latest-blame] field holds the blame object for the most recent
|
||||
contract attached. Similarly, the @racket[missing-party] filed holds the latest
|
||||
missing party passed to the contract. The @racket[latest-contract] field stores
|
||||
the most recent contract attached to the value.
|
||||
}
|
||||
|
||||
@defstruct*[collapsible-leaf/c
|
||||
([proj-list (listof (-> any/c any/c any/c))]
|
||||
[contract-list (listof contract?)]
|
||||
[blame-list (listof blame?)]
|
||||
[missing-party-list (listof any/c)])]{
|
||||
A structure representing the leaf nodes of a collapsible contract. The @racket[proj-list]
|
||||
field holds a list of partially applied @tech{late neg projections}. The @racket[contract-list],
|
||||
@racket[blame-list], and @racket[missing-party-list] fields hold a list of contracts,
|
||||
blame objects, and blame missing parties respectively.
|
||||
}
|
||||
|
||||
@deftogether[(@defthing[impersonator-prop:collapsible impersonator-property?]
|
||||
@defproc[(has-impersonator-prop:collapsible? [v any/c]) boolean?]
|
||||
@defproc[(get-impersonator-prop:collapsible [v any/c]) collapsible-property?])]{
|
||||
An impersonator property (and its accessors) that should be attached to chaperoned or impersonated
|
||||
values that are guarded with a collapsible contract.
|
||||
}
|
||||
|
||||
@defstruct*[collapsible-property ([c-c collapsible-contract?]
|
||||
[neg-party any/c]
|
||||
[ref (or/c #f impersonator?)])]{
|
||||
The parent struct of properties that should be attached to chaperones or impersonators
|
||||
of values protected with a collapsible contract. The @racket[c-c] field stores the collapsible
|
||||
contract that is or will in the future be attached to the the value. The @racket[neg-party] field
|
||||
stores the latest missing blame party passed to the contract on the value. The @racket[ref] field
|
||||
is mutable and stores a reference to the chaperone or impersonator to which this property is
|
||||
attached. This is necessary to determine whether an unknown chaperone has been attached to a value
|
||||
after it has been protected by a collapsible contract.
|
||||
}
|
||||
@defstruct*[(collapsible-count-property collapsible-property)
|
||||
([count natural-number/c]
|
||||
[prev (or/c collapsible-count-property? any/c)])]{
|
||||
This property is associated with the @racket[impersonator-prop:collapsible] property before
|
||||
the value completely enters the collapsible mode. These properties keep track of the number of
|
||||
contracts on a value in the @racket[_count] field, and hold a reference to the previous
|
||||
@deftech{count property} in the @racket[prev] field or the original value without a contract. This
|
||||
allows the contract system to traverse the chain of attached contracts and merge them into a single
|
||||
collapsible contract to protect the original value.
|
||||
}
|
||||
@defstruct*[(collapsible-wrapper-property collapsible-property)
|
||||
([checking-wrapper impersonator?])]{
|
||||
This property is used when a value is guarded by a collapsible contract. The
|
||||
@racket[checking-wrapper] field holds a chaperone or impersonator that dispatches to the
|
||||
collapsible contract stored in this property to perform any necessary contract checks. When
|
||||
the value receives another contract and merging happens, the checking wrapper will remain the
|
||||
same even though the specific collapsible contract attached to the value may change.
|
||||
}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
|
||||
@section{Legacy Contracts}
|
||||
|
||||
@defproc[(make-proj-contract [name any/c]
|
||||
|
|
|
|||
|
|
@ -5,14 +5,18 @@
|
|||
scribble/examples
|
||||
scribble/decode
|
||||
racket/contract
|
||||
racket/contract/collapsible
|
||||
"../icons.rkt")
|
||||
|
||||
(provide (all-from-out scribble/manual)
|
||||
(all-from-out scribble/examples)
|
||||
(all-from-out racket/contract))
|
||||
(all-from-out racket/contract)
|
||||
(all-from-out racket/contract/collapsible))
|
||||
|
||||
(require (for-label racket))
|
||||
(provide (for-label (all-from-out racket)))
|
||||
(require (for-label racket/contract/collapsible))
|
||||
(provide (for-label (all-from-out racket/contract/collapsible)))
|
||||
|
||||
(provide mz-examples)
|
||||
(define mz-eval (make-base-eval))
|
||||
|
|
|
|||
|
|
@ -800,7 +800,21 @@
|
|||
'neg))
|
||||
x)
|
||||
'(body ctc)
|
||||
'(body ctc ctc)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore2-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(contract
|
||||
(->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(body ctc ctc)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore3
|
||||
|
|
@ -811,7 +825,21 @@
|
|||
'neg))
|
||||
x)
|
||||
'(ctc body)
|
||||
'(ctc ctc body)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore3-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(contract
|
||||
(->d () () [res (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(ctc ctc body)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore4
|
||||
|
|
|
|||
|
|
@ -750,18 +750,48 @@
|
|||
b)
|
||||
(unbox b))
|
||||
'(5 4 3 2 1)
|
||||
'(5 4 5 4 3 2 1 2 1)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i44
|
||||
'((contract (->i ([x () any/c])
|
||||
[y any/c]
|
||||
#:post (x) x)
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#t)
|
||||
'#t)
|
||||
'->i43-double-wrap
|
||||
'(let ([b (box '())])
|
||||
((contract (->i ([i (box/c (listof integer?))])
|
||||
(values [_ (i)
|
||||
(begin
|
||||
(set-box! i (cons 1 (unbox i)))
|
||||
(λ (x)
|
||||
(set-box! i (cons 4 (unbox i)))
|
||||
#t))]
|
||||
[_ (i)
|
||||
(begin
|
||||
(set-box! i (cons 2 (unbox i)))
|
||||
(λ (x)
|
||||
(set-box! i (cons 5 (unbox i)))
|
||||
#t))]))
|
||||
(contract
|
||||
(->i ([i (box/c (listof integer?))])
|
||||
(values [_ (i)
|
||||
(begin
|
||||
(set-box! i (cons 1 (unbox i)))
|
||||
(λ (x)
|
||||
(set-box! i (cons 4 (unbox i)))
|
||||
#t))]
|
||||
[_ (i)
|
||||
(begin
|
||||
(set-box! i (cons 2 (unbox i)))
|
||||
(λ (x)
|
||||
(set-box! i (cons 5 (unbox i)))
|
||||
#t))]))
|
||||
(λ (i)
|
||||
(set-box! i (cons 3 (unbox i)))
|
||||
(values 2 2))
|
||||
'pos 'neg)
|
||||
(quote pos)
|
||||
(quote neg))
|
||||
b)
|
||||
(unbox b))
|
||||
'(5 4 5 4 3 2 1 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/pos-blame
|
||||
'->i45
|
||||
|
|
@ -875,7 +905,31 @@
|
|||
1)
|
||||
x)
|
||||
'(res-check res-eval body arg-eval)
|
||||
'(res-check res-eval res-check res-eval body arg-eval arg-eval)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i48-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[res () (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(contract
|
||||
(->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[res () (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(λ (arg)
|
||||
(set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
x)
|
||||
'(res-check res-eval res-check res-eval body arg-eval arg-eval)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i49
|
||||
|
|
@ -892,8 +946,32 @@
|
|||
1)
|
||||
x)
|
||||
'(res-check body res-eval arg-eval)
|
||||
'(res-check res-check body res-eval res-eval arg-eval arg-eval)) ; result if contract is applied twice
|
||||
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i49-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[_ () (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(contract
|
||||
(->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[_ () (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(λ (arg)
|
||||
(set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
x)
|
||||
'(res-check res-check body res-eval res-eval arg-eval arg-eval)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i50
|
||||
'(let ([x '()])
|
||||
|
|
@ -909,7 +987,31 @@
|
|||
1)
|
||||
x)
|
||||
'(res-check body res-eval arg-eval)
|
||||
'(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i50-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[res (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(contract
|
||||
(->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[res (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(λ (arg)
|
||||
(set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
x)
|
||||
'(res-check res-check body res-eval arg-eval res-eval arg-eval)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i51
|
||||
|
|
@ -926,7 +1028,31 @@
|
|||
1)
|
||||
x)
|
||||
'(res-check body res-eval arg-eval)
|
||||
'(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i51-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[_ (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(contract
|
||||
(->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
|
||||
[_ (begin
|
||||
(set! x (cons 'res-eval x))
|
||||
(λ (res)
|
||||
(set! x (cons 'res-check x))))])
|
||||
(λ (arg)
|
||||
(set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
x)
|
||||
'(res-check res-check body res-eval arg-eval res-eval arg-eval)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i52
|
||||
|
|
@ -965,9 +1091,25 @@
|
|||
1 2)
|
||||
b)
|
||||
'(3 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
;; this is probably right (but not what we really really want, of course)
|
||||
'(3 2 1 2 1))
|
||||
(test/spec-passed/result
|
||||
'->i55-double-wrap
|
||||
'(let ([b '()])
|
||||
((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
|
||||
[z (y) (begin (set! b (cons 2 b)) any/c)])
|
||||
any)
|
||||
(contract
|
||||
(->i ([y () (begin (set! b (cons 1 b)) any/c)]
|
||||
[z (y) (begin (set! b (cons 2 b)) any/c)])
|
||||
any)
|
||||
(λ args (set! b (cons 3 b)) 0)
|
||||
'pos 'neg)
|
||||
'pos 'neg)
|
||||
1 2)
|
||||
b)
|
||||
'(3 2 1 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i56
|
||||
|
|
@ -982,9 +1124,29 @@
|
|||
1 2)
|
||||
b)
|
||||
'(5 4 3 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
;; this is probably right (but not what we really really want, of course)
|
||||
'(5 4 5 4 3 2 1 2 1))
|
||||
(test/spec-passed/result
|
||||
'->i56-double-wrap
|
||||
'(let ([b '()])
|
||||
((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
|
||||
[z (y) (begin (set! b (cons 2 b)) any/c)])
|
||||
(values
|
||||
[a () (begin (set! b (cons 4 b)) any/c)]
|
||||
[b (a) (begin (set! b (cons 5 b)) any/c)]))
|
||||
(contract
|
||||
(->i ([y () (begin (set! b (cons 1 b)) any/c)]
|
||||
[z (y) (begin (set! b (cons 2 b)) any/c)])
|
||||
(values
|
||||
[a () (begin (set! b (cons 4 b)) any/c)]
|
||||
[b (a) (begin (set! b (cons 5 b)) any/c)]))
|
||||
(λ args (set! b (cons 3 b)) (values 0 0))
|
||||
'pos 'neg)
|
||||
'pos 'neg)
|
||||
1 2)
|
||||
b)
|
||||
'(5 4 5 4 3 2 1 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i57
|
||||
|
|
@ -1003,9 +1165,37 @@
|
|||
1 2)
|
||||
b)
|
||||
'(9 8 7 6 5 4 3 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
;; this is probably right (but not what we really really want, of course)
|
||||
'(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1))
|
||||
(test/spec-passed/result
|
||||
'->i57-double-wrap
|
||||
'(let ([b '()])
|
||||
((contract (->i ([y () (begin (set! b (cons 1 b))
|
||||
(λ (y) (set! b (cons 2 b)) #t))]
|
||||
[z (y) (begin (set! b (cons 3 b))
|
||||
(λ (y) (set! b (cons 4 b)) #t))])
|
||||
(values
|
||||
[a () (begin (set! b (cons 6 b))
|
||||
(λ (a) (set! b (cons 7 b)) #t))]
|
||||
[b (a) (begin (set! b (cons 8 b))
|
||||
(λ (a) (set! b (cons 9 b)) #t))]))
|
||||
(contract
|
||||
(->i ([y () (begin (set! b (cons 1 b))
|
||||
(λ (y) (set! b (cons 2 b)) #t))]
|
||||
[z (y) (begin (set! b (cons 3 b))
|
||||
(λ (y) (set! b (cons 4 b)) #t))])
|
||||
(values
|
||||
[a () (begin (set! b (cons 6 b))
|
||||
(λ (a) (set! b (cons 7 b)) #t))]
|
||||
[b (a) (begin (set! b (cons 8 b))
|
||||
(λ (a) (set! b (cons 9 b)) #t))]))
|
||||
(λ args (set! b (cons 5 b)) (values 0 0))
|
||||
'pos 'neg)
|
||||
'pos 'neg)
|
||||
1 2)
|
||||
b)
|
||||
'(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i58
|
||||
|
|
@ -1028,7 +1218,26 @@
|
|||
'pos 'neg))
|
||||
b)
|
||||
'(3 2 1)
|
||||
'(3 2 1 2 1))
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i59-double-wrap
|
||||
'(let ([b '()])
|
||||
((contract (->i ()
|
||||
([x (begin (set! b (cons 1 b)) integer?)]
|
||||
[y (x) (begin (set! b (cons 'nope b)) (>=/c x))])
|
||||
[result (begin (set! b (cons 2 b)) any/c)])
|
||||
(contract
|
||||
(->i ()
|
||||
([x (begin (set! b (cons 1 b)) integer?)]
|
||||
[y (x) (begin (set! b (cons 'nope b)) (>=/c x))])
|
||||
[result (begin (set! b (cons 2 b)) any/c)])
|
||||
(λ ([x #f] [y #f]) (set! b (cons 3 b)) 0)
|
||||
'pos 'neg)
|
||||
'pos 'neg))
|
||||
b)
|
||||
'(3 2 1 2 1)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/pos-blame
|
||||
'->i-arity1
|
||||
|
|
@ -1448,7 +1657,21 @@
|
|||
'neg))
|
||||
x)
|
||||
'(body ctc)
|
||||
'(body ctc ctc)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i-underscore2-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i () () [_ (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(contract
|
||||
(->i () () [_ (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(body ctc ctc)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i-underscore3
|
||||
|
|
@ -1459,7 +1682,21 @@
|
|||
'neg))
|
||||
x)
|
||||
'(body ctc)
|
||||
'(body ctc ctc)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i-underscore3-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i () () [res (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(contract
|
||||
(->i () () [res (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(body ctc ctc)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i-underscore4
|
||||
|
|
@ -1487,7 +1724,22 @@
|
|||
11)
|
||||
x)
|
||||
'(body ctc)
|
||||
'(body ctc ctc)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'->i-underscore6-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(contract
|
||||
(->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ (a) (set! x (cons 'body x)))
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
11)
|
||||
x)
|
||||
'(body ctc ctc)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/pos-blame
|
||||
'->i-bad-number-of-result-values1
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
|
||||
(parameterize ([current-contract-namespace
|
||||
(make-basic-contract-namespace 'racket/contract
|
||||
'racket/contract/private/blame)])
|
||||
'racket/contract/private/blame
|
||||
'syntax/srcloc)])
|
||||
|
||||
(test/spec-passed/result
|
||||
'blame-selector.1
|
||||
|
|
@ -371,6 +372,16 @@
|
|||
'(has-complete-blame? (contract (vectorof integer?) (vector 1 2 3) 'pos 'neg))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'complete-prop-blame-vector/c
|
||||
'(let* ([ctc (vector/c (-> integer? integer?))]
|
||||
[v (contract
|
||||
ctc
|
||||
(contract ctc (vector add1) 'inner-pos 'inner-neg)
|
||||
'pos 'neg)])
|
||||
(has-complete-blame? (vector-ref v 0)))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'blame-selectors
|
||||
'(let ()
|
||||
|
|
@ -394,10 +405,12 @@
|
|||
(λ (val np)
|
||||
val)))
|
||||
'whatevs
|
||||
'pos 'neg)
|
||||
'pos 'neg
|
||||
'there-is-no-name
|
||||
(build-source-location #f))
|
||||
(list source pos neg ctc val orig? swapped?))
|
||||
(list (srcloc #f #f #f #f #f)
|
||||
'pos #f 'blame-selector-helper #f #t #f))
|
||||
'pos #f 'blame-selector-helper 'there-is-no-name #t #f))
|
||||
|
||||
(test/spec-passed/result
|
||||
'swapped-blame-selectors
|
||||
|
|
@ -425,10 +438,12 @@
|
|||
any))
|
||||
(contract the-ctc
|
||||
(λ (x) 'whatevs)
|
||||
'pos 'neg)
|
||||
'pos 'neg
|
||||
'there-is-no-name
|
||||
(build-source-location #f))
|
||||
(list source pos neg ctc val orig? swapped?))
|
||||
(list (srcloc #f #f #f #f #f)
|
||||
#f 'pos '(-> blame-selector-helper any) #f #f #t))
|
||||
#f 'pos '(-> blame-selector-helper any) 'there-is-no-name #f #t))
|
||||
|
||||
(test/spec-passed/result
|
||||
'blame-equality
|
||||
|
|
|
|||
929
pkgs/racket-test/tests/racket/contract/collapsible-arrow.rkt
Normal file
929
pkgs/racket-test/tests/racket/contract/collapsible-arrow.rkt
Normal file
|
|
@ -0,0 +1,929 @@
|
|||
#lang racket/base
|
||||
(require "test-util.rkt")
|
||||
|
||||
(parameterize ([current-contract-namespace
|
||||
(make-basic-contract-namespace
|
||||
'racket/contract)])
|
||||
|
||||
(contract-eval
|
||||
'(define (add-many-contracts n ctc val [pos 'pos] [neg 'neg])
|
||||
(for/fold ([val val])
|
||||
([i (in-range n)])
|
||||
(contract ctc val pos neg))))
|
||||
|
||||
(contract-eval '(define ctc (-> (-> integer? integer?) (-> integer? integer?))))
|
||||
(contract-eval '(define (wrap x) (add-many-contracts 11 ctc x 'pos 'neg)))
|
||||
(contract-eval '(define id (wrap (wrap (lambda (x) x)))))
|
||||
|
||||
(test/spec-passed
|
||||
'collapsible1
|
||||
'(id add1))
|
||||
(test/spec-passed
|
||||
'collapsible2
|
||||
'((id add1) 1))
|
||||
(test/spec-failed
|
||||
'collapsible3
|
||||
'((id add1) 'a)
|
||||
'neg)
|
||||
(test/spec-passed
|
||||
'collapsible4
|
||||
'(((wrap id) add1) 1))
|
||||
(test/spec-failed
|
||||
'collapsible5
|
||||
'(((wrap id) add1) 'a)
|
||||
'neg)
|
||||
(test/spec-passed
|
||||
'collapsible6
|
||||
'(((wrap (wrap (wrap (wrap (wrap (wrap (wrap (wrap (wrap id))))))))) add1) 1))
|
||||
(test/spec-failed
|
||||
'collapsible7
|
||||
'(wrap 3)
|
||||
'pos)
|
||||
|
||||
;; works with non-flat contracts at the leaves
|
||||
(test/spec-passed
|
||||
'collapsible8
|
||||
'(let ([ctc (-> (vector/c integer?) (vector/c integer?))])
|
||||
(vector-ref ((contract ctc
|
||||
(add-many-contracts 11 ctc
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
(vector 1))
|
||||
0)))
|
||||
(test/spec-failed
|
||||
'collapsible9
|
||||
'(vector-ref ((contract ctc
|
||||
(add-many-contracts 11 ctc
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
(vector 'a))
|
||||
0)
|
||||
'neg)
|
||||
(test/spec-failed
|
||||
'collapsible10
|
||||
'(let ([ctc (-> any/c (-> integer? integer?))])
|
||||
(vector-ref ((contract ctc
|
||||
(add-many-contracts 11 ctc
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
(vector 'a))
|
||||
0))
|
||||
"inner-pos")
|
||||
|
||||
(contract-eval '(require (submod racket/contract/private/arrow-collapsible for-testing)))
|
||||
(contract-eval '(require (submod racket/contract/private/collapsible-common for-testing)))
|
||||
(contract-eval
|
||||
'(define (has-num-contracts? f dom rng)
|
||||
(unless (has-impersonator-prop:collapsible? f)
|
||||
(error "has-num-contracts?: no collapsible contract"))
|
||||
(define collapsible/c (collapsible-property-c-c (get-impersonator-prop:collapsible f)))
|
||||
(define domain/c (car (collapsible->-doms collapsible/c)))
|
||||
(define range/c (collapsible->-rng collapsible/c))
|
||||
(unless (= (length (collapsible-leaf/c-proj-list domain/c)) dom)
|
||||
(error "has-num-contracts?: wrong number of domain projections"))
|
||||
(unless (= (length (collapsible-leaf/c-proj-list range/c)) rng)
|
||||
(error "has-num-contracts?: wrong number of range projections"))
|
||||
(unless (= (length (collapsible-leaf/c-contract-list domain/c)) dom)
|
||||
(error "has-num-contracts?: wrong num of domain contracts"))
|
||||
(unless (= (length (collapsible-leaf/c-contract-list range/c)) rng)
|
||||
(error "has-num-contracts?: wrong num of range contracts"))))
|
||||
(contract-eval '(define (collapsible? val)
|
||||
(and (has-impersonator-prop:collapsible? val)
|
||||
(let ([prop (get-impersonator-prop:collapsible val #f)])
|
||||
(and (collapsible-wrapper-property? prop)
|
||||
(eq? val (collapsible-property-ref prop)))))))
|
||||
|
||||
(contract-eval '(define pos (flat-named-contract
|
||||
'pos
|
||||
(lambda (x) (and (integer? x) (>= x 0))))))
|
||||
(contract-eval '(define pos->pos (-> pos pos)))
|
||||
(contract-eval '(define pos->pos->pos (-> pos->pos pos)))
|
||||
|
||||
(contract-eval
|
||||
'(define guarded
|
||||
(add-many-contracts 11 pos->pos (lambda (x) (* x -2)) 'positive 'negative)))
|
||||
(contract-eval
|
||||
'(define f1 (add-many-contracts 11 pos->pos->pos
|
||||
(flat-named-contract
|
||||
'c
|
||||
(lambda (f)
|
||||
(unless (has-contract? f)
|
||||
(error "f1 should already be contracted"))
|
||||
;; Check that the already contracted function only
|
||||
;; has one contract
|
||||
(has-num-contracts? f 1 1)
|
||||
(f 1)))
|
||||
'pos 'neg)))
|
||||
(contract-eval
|
||||
'(define f2 (add-many-contracts 11 pos->pos->pos
|
||||
(lambda (f)
|
||||
(unless (has-contract? f)
|
||||
(error "f2 should already be contracted"))
|
||||
;; Check that the already contracted function only
|
||||
;; has one contract
|
||||
(has-num-contracts? f 1 1)
|
||||
(f -1))
|
||||
'pos 'neg)))
|
||||
|
||||
(test/spec-failed
|
||||
'collapsible11
|
||||
'(f1 guarded)
|
||||
"positive")
|
||||
(test/spec-failed
|
||||
'collapsible12
|
||||
'(f2 guarded)
|
||||
'pos)
|
||||
;; check whether it has a contract (but not a collapsible wrapper)
|
||||
(test-false
|
||||
'collapsible12.5
|
||||
'(collapsible->? (value-contract guarded)))
|
||||
;; checking normal blame
|
||||
(test/spec-failed
|
||||
'collapsible13
|
||||
'(guarded -34)
|
||||
"negative")
|
||||
(test/spec-failed
|
||||
'collapsible14
|
||||
'(guarded 34)
|
||||
"positive")
|
||||
|
||||
(contract-eval
|
||||
'(define guarded-twice (add-many-contracts 11 pos->pos guarded 'positive2 'negative2)))
|
||||
;; Reapplying the same contract over the already contracted function
|
||||
(test-true
|
||||
'collapsible14.5
|
||||
'(has-contract? guarded-twice))
|
||||
;; Outer wrapper should be applied first for the domain
|
||||
(test/spec-failed
|
||||
'collapsible15
|
||||
'(guarded-twice -34)
|
||||
"negative2")
|
||||
;; Inner wrapper should be applied first for the range
|
||||
(test/spec-failed
|
||||
'collapsible16
|
||||
'(guarded-twice 34)
|
||||
"positive")
|
||||
;; Get the domain and range contract from the twice contracted function
|
||||
(test/spec-passed
|
||||
'collapsible16.1
|
||||
'(has-num-contracts? guarded-twice 1 1))
|
||||
(test-true
|
||||
'collapsible16.5
|
||||
'(collapsible? guarded-twice))
|
||||
|
||||
(contract-eval
|
||||
'(define (contract-times f c n)
|
||||
(if (= n 0)
|
||||
f
|
||||
(contract-times (contract c f 'positive 'negative) c (- n 1)))))
|
||||
|
||||
(test/spec-passed
|
||||
'arrow-false-contracts
|
||||
'(let* ([f (lambda (x) x)]
|
||||
[ctc (-> #f #f)] ;; defeat opt/c rewriting
|
||||
[cf1 (add-many-contracts 11 ctc f 'pos 'neg)]
|
||||
[cf2 (contract ctc cf1 'pos 'neg)]
|
||||
[cf3 (contract ctc cf2 'pos 'neg)]
|
||||
[cf4 (contract ctc cf3 'pos 'neg)])
|
||||
(has-num-contracts? cf4 1 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'arrow-many-false-contracts
|
||||
'(let ([ctc (-> #f #f)])
|
||||
(has-num-contracts? (contract-times (lambda (x) x) ctc 1000) 1 1)))
|
||||
|
||||
;; Apply the contract 1000 times
|
||||
(contract-eval
|
||||
'(define insanely-contracted (contract-times guarded-twice pos->pos 1000)))
|
||||
(test/spec-passed
|
||||
'collapsible-wrap0
|
||||
'(has-num-contracts? insanely-contracted 1 1))
|
||||
;; not actually doubly-wrapped
|
||||
|
||||
(contract-eval
|
||||
'(define (double-wrapped? x)
|
||||
(define prop (get-impersonator-prop:collapsible x #f))
|
||||
(and
|
||||
(collapsible-wrapper-property? prop)
|
||||
(and (has-impersonator-prop:collapsible?
|
||||
(collapsible-wrapper-property-checking-wrapper prop))
|
||||
;; this is annoying because of how unsafe-chaperones ...
|
||||
;; work in relation to impersonator-properties
|
||||
(collapsible-wrapper-property?
|
||||
(get-impersonator-prop:collapsible
|
||||
(collapsible-wrapper-property-checking-wrapper prop)
|
||||
#f))))))
|
||||
|
||||
(test-false
|
||||
'collapsible-wrap1
|
||||
'(double-wrapped? insanely-contracted))
|
||||
(test-true
|
||||
'collapsible-wrap2
|
||||
'(collapsible? insanely-contracted))
|
||||
|
||||
(test-false
|
||||
'collapsible-wrap3
|
||||
'(double-wrapped? (id add1)))
|
||||
(test-true
|
||||
'collapsible-wrap4
|
||||
'(collapsible? (id add1)))
|
||||
(test-false
|
||||
'collapsible-wrap5
|
||||
'(double-wrapped? (id (id add1))))
|
||||
(test-true
|
||||
'collapsible-wrap6
|
||||
'(collapsible? (id (id add1))))
|
||||
(test-false
|
||||
'collapsible-wrap7
|
||||
'(double-wrapped? (id (id (id add1)))))
|
||||
(test-true
|
||||
'collapsible-wrap7
|
||||
'(collapsible? (id (id (id add1)))))
|
||||
|
||||
;; test relying on contract-stronger?
|
||||
(contract-eval '(define r-i (contract (-> integer? any/c)
|
||||
(add-many-contracts 11 (-> integer? integer?)
|
||||
add1
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define r-i2 (contract (-> integer? any/c)
|
||||
(add-many-contracts 11 (-> integer? integer?)
|
||||
(lambda (x) 'a)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(test/spec-passed
|
||||
'collapsible-stronger-num1
|
||||
'(has-num-contracts? r-i 1 1))
|
||||
(test-true
|
||||
'collapsible-stronger1
|
||||
'(collapsible? r-i))
|
||||
(test/spec-passed
|
||||
'collapsible-stronger-num2
|
||||
'(has-num-contracts? r-i2 1 1))
|
||||
(test-true
|
||||
'collapsible-stronger2
|
||||
'(collapsible? r-i2))
|
||||
(test/spec-passed
|
||||
'collapsible17
|
||||
'(r-i 1))
|
||||
(test/spec-failed
|
||||
'collapsible18
|
||||
'(r-i 'a)
|
||||
'neg)
|
||||
(test/spec-failed
|
||||
'collapsible19
|
||||
'(r-i2 1)
|
||||
"inner-pos")
|
||||
(contract-eval '(define i-r (contract (-> integer? integer?)
|
||||
(add-many-contracts 11 (-> integer? any/c)
|
||||
add1
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define i-r2 (contract (-> integer? integer?)
|
||||
(add-many-contracts 11 (-> integer? any/c)
|
||||
(lambda (x) 'a)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
;; can't collapse those. any/c must still be checked before integer? on the
|
||||
;; way out, otherwise may blame wrong
|
||||
(test/spec-passed
|
||||
'collapsible-stronger-num3
|
||||
'(has-num-contracts? i-r 1 2))
|
||||
(test/spec-passed
|
||||
'collapsible-stronger-num4
|
||||
'(has-num-contracts? i-r2 1 2))
|
||||
(test-true
|
||||
'collapsible-stronger3
|
||||
'(collapsible? i-r))
|
||||
(test-true
|
||||
'collapsible-stronger4
|
||||
'(collapsible? i-r2))
|
||||
(test/spec-passed
|
||||
'collapsible20
|
||||
'(i-r 1))
|
||||
(test/spec-failed
|
||||
'collapsible21
|
||||
'(i-r 'a)
|
||||
'neg)
|
||||
(test/spec-failed
|
||||
'collapsible22
|
||||
'(i-r2 1)
|
||||
'pos)
|
||||
|
||||
;; test mixing chaperone and impersonator contracts
|
||||
(contract-eval
|
||||
'(define c1 ; this is an impersonator contract
|
||||
(make-contract
|
||||
#:name 'c1
|
||||
#:val-first-projection
|
||||
(lambda (blame)
|
||||
(lambda (x)
|
||||
(lambda (neg-party)
|
||||
(unless (integer? x)
|
||||
(raise-blame-error (blame-add-missing-party blame neg-party) x "eh"))
|
||||
(add1 x))))))) ; does not respect the chaperone property
|
||||
(contract-eval
|
||||
'(define c2 ; this is an chaperone contract
|
||||
(make-chaperone-contract
|
||||
#:name 'c2
|
||||
#:val-first-projection
|
||||
(lambda (blame)
|
||||
(lambda (x)
|
||||
(lambda (neg-party)
|
||||
(unless (integer? x)
|
||||
(raise-blame-error (blame-add-missing-party blame neg-party) x "eh"))
|
||||
x))))))
|
||||
(contract-eval
|
||||
'(define (can-combine? val ctc)
|
||||
(define cv (contract ctc val 'p 'n))
|
||||
(and (collapsible? val)
|
||||
(collapsible? cv))))
|
||||
|
||||
(contract-eval '(define ic
|
||||
(contract (-> (-> c1 c1) (-> c1 c1))
|
||||
(add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define iic
|
||||
(add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
|
||||
ic
|
||||
'outer-pos 'outer-neg)))
|
||||
|
||||
(contract-eval
|
||||
'(define imp-add1
|
||||
(impersonate-procedure add1 (lambda (x) x))))
|
||||
(contract-eval
|
||||
'(define chap-add1
|
||||
(chaperone-procedure add1 (lambda (x) x))))
|
||||
|
||||
(test-true
|
||||
'collapsible-imps-on-underlying-chap
|
||||
'(collapsible? (add-many-contracts 11 (-> c1 c1) chap-add1)))
|
||||
(test-true
|
||||
'collapsible-chaps-on-underlying-chap
|
||||
'(collapsible? (add-many-contracts 11 (-> c2 c2) chap-add1)))
|
||||
(test-true
|
||||
'collapsible-imps-on-underlying-imp
|
||||
'(collapsible? (add-many-contracts 11 (-> c1 c1) imp-add1)))
|
||||
(test-true
|
||||
'collapsible-chaps-on-underlying-imp
|
||||
'(collapsible? (add-many-contracts 11 (-> c2 c2) imp-add1)))
|
||||
|
||||
(test-false
|
||||
'collapsible-chap+imp1
|
||||
'(can-combine? ic (-> c1 c1))) ; can collapse impersonators, the inner chaperone is not chaperone*
|
||||
(test-false
|
||||
'collapsible-chap+imp2
|
||||
'(can-combine? ic (-> c2 c2)))
|
||||
(test-false
|
||||
'collapsible-chap+imp3
|
||||
'(can-combine? iic (-> c1 c1))) ; see above
|
||||
(test-false
|
||||
'collapsible-chap+imp4
|
||||
'(can-combine? iic (-> c2 c2)))
|
||||
(test/spec-passed
|
||||
'collapsible23
|
||||
'((iic add1) 1))
|
||||
|
||||
(contract-eval '(define cc
|
||||
(contract (-> (-> c2 c2) (-> c2 c2))
|
||||
(add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define icc
|
||||
(add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
|
||||
cc
|
||||
'outer-pos 'outer-neg)))
|
||||
(test-true
|
||||
'collapsible-chap+imp5
|
||||
'(collapsible? cc))
|
||||
(test-false
|
||||
'collapsible-chap+imp6
|
||||
'(can-combine? cc (-> c1 c1)))
|
||||
(test-true
|
||||
'collapsible-chap+imp7
|
||||
'(can-combine? cc (-> c2 c2)))
|
||||
(test-false
|
||||
'collapsible-chap+imp8
|
||||
'(can-combine? icc (-> c1 c1)))
|
||||
(test-false
|
||||
'collapsible-chap+imp9
|
||||
'(can-combine? icc (-> c2 c2)))
|
||||
(test/spec-passed
|
||||
'collapsible24
|
||||
'((icc add1) 1))
|
||||
|
||||
(contract-eval '(define ci (contract (-> (-> c2 c2) (-> c2 c2))
|
||||
(add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define ici (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
|
||||
ci
|
||||
'outer-pos 'outer-neg)))
|
||||
(test-false
|
||||
'collapsible-chap+imp10
|
||||
'(can-combine? ci (-> c1 c1)))
|
||||
(test-false
|
||||
'collapsible-chap+imp11
|
||||
'(can-combine? ci (-> c2 c2))) ; it's impersonated before the `cc`, but not impersonator*, sook
|
||||
(test-false
|
||||
'collapsible-chap+imp12
|
||||
'(can-combine? ici (-> c1 c1))) ; ditto
|
||||
(test-false
|
||||
'collapsible-chap+imp13
|
||||
'(can-combine? ici (-> c2 c2)))
|
||||
(test/spec-passed
|
||||
'collapsible25
|
||||
'((ici add1) 1))
|
||||
|
||||
(test/spec-passed
|
||||
'collapsible25.5
|
||||
;; using `contract` explicitly, to trigger double-wrapping rewrite
|
||||
;; (that changed something! (but it shouldn't, so it's a bug!))
|
||||
'(((contract (-> (-> c1 c1) (-> c1 c1))
|
||||
(contract (-> (-> c2 c2) (-> c2 c2))
|
||||
(add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
'outer-pos 'outer-neg)
|
||||
add1)
|
||||
1))
|
||||
|
||||
(contract-eval '(define cic
|
||||
(add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
|
||||
ci
|
||||
'outer-pos 'outer-neg)))
|
||||
(test-false
|
||||
'collapsible-chap+imp14
|
||||
'(can-combine? cic (-> c1 c1)))
|
||||
(test-false
|
||||
'collapsible-chap+imp15
|
||||
'(can-combine? cic (-> c2 c2)))
|
||||
(test/spec-passed
|
||||
'collapsible26
|
||||
'((cic add1) 1))
|
||||
|
||||
;; can we get collapsible wrappers for impersonator contracts?
|
||||
(contract-eval
|
||||
'(define imp-imp (contract (-> c1 c1)
|
||||
(add-many-contracts 11 (-> c1 c1) (lambda (x) x) 'pos 'neg)
|
||||
'pos 'neg)))
|
||||
(test-true
|
||||
'collapsible-imp1
|
||||
'(collapsible? imp-imp))
|
||||
(test/spec-passed
|
||||
'collapsible27
|
||||
'(imp-imp 1))
|
||||
(test/spec-failed
|
||||
'collapsible27f
|
||||
'(imp-imp 'a)
|
||||
'neg)
|
||||
;; should be an impersonator contract
|
||||
(test-false
|
||||
'collapsible-imp2
|
||||
'(chaperone-contract? (value-contract imp-imp)))
|
||||
|
||||
|
||||
(contract-eval '(define mix1 (contract (-> any/c any/c)
|
||||
(add-many-contracts 11 (-> (-> integer? integer?)
|
||||
(-> integer? integer?))
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'pos 'neg)))
|
||||
(contract-eval '(define mix2 (contract (-> (-> integer? integer?)
|
||||
(-> integer? integer?))
|
||||
(add-many-contracts 11 (-> any/c any/c)
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'pos 'neg)))
|
||||
(test-true
|
||||
'collapsible-flat-h/o-mix1
|
||||
'(collapsible? mix1))
|
||||
(test/spec-passed
|
||||
'collapsible-flat-h/o-mix2
|
||||
'((mix1 add1) 2))
|
||||
(test-true
|
||||
'collapsible-flat-h/o-mix3
|
||||
'(collapsible? mix2))
|
||||
(test/spec-passed
|
||||
'collapsible-flat-h/o-mix5
|
||||
'((mix2 add1) 2))
|
||||
(test/neg-blame
|
||||
'collapsible-flat-h/o-mix6
|
||||
'((mix1 add1) 'a))
|
||||
(test/neg-blame
|
||||
'collapsible-flat-h/o-mix7
|
||||
'((mix1 number->string) 2))
|
||||
(test/neg-blame
|
||||
'collapsible-flat-h/o-mix8
|
||||
'((mix2 add1) 'a))
|
||||
(test/neg-blame
|
||||
'collapsible-flat-h/o-mix9
|
||||
'((mix2 number->string) 2))
|
||||
|
||||
;; only the outer contract matters for these tests, as the inner one is fully
|
||||
;; checked before we enter collapsible mode
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks1
|
||||
'(contract (-> any/c)
|
||||
(add-many-contracts 11 (-> any/c any/c) add1 'inner-pos 'inner-neg)
|
||||
'pos 'neg))
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks2
|
||||
'((contract (-> (-> any/c))
|
||||
(add-many-contracts 11 (-> (-> any/c any/c))
|
||||
(lambda () add1)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks3
|
||||
'((contract (-> (-> any/c any/c))
|
||||
(add-many-contracts 11 (-> (-> any/c))
|
||||
(lambda () add1)
|
||||
'pos 'neg)
|
||||
'outer-pos 'outer-neg)))
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks4
|
||||
'((contract (-> (-> any/c any/c))
|
||||
(contract (-> (-> any/c))
|
||||
(add-many-contracts 11 (-> (-> any/c any/c any/c))
|
||||
(lambda () add1)
|
||||
'pos 'neg)
|
||||
'mid-pos 'mid-neg)
|
||||
'outer-pos 'outer-neg)))
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks5
|
||||
'((contract (-> (-> any/c any/c))
|
||||
(contract (-> (-> any/c))
|
||||
(add-many-contracts 11 (-> (-> any/c any/c any/c))
|
||||
(contract (-> (-> any/c any/c)) ; to have next one be collapsible
|
||||
(lambda () add1)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
'mid-pos 'mid-neg)
|
||||
'outer-pos 'outer-neg)))
|
||||
(test/pos-blame
|
||||
'collapsible-first-order-checks6
|
||||
'((contract (-> (-> any/c any/c))
|
||||
(contract (-> (-> any/c))
|
||||
(add-many-contracts 11 (-> (-> any/c any/c))
|
||||
(contract (-> (-> any/c any/c)) ; to have next one be collapsible
|
||||
(lambda () add1)
|
||||
'innermost-pos 'innermost-neg)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
'outer-pos 'outer-neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'collapsible-first-order-checks7
|
||||
;; both should fail, but want to make sure we drop the right redundant check
|
||||
'((contract (-> (-> any/c any/c any/c) any)
|
||||
(add-many-contracts 11 (-> (-> any/c any/c any/c) any)
|
||||
(lambda (x) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
add1))
|
||||
|
||||
;; scenario: double-wrap (enter collapsible mode), unrelated chaperone, another contract
|
||||
;; want to make sure no check gets lost
|
||||
(test/pos-blame
|
||||
'collapsible-chaperone-in-middle
|
||||
'(let ([x 0])
|
||||
(define f (contract (-> any/c string?)
|
||||
(add-many-contracts 11 (-> any/c string?)
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'mid-pos 'mid-neg))
|
||||
(define f2 (chaperone-procedure f (lambda (y) y)))
|
||||
((add-many-contracts 11 (-> any/c integer?)
|
||||
f2
|
||||
'outer-pos 'outer-neg)
|
||||
4)))
|
||||
|
||||
(test-true
|
||||
'collapsible-bail-on-subcontract1
|
||||
;; Contracts lifted to defeat the opt/c rewriting
|
||||
'(let ([ctc1 (-> (-> any/c (values any/c any/c)) any/c)]
|
||||
[ctc2 (-> (-> any/c (values any/c any/c)) any/c)])
|
||||
(collapsible?
|
||||
(contract ctc1
|
||||
(add-many-contracts 11 ctc2
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'pos 'neg))))
|
||||
(test-true
|
||||
'collapsible-bail-on-subcontract2
|
||||
;; Contracts lifted to defeat the opt/c rewriting
|
||||
'(let ([ctc1 (-> any/c (-> any/c (values any/c any/c)) any/c)]
|
||||
[ctc2 (-> any/c (-> any/c (values any/c any/c)) any/c)])
|
||||
(collapsible?
|
||||
(contract ctc1
|
||||
(add-many-contracts 11 ctc2
|
||||
(lambda (x y) x)
|
||||
'pos 'neg)
|
||||
'pos 'neg))))
|
||||
(test-true
|
||||
'collapsible-bail-on-subcontract3
|
||||
;; Contracts lifted to defeat the opt/c rewriting
|
||||
'(let ([ctc1 (-> any/c (-> any/c (values any/c any/c)))]
|
||||
[ctc2 (-> any/c (-> any/c (values any/c any/c)))])
|
||||
(collapsible?
|
||||
(contract ctc1
|
||||
(add-many-contracts 11 ctc2
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'pos 'neg))))
|
||||
|
||||
(test/neg-blame
|
||||
'collapsible-merge-subcontract1
|
||||
'(let ()
|
||||
(define id (contract (-> (-> string? string?) (-> string? string?))
|
||||
(add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
|
||||
(lambda (x) x)
|
||||
'p1 'n1)
|
||||
'p2 'n2))
|
||||
(define a1 (add-many-contracts 11 (-> integer? integer?)
|
||||
add1
|
||||
'pos 'neg))
|
||||
((id a1) "a")))
|
||||
(test/neg-blame
|
||||
'collapsible-merge-subcontract2
|
||||
'(let ()
|
||||
(define id (contract (-> (-> string? string?) (-> string? string?))
|
||||
(add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
|
||||
(lambda (x) x)
|
||||
'p1 'n2)
|
||||
'pos 'neg))
|
||||
(define a1 (add-many-contracts 11 (-> integer? integer?)
|
||||
(lambda (x) x)
|
||||
'p3 'n3))
|
||||
((id a1) 1)))
|
||||
(test/spec-passed
|
||||
'collapsible-merge-subcontract3
|
||||
'(let ()
|
||||
;; lift definitions to defeat the opt/c rewriting
|
||||
;; (otherwise that bypasses the whole collapsible machinery)
|
||||
(define ctc1 (-> (-> string? string?) (-> string? string?)))
|
||||
(define ctc2 (-> string? string?))
|
||||
(define id (contract ctc1
|
||||
(add-many-contracts 11 ctc1
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'p2 'n2))
|
||||
(define a1 (add-many-contracts 11 ctc2
|
||||
(lambda (x) x)
|
||||
'p3 'n3))
|
||||
(has-num-contracts? (id a1) 1 1)))
|
||||
(test/neg-blame
|
||||
'collapsible-merge-subcontract4
|
||||
'(let ()
|
||||
(define id (contract (-> (-> string? string?) (-> string? string?))
|
||||
(add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
|
||||
(lambda (x) x)
|
||||
'p1 'n1)
|
||||
'p2 'n2))
|
||||
(define a1 (contract (-> integer? integer?)
|
||||
(add-many-contracts 11 (-> integer? integer?)
|
||||
add1
|
||||
'p3 'n3)
|
||||
'pos 'neg))
|
||||
((id a1) "a")))
|
||||
(test/neg-blame
|
||||
'collapsible-merge-subcontract5
|
||||
'(let ()
|
||||
(define id (contract (-> (-> string? string?) (-> string? string?))
|
||||
(add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
|
||||
(lambda (x) x)
|
||||
'p1 'n1)
|
||||
'pos 'neg))
|
||||
(define a1 (contract (-> integer? integer?)
|
||||
(add-many-contracts 11 (-> integer? integer?)
|
||||
(lambda (x) x)
|
||||
'p3 'n3)
|
||||
'p4 'n4))
|
||||
((id a1) 1)))
|
||||
(test/spec-passed
|
||||
'collapsible-merge-subcontract6
|
||||
'(let ()
|
||||
;; lift definitions to defeat the opt/c rewriting
|
||||
;; (otherwise that bypasses the whole collapsible machinery)
|
||||
(define ctc1 (-> (-> string? string?) (-> string? string?)))
|
||||
(define ctc2 (-> string? string?))
|
||||
(define id (contract ctc1
|
||||
(add-many-contracts 11 ctc1
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'p2 'n2))
|
||||
(define a1 (contract ctc2
|
||||
(add-many-contracts 11 ctc2
|
||||
(lambda (x) x)
|
||||
'p3 'n3)
|
||||
'p4 'n4))
|
||||
(has-num-contracts? (id a1) 1 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'collapsible-multi-args1
|
||||
'((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'pos 'neg)
|
||||
'outer-pos 'outer-neg)
|
||||
1 "a"))
|
||||
(test/pos-blame
|
||||
'collapsible-multi-args2
|
||||
'((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x) x)
|
||||
'pos 'neg)
|
||||
'outer-pos 'outer-neg)
|
||||
1 "a"))
|
||||
(test/neg-blame
|
||||
'collapsible-multi-args3
|
||||
'((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
"a" "a"))
|
||||
(test/neg-blame
|
||||
'collapsible-multi-args4
|
||||
'((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
1 1))
|
||||
(test/spec-passed/result
|
||||
'collapsible-multi-args5
|
||||
'(with-handlers ([exn:fail:contract:arity? (lambda (e) 'ok)])
|
||||
((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
1 1 "a"))
|
||||
'ok)
|
||||
(test/spec-passed/result
|
||||
'collapsible-multi-args6
|
||||
'(with-handlers ([exn:fail:contract:arity? (lambda (e) 'ok)])
|
||||
((contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)
|
||||
1))
|
||||
'ok)
|
||||
(test/spec-passed
|
||||
'collapsible-multi-args7
|
||||
'(collapsible? (contract (-> number? string? number?)
|
||||
(add-many-contracts 11 (-> number? string? number?)
|
||||
(lambda (x y) x)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)))
|
||||
|
||||
(contract-eval '(require racket/class))
|
||||
|
||||
(test/spec-passed
|
||||
'object/c-->-pass/no-bail
|
||||
'(let* ([grid/c (-> (-> (object/c)))]
|
||||
[o (new object%)]
|
||||
[v (lambda () o)]
|
||||
[grid (contract
|
||||
grid/c
|
||||
(add-many-contracts 11
|
||||
grid/c
|
||||
(lambda () v)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)])
|
||||
((grid))))
|
||||
|
||||
(test/spec-failed
|
||||
'object/c-->-fail/should-bail
|
||||
'(let* ([v (add-many-contracts 11 (-> integer?) (lambda () 1) 'p 'n)]
|
||||
[grid (contract
|
||||
(-> (-> (object/c)))
|
||||
(add-many-contracts 11
|
||||
(-> (-> (object/c)))
|
||||
(lambda () v)
|
||||
'inner-pos 'inner-neg)
|
||||
'pos 'neg)])
|
||||
((grid)))
|
||||
"inner-pos")
|
||||
|
||||
;; arrow and vector contracts
|
||||
(test/spec-failed
|
||||
'arrow+vector
|
||||
'(let* ([ctc (-> (vectorof integer?))]
|
||||
[f (contract ctc
|
||||
(add-many-contracts 11 ctc (lambda () (vector 1)) 'inner-pos 'inner-neg)
|
||||
'pos 'neg)])
|
||||
(vector-set! (f) 0 1.5))
|
||||
"neg")
|
||||
|
||||
;; arrow and box
|
||||
(test/spec-failed
|
||||
'arrow+box
|
||||
'(let* ([ctc (-> (box/c integer?))]
|
||||
[f (contract ctc (add-many-contracts 11 ctc (lambda () (box 1)) 'inner-pos 'inner-neg) 'pos 'neg)])
|
||||
(set-box! (f) 1.5))
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'arrow-symbol-multi-pos1
|
||||
'(let* ([ctc1 (-> integer? (-> symbol? symbol?))]
|
||||
[ctc2 (-> integer? symbol?)]
|
||||
[f (lambda (x) (lambda (y) y))]
|
||||
[cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
|
||||
(cf 0))
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'arrow-symbol-multi-pos2
|
||||
'(let* ([ctc1 (-> integer? (-> symbol? symbol?))]
|
||||
[ctc2 (-> integer? symbol?)]
|
||||
[f (lambda (x) 'foo)]
|
||||
[cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
|
||||
(cf 0))
|
||||
"inner-pos")
|
||||
|
||||
(test/spec-failed
|
||||
'arrow-symbol-multi-neg1
|
||||
'(let* ([ctc1 (-> symbol? integer?)]
|
||||
[ctc2 (-> (-> symbol? symbol?) integer?)]
|
||||
[f (lambda (x) 0)]
|
||||
[cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
|
||||
(cf (lambda (x) x)))
|
||||
"inner-neg")
|
||||
|
||||
(test/spec-failed
|
||||
'arrow-symbol-multi-neg2
|
||||
'(let* ([ctc1 (-> symbol? integer?)]
|
||||
[ctc2 (-> (-> symbol? symbol?) integer?)]
|
||||
[f (lambda (x) 0)]
|
||||
[cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
|
||||
(cf 'foo))
|
||||
"neg")
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-1
|
||||
'(let* ([ctc1 (coerce-contract/f integer?)]
|
||||
[ctc2 (coerce-contract/f string?)]
|
||||
[ctcs (list ctc1 ctc2 ctc1 ctc2 ctc1)])
|
||||
(calculate-drops ctcs))
|
||||
'(2))
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-2
|
||||
'(let* ([ctc1 (coerce-contract/f integer?)]
|
||||
[ctcs (list ctc1 ctc1 ctc1 ctc1 ctc1)])
|
||||
(calculate-drops ctcs))
|
||||
'(3 2 1))
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-2
|
||||
'(let* ([ctc1 (coerce-contract/f (object/c))]
|
||||
[ctcs (list ctc1 ctc1 ctc1 ctc1 ctc1)])
|
||||
(calculate-drops ctcs))
|
||||
'())
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-3
|
||||
'(let* ([ctc1 (coerce-contract/f integer?)]
|
||||
[ctc2 (coerce-contract/f string?)]
|
||||
[ctcs (list ctc1 ctc2 ctc1 ctc2 ctc1)])
|
||||
(calculate-drops ctcs))
|
||||
'(2))
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-4
|
||||
'(let* ([c1 (coerce-contract/f integer?)]
|
||||
[c2 (coerce-contract/f (vectorof integer?))]
|
||||
[c3 (coerce-contract/f (-> integer? integer?))]
|
||||
[ctcs (list c1 c2 c3 c2 c3 c1 c3 c2 c1)])
|
||||
(calculate-drops ctcs))
|
||||
'(5 3 4))
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-5
|
||||
'(let* ([c1 (coerce-contract/f integer?)]
|
||||
[c2 (coerce-contract/f (vectorof integer?))]
|
||||
[c3 (coerce-contract/f (-> integer? integer?))]
|
||||
[c4 (coerce-contract/f (object/c))]
|
||||
[ctcs (list c1 c2 c3 c4 c4 c2 c3 c1 c3 c2 c4 c1 c4)])
|
||||
(calculate-drops ctcs))
|
||||
'(7 5 6))
|
||||
|
||||
(test/spec-passed/result
|
||||
'calculate-drops-6
|
||||
'(let* ([c1 (coerce-contract/f integer?)]
|
||||
[ctcs (list c1 c1 c1 c1 c1 c1 c1 c1 c1)])
|
||||
(calculate-drops ctcs))
|
||||
'(7 6 5 4 3 2 1))
|
||||
)
|
||||
1455
pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt
Normal file
1455
pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt
Normal file
File diff suppressed because it is too large
Load Diff
|
|
@ -72,6 +72,16 @@
|
|||
'pos
|
||||
'neg)
|
||||
0 1))
|
||||
|
||||
(context-test '("the 1st argument of")
|
||||
'((contract (-> boolean? integer? integer?)
|
||||
(contract (-> boolean? integer? integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
'pos
|
||||
'neg)
|
||||
0 1))
|
||||
|
||||
(context-test '("the cdr of" "the 1st argument of")
|
||||
'((contract (-> (cons/c integer? boolean?) integer? integer?)
|
||||
|
|
@ -344,6 +354,59 @@
|
|||
'neg)
|
||||
2)
|
||||
0))
|
||||
|
||||
(context-test '("an element of" "the 2nd element of")
|
||||
'(vector-ref
|
||||
(vector-ref
|
||||
(let ([ctc (vector/c (vectorof real?)
|
||||
(vectorof number?)
|
||||
(vectorof boolean?))])
|
||||
(contract
|
||||
ctc
|
||||
(contract
|
||||
ctc
|
||||
(vector (vector 1) (vector 1) (vector 1))
|
||||
'pos
|
||||
'neg)
|
||||
'pos
|
||||
'neg))
|
||||
2)
|
||||
0))
|
||||
|
||||
(context-test
|
||||
'("the 1st argument of" "an element of" "the range of" "the 2nd element of")
|
||||
'(let* ([ctc (vector/c any/c any/c (-> any/c (vectorof (-> string? any/c))))]
|
||||
[v (vector 'any1
|
||||
'any2
|
||||
(λ (_) (vector (λ (s) s))))]
|
||||
[cv (contract ctc (contract ctc v 'pos 'neg) 'pos 'neg)])
|
||||
((vector-ref ((vector-ref cv 2) 'any3) 0) 'not-a-string)))
|
||||
|
||||
(context-test
|
||||
'("the range of" "an element of" "the range of" "the 2nd element of")
|
||||
'(let* ([ctc (vector/c any/c any/c (-> any/c (vectorof (-> string? string?))))]
|
||||
[v (vector 'any1
|
||||
'any2
|
||||
(λ (_) (vector (λ (s) s))))]
|
||||
[cv (contract ctc (contract ctc v 'pos 'neg) 'pos 'neg)])
|
||||
(vector-set! cv 2 (λ (_) (vector (λ (_) 'not-a-string))))
|
||||
((vector-ref ((vector-ref cv 2) 'any3) 0) "a string")))
|
||||
|
||||
(context-test '("the 1st element of" "an element of")
|
||||
'(vector-ref
|
||||
(vector-ref
|
||||
(let ([ctc (vectorof (vector/c integer? boolean?))])
|
||||
(contract
|
||||
ctc
|
||||
(contract
|
||||
ctc
|
||||
(vector (vector 1 2) (vector 2 3))
|
||||
'pos
|
||||
'neg)
|
||||
'pos
|
||||
'neg))
|
||||
0)
|
||||
1))
|
||||
|
||||
(context-test '("the 0th element of")
|
||||
'(vector-ref (contract (vector/c integer?)
|
||||
|
|
@ -508,6 +571,50 @@
|
|||
'(contract (and/c integer? positive?)
|
||||
5.9
|
||||
'pos 'neg))
|
||||
|
||||
(context-test
|
||||
'("the x argument of" "an element of")
|
||||
'(let ()
|
||||
(define (contract* n c v pos neg)
|
||||
(for/fold ([cv v])
|
||||
([_ (in-range n)])
|
||||
(contract c cv pos neg)))
|
||||
(define c1 (vectorof (->i ([x integer?]) [_ integer?])))
|
||||
(define c2 (vectorof (->i ([y (not/c string?)]) [_ any/c])))
|
||||
(define vec
|
||||
(contract
|
||||
c1
|
||||
(contract
|
||||
c2
|
||||
(contract* 11 c1 (vector (λ (x) x)) 'p 'n)
|
||||
'p
|
||||
'n)
|
||||
'p
|
||||
'n))
|
||||
(define f (vector-ref vec 0))
|
||||
(f "bad")))
|
||||
|
||||
(context-test
|
||||
'("the x argument of" "an element of")
|
||||
'(let ()
|
||||
(define (contract* n c v pos neg)
|
||||
(for/fold ([cv v])
|
||||
([_ (in-range n)])
|
||||
(contract c cv pos neg)))
|
||||
(define c1 (vectorof (->i ([x integer?]) [_ integer?])))
|
||||
(define c2 (vectorof (->i ([y (not/c string?)]) [_ any/c])))
|
||||
(define vec
|
||||
(contract
|
||||
c1
|
||||
(contract
|
||||
c2
|
||||
(contract c1 (vector (λ (x) x)) 'p 'n)
|
||||
'p
|
||||
'n)
|
||||
'p
|
||||
'n))
|
||||
(define f (vector-ref vec 0))
|
||||
(f "bad")))
|
||||
|
||||
(let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f)
|
||||
#f
|
||||
|
|
@ -520,4 +627,4 @@
|
|||
(ctest "promised: ~s\n produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s" given: "~e"))
|
||||
(ctest "expected: ~s\n given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s" given: "~e"))
|
||||
(ctest "promised ~s produced ~e" blame-fmt->-string ,blame-pos '(expected "~s" given "~e"))
|
||||
(ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e"))))
|
||||
(ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e"))))
|
||||
|
|
|
|||
|
|
@ -1664,8 +1664,7 @@
|
|||
(and (exn:fail:contract:blame? x)
|
||||
;; ensure there is context information
|
||||
(regexp-match? #rx"in: the 1st argument of" (exn-message x))
|
||||
(regexp-match? #rx"blaming: [^\n]*contract7-n" (exn-message x)))))
|
||||
|
||||
(regexp-match? #rx"blaming: [^\n]*contract7-n" (exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
're-providing
|
||||
|
|
|
|||
|
|
@ -246,6 +246,48 @@
|
|||
(list-contract? (odd-length-list-of-integers)))
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
'build-chaperone-contract-property-s-e1
|
||||
'(let ()
|
||||
(struct s-e-late-neg-none ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:collapsible-late-neg-projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(values
|
||||
(λ (val neg-party)
|
||||
(raise-blame-error blame val "bad"))
|
||||
#f)))
|
||||
#:name (λ (x) 'the-name)
|
||||
#:first-order (λ (c) (λ (x) #t))
|
||||
#:stronger (λ (x y) #f)))
|
||||
|
||||
(((contract-projection (s-e-late-neg-none))
|
||||
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
|
||||
5)))
|
||||
|
||||
(test/pos-blame
|
||||
'build-chaperone-contract-property-s-e2
|
||||
'(let ()
|
||||
(struct s-e-late-neg-none ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:collapsible-late-neg-projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(values
|
||||
(λ (val neg-party)
|
||||
(raise-blame-error blame val "bad"))
|
||||
#f)))
|
||||
#:name (λ (x) 'the-name)
|
||||
#:first-order (λ (c) (λ (x) #t))
|
||||
#:stronger (λ (x y) #f)))
|
||||
|
||||
(((contract-projection (listof (s-e-late-neg-none)))
|
||||
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
|
||||
(list 1 2 3))))
|
||||
|
||||
(contract-eval
|
||||
'(define prop:late-neg-proj:bad-prime-box-list/c
|
||||
(let* ([prime? (λ (n)
|
||||
|
|
|
|||
|
|
@ -1464,19 +1464,20 @@
|
|||
|
||||
(let ([c% (parameterize ([current-inspector (make-inspector)])
|
||||
(contract-eval '(class object% (super-new))))])
|
||||
(test (list c% #f)
|
||||
(test #:test-case-name 'object-info
|
||||
(list c% #f)
|
||||
'object-info
|
||||
(contract-eval
|
||||
`(call-with-values
|
||||
(lambda () (object-info (contract (object-contract) (new ,c%) 'pos 'neg)))
|
||||
list))))
|
||||
|
||||
;; object->vector tests
|
||||
(let* ([obj
|
||||
(parameterize ([current-inspector (make-inspector)])
|
||||
(contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))]
|
||||
[vec (contract-eval `(object->vector ,obj))])
|
||||
(test vec
|
||||
(test #:test-case-name 'object->vector
|
||||
vec
|
||||
(contract-eval 'object->vector)
|
||||
(contract-eval
|
||||
`(contract (object-contract (field x integer?) (field y integer?))
|
||||
|
|
|
|||
|
|
@ -422,7 +422,8 @@
|
|||
'pos 'neg))
|
||||
log)
|
||||
|
||||
'(c b a) '(c c b b a a))
|
||||
'(c b a)
|
||||
'(c c c c c c c c c c c b b b b b b b b b b b a a a a a a a a a a a))
|
||||
|
||||
;; this tests the situation where the double-wrapping avoidance
|
||||
;; kicks in. The second part of the result, '(a b b a a), indicates
|
||||
|
|
|
|||
|
|
@ -313,4 +313,24 @@ so that propagation occurs.
|
|||
(ctest #t couple? (make-couple 1 2))
|
||||
(ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg))
|
||||
(ctest #f couple? 1)
|
||||
(ctest #f couple? #f))
|
||||
(ctest #f couple? #f)
|
||||
|
||||
(test/spec-passed/result
|
||||
"chaperone-contracts-stay-chaperones"
|
||||
'(let ([ctc (-> integer?)]
|
||||
[opt-ctc (opt/c (-> integer?))])
|
||||
(and (chaperone-contract? ctc)
|
||||
(not (impersonator-contract? ctc))
|
||||
(chaperone-contract? opt-ctc)
|
||||
(not (impersonator-contract? ctc))))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
"impersonators-stay-impersonators"
|
||||
'(let ([ctc (->i () [_ any/c])]
|
||||
[opt-ctc (opt/c (->i () [_ any/c]))])
|
||||
(and (impersonator-contract? ctc)
|
||||
(not (chaperone-contract? ctc))
|
||||
(impersonator-contract? opt-ctc)
|
||||
(not (chaperone-contract? opt-ctc))))
|
||||
#t))
|
||||
|
|
|
|||
|
|
@ -103,7 +103,21 @@
|
|||
'neg)
|
||||
x)
|
||||
'(1 2)
|
||||
'(1 2 1 2)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'or/c-ordering-double-wrap
|
||||
'(let ([x '()])
|
||||
(contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
(contract
|
||||
(or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
'anything
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
x)
|
||||
'(1 2 1 2)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'or/c-ordering2
|
||||
|
|
@ -114,7 +128,21 @@
|
|||
'neg)
|
||||
x)
|
||||
'(2)
|
||||
'(2 2)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'or/c-ordering2-double-wrap
|
||||
'(let ([x '()])
|
||||
(contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
(contract
|
||||
(or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
'anything
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
x)
|
||||
'(2 2)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed
|
||||
'or/c-hmm
|
||||
|
|
@ -188,7 +216,21 @@
|
|||
'neg)
|
||||
x)
|
||||
'(1 2)
|
||||
'(1 2 1 2)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'and/c-ordering-double-wrap
|
||||
'(let ([x '()])
|
||||
(contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
(contract
|
||||
(and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
'anything
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
x)
|
||||
'(1 2 1 2)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'ho-and/c-ordering
|
||||
|
|
@ -203,7 +245,28 @@
|
|||
1)
|
||||
(reverse x))
|
||||
'(3 1 2 4)
|
||||
'(3 1 3 1 2 4 2 4)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'ho-and/c-ordering-double-wrap
|
||||
'(let ([x '()])
|
||||
((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t)
|
||||
(lambda (y) (set! x (cons 2 x)) #t))
|
||||
(-> (lambda (y) (set! x (cons 3 x)) #t)
|
||||
(lambda (y) (set! x (cons 4 x)) #t)))
|
||||
(contract
|
||||
(and/c (-> (lambda (y) (set! x (cons 1 x)) #t)
|
||||
(lambda (y) (set! x (cons 2 x)) #t))
|
||||
(-> (lambda (y) (set! x (cons 3 x)) #t)
|
||||
(lambda (y) (set! x (cons 4 x)) #t)))
|
||||
(λ (x) x)
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
(reverse x))
|
||||
'(3 1 3 1 2 4 2 4)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'and/c-isnt
|
||||
|
|
@ -344,7 +407,22 @@
|
|||
'neg)
|
||||
x)
|
||||
'(1 2)
|
||||
'(1 2 1 2)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'first-or/c-ordering-double-wrap
|
||||
'(let ([x '()])
|
||||
(contract (first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
(contract
|
||||
(first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
'anything
|
||||
'pos
|
||||
'neg)
|
||||
'pos
|
||||
'neg)
|
||||
x)
|
||||
'(1 2 1 2)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'first-or/c-ordering2
|
||||
|
|
@ -355,7 +433,21 @@
|
|||
'neg)
|
||||
x)
|
||||
'(2)
|
||||
'(2 2)) ; result if contract is applied twice
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'first-or/c-ordering2-double-wrap
|
||||
'(let ([x '()])
|
||||
(contract (first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
(contract
|
||||
(first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
|
||||
'anything
|
||||
'pos 'neg)
|
||||
'pos
|
||||
'neg)
|
||||
x)
|
||||
'(2 2)
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed
|
||||
'first-or/c-hmm
|
||||
|
|
|
|||
|
|
@ -396,7 +396,7 @@
|
|||
'(contract (vector/c pos-blame? #:flat? #t) #(1) 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-marks42
|
||||
'contract-marks42b
|
||||
'((vector-ref (contract (vector/c (-> pos-blame? neg-blame?)) (vector values)
|
||||
'pos 'neg)
|
||||
0)
|
||||
|
|
|
|||
|
|
@ -138,4 +138,5 @@
|
|||
;; with the old implementation it is more like 20 seconds
|
||||
;; on my laptop and about .3 seconds with the new one
|
||||
(< (- cpu gc) 5000))
|
||||
#t))
|
||||
#t
|
||||
do-not-double-wrap))
|
||||
|
|
|
|||
|
|
@ -213,7 +213,9 @@
|
|||
(struct gds dx ())
|
||||
(define gd (contract (struct/c gds (vectorof any/c)) (gds (vector 1)) 'pos 'neg))
|
||||
(vector-ref (d-vec gd) 0)))
|
||||
1)
|
||||
1
|
||||
;; wrapping 11 times is too many for this test case, so skip the multi-wrap test
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed
|
||||
'struct/c-simple-contract-accessor
|
||||
|
|
@ -1005,7 +1007,7 @@
|
|||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-new42
|
||||
'struct/dc-new42-1
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(define α (new-∀/c 'α))
|
||||
|
|
@ -1013,10 +1015,11 @@
|
|||
(λ (x) (s 11 x))
|
||||
'pos
|
||||
'neg) 1)))
|
||||
1)
|
||||
1
|
||||
do-not-double-wrap)
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new42
|
||||
'struct/dc-new42-2
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)])
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
test/neg-blame
|
||||
test/well-formed
|
||||
test ctest ctest/rewrite
|
||||
test-true test-false
|
||||
|
||||
current-contract-namespace
|
||||
make-basic-contract-namespace
|
||||
|
|
@ -23,14 +24,17 @@
|
|||
contract-expand
|
||||
|
||||
rewrite-to-add-opt/c
|
||||
rewrite-to-double-wrap
|
||||
rewrite-to-multi-wrap
|
||||
do-not-double-wrap
|
||||
contract-rewrite-tests-to-skip
|
||||
|
||||
test-cases failures)
|
||||
|
||||
(define test-cases 0)
|
||||
(define failures 0)
|
||||
|
||||
(define contract-rewrite-tests-to-skip (make-parameter '()))
|
||||
|
||||
(provide new-test-case new-failure)
|
||||
(define (new-test-case name)
|
||||
;(printf "running test ~a\n" name)
|
||||
|
|
@ -101,6 +105,7 @@
|
|||
(parameterize ([current-namespace n])
|
||||
(namespace-require 'racket/contract/base)
|
||||
(namespace-require '(only racket/contract/private/blame exn:fail:contract:blame?))
|
||||
(namespace-require '(only racket/contract/private/collapsible-common COLLAPSIBLE-LIMIT))
|
||||
(for ([addon (in-list addons)])
|
||||
(namespace-require addon)))
|
||||
n)
|
||||
|
|
@ -159,7 +164,9 @@
|
|||
(test #t
|
||||
name
|
||||
(contract-eval #:test-case-name name
|
||||
`(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
|
||||
`(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t))))
|
||||
,exp
|
||||
"NO EXN RAISED"))))
|
||||
|
||||
(define (contract-syntax-error-test name exp [reg #rx""])
|
||||
(test #t
|
||||
|
|
@ -207,7 +214,7 @@
|
|||
,(wrapper expression k)
|
||||
'no-exn-raised)))))
|
||||
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c")
|
||||
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap"))
|
||||
(rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap"))
|
||||
|
||||
(define (test/spec-passed/result name expression result [double-wrapped-result result])
|
||||
(parameterize ([compile-enforce-module-constants #f])
|
||||
|
|
@ -224,7 +231,7 @@
|
|||
',(wrapper expression k)))))
|
||||
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c")
|
||||
(unless (eq? double-wrapped-result do-not-double-wrap)
|
||||
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" double-wrapped-result))
|
||||
(rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" double-wrapped-result))
|
||||
|
||||
(let ([new-expression (rewrite-out expression)])
|
||||
(when new-expression
|
||||
|
|
@ -237,6 +244,10 @@
|
|||
eval
|
||||
',new-expression))))))
|
||||
|
||||
;; convenient shortcuts
|
||||
(define (test-true name expression) (test/spec-passed/result name expression #t))
|
||||
(define (test-false name expression) (test/spec-passed/result name expression #f))
|
||||
|
||||
;; rewrites `provide/contract' to use `contract-out'
|
||||
(define (rewrite-out orig-exp)
|
||||
(define rewrote? #f)
|
||||
|
|
@ -327,16 +338,15 @@
|
|||
(rewrite (lambda (ctc val parties loop)
|
||||
`(contract (opt/c ,(loop ctc)) ,(loop val) ,@(map loop parties)))))
|
||||
|
||||
;; rewrites `contract` to double-wrap. To test space-efficient wrappers.
|
||||
(define rewrite-to-double-wrap
|
||||
;; rewrites `contract` to double-wrap. To test collapsible wrappers.
|
||||
(define rewrite-to-multi-wrap
|
||||
(rewrite (lambda (ctc val parties loop)
|
||||
(define new-ctc (loop ctc))
|
||||
(define new-parties (map loop parties))
|
||||
`(contract ,new-ctc
|
||||
(contract ,(loop ctc)
|
||||
,(loop val)
|
||||
,@new-parties)
|
||||
,@new-parties))))
|
||||
`(let ([the-ctc ,new-ctc])
|
||||
(for/fold ([the-val ,(loop val)])
|
||||
([i (in-range (add1 COLLAPSIBLE-LIMIT))])
|
||||
(contract the-ctc the-val ,@new-parties))))))
|
||||
(define do-not-double-wrap (gensym)) ; recognized by some test forms
|
||||
|
||||
;; blame : (or/c 'pos 'neg string?)
|
||||
|
|
@ -360,19 +370,20 @@
|
|||
(and (exn:fail:contract:blame? exn)
|
||||
(,has-proper-blame? (exn-message exn))))))
|
||||
(define (rewrite-test wrapper wrapper-name short-wrapper-name)
|
||||
(let/ec k
|
||||
(let ([rewritten (wrapper expression k)])
|
||||
(contract-eval
|
||||
#:test-case-name (format "~a ~a" name wrapper-name)
|
||||
`(,test-an-error
|
||||
',(string->symbol (format "~a+~a" name short-wrapper-name))
|
||||
(lambda () ,rewritten)
|
||||
',rewritten
|
||||
(lambda (exn)
|
||||
(and (exn:fail:contract:blame? exn)
|
||||
(,has-proper-blame? (exn-message exn)))))))))
|
||||
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c" "opt/c")
|
||||
(rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" "double"))
|
||||
(unless (member short-wrapper-name (contract-rewrite-tests-to-skip))
|
||||
(let/ec k
|
||||
(let ([rewritten (wrapper expression k)])
|
||||
(contract-eval
|
||||
#:test-case-name (format "~a ~a" name wrapper-name)
|
||||
`(,test-an-error
|
||||
',(string->symbol (format "~a+~a" name short-wrapper-name))
|
||||
(lambda () ,rewritten)
|
||||
',rewritten
|
||||
(lambda (exn)
|
||||
(and (exn:fail:contract:blame? exn)
|
||||
(,has-proper-blame? (exn-message exn))))))))))
|
||||
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c" "opt/c")
|
||||
(rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" "double"))
|
||||
|
||||
(define (test/pos-blame name expression) (test/spec-failed name expression 'pos))
|
||||
(define (test/neg-blame name expression) (test/spec-failed name expression 'neg))
|
||||
|
|
@ -392,7 +403,7 @@
|
|||
',name*
|
||||
,(wrapper 'expression k)))))
|
||||
(rewrite-test rewrite-to-add-opt/c 'opt-name)
|
||||
(rewrite-test rewrite-to-double-wrap 'double-name)))]))
|
||||
(rewrite-test rewrite-to-multi-wrap 'double-name)))]))
|
||||
|
||||
(define (test/well-formed stx)
|
||||
(contract-eval
|
||||
|
|
@ -427,4 +438,4 @@
|
|||
eval
|
||||
'(begin ,rewritten (void)))))))
|
||||
(rewrite-test rewrite-to-add-opt/c "opt/c")
|
||||
(rewrite-test rewrite-to-double-wrap "double"))
|
||||
(rewrite-test rewrite-to-multi-wrap "double"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "test-util.rkt")
|
||||
(require (only-in racket/contract/private/collapsible-common COLLAPSIBLE-LIMIT))
|
||||
(parameterize ([current-contract-namespace
|
||||
(make-basic-contract-namespace
|
||||
'racket/contract/combinator)])
|
||||
|
|
@ -87,41 +88,43 @@
|
|||
(vector-immutable 11)
|
||||
'pos 'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'vectorof13
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
(parameterize ([contract-rewrite-tests-to-skip '("double")])
|
||||
(test/pos-blame
|
||||
'vectorof13
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0))))))
|
||||
|
||||
(test/neg-blame
|
||||
'vectorof14
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))]))))
|
||||
(parameterize ([contract-rewrite-tests-to-skip '("double")])
|
||||
(test/neg-blame
|
||||
'vectorof14
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))])))))
|
||||
|
||||
(test/spec-passed
|
||||
'vector/c1
|
||||
|
|
@ -163,56 +166,59 @@
|
|||
(vector-set! (contract (vector/c integer?) v 'pos 'neg)
|
||||
0 #f)))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c7
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
(parameterize ([contract-rewrite-tests-to-skip '("double")])
|
||||
(test/pos-blame
|
||||
'vector/c7
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0))))))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c8
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector-immutable v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
(parameterize ([contract-rewrite-tests-to-skip '("double")])
|
||||
(test/pos-blame
|
||||
'vector/c8
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector-immutable v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0))))))
|
||||
|
||||
(test/neg-blame
|
||||
'vector/c9
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))]))))
|
||||
(parameterize ([contract-rewrite-tests-to-skip '("double")])
|
||||
(test/neg-blame
|
||||
'vector/c9
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))])))))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c7
|
||||
|
|
@ -234,7 +240,7 @@
|
|||
'pos 'neg)
|
||||
0)
|
||||
1
|
||||
2)
|
||||
(add1 COLLAPSIBLE-LIMIT))
|
||||
|
||||
(test/spec-passed/result
|
||||
'vectorof-eager
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@
|
|||
value-blame
|
||||
contract-continuation-mark-key
|
||||
list-contract?
|
||||
|
||||
|
||||
;; from private/case-arrow.rkt
|
||||
case->
|
||||
|
||||
|
|
|
|||
28
racket/collects/racket/contract/collapsible.rkt
Normal file
28
racket/collects/racket/contract/collapsible.rkt
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
#lang racket/base
|
||||
(require "private/collapsible-common.rkt"
|
||||
(submod "private/collapsible-common.rkt" properties)
|
||||
(only-in "private/guts.rkt"
|
||||
get/build-collapsible-late-neg-projection
|
||||
collapsible-contract-continuation-mark-key
|
||||
with-collapsible-contract-continuation-mark))
|
||||
|
||||
(provide
|
||||
;; collapsible functions and structures
|
||||
(struct-out collapsible-ho/c)
|
||||
(struct-out collapsible-leaf/c)
|
||||
(struct-out collapsible-property)
|
||||
(struct-out collapsible-count-property)
|
||||
(struct-out collapsible-wrapper-property)
|
||||
build-collapsible-leaf
|
||||
prop:collapsible-contract
|
||||
collapsible-contract-property?
|
||||
build-collapsible-contract-property
|
||||
collapsible-contract?
|
||||
merge
|
||||
collapsible-guard
|
||||
impersonator-prop:collapsible
|
||||
has-impersonator-prop:collapsible?
|
||||
get-impersonator-prop:collapsible
|
||||
get/build-collapsible-late-neg-projection
|
||||
collapsible-contract-continuation-mark-key
|
||||
with-collapsible-contract-continuation-mark)
|
||||
|
|
@ -53,7 +53,7 @@
|
|||
contract-stronger?
|
||||
contract-equivalent?
|
||||
list-contract?
|
||||
|
||||
|
||||
contract-first-order
|
||||
contract-first-order-passes?
|
||||
|
||||
|
|
@ -74,7 +74,7 @@
|
|||
|
||||
contract-continuation-mark-key
|
||||
with-contract-continuation-mark
|
||||
|
||||
|
||||
(struct-out wrapped-extra-arg-arrow)
|
||||
contract-custom-write-property-proc
|
||||
(rename-out [contract-custom-write-property-proc custom-write-property-proc])
|
||||
|
|
@ -123,6 +123,7 @@
|
|||
(λ (#:name [name 'anonymous-chaperone-contract]
|
||||
#:first-order [first-order (λ (x) #t)]
|
||||
#:late-neg-projection [late-neg-projection #f]
|
||||
#:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
|
||||
#:val-first-projection [val-first-projection #f]
|
||||
#:projection [projection #f]
|
||||
#:stronger [stronger #f]
|
||||
|
|
@ -133,6 +134,9 @@
|
|||
#:first-order first-order
|
||||
#:late-neg-projection
|
||||
(maybe-add-wrapper add-late-neg-chaperone-check late-neg-projection)
|
||||
#:collapsible-late-neg-projection
|
||||
(maybe-add-wrapper add-collapsible-late-neg-chaperone-check
|
||||
collapsible-late-neg-projection)
|
||||
#:val-first-projection
|
||||
(maybe-add-wrapper add-val-first-chaperone-check val-first-projection)
|
||||
#:projection
|
||||
|
|
@ -149,6 +153,7 @@
|
|||
#:first-order [get-first-order (λ (c) (λ (x) #t))]
|
||||
#:val-first-projection [val-first-proj #f]
|
||||
#:late-neg-projection [late-neg-proj #f]
|
||||
#:collapsible-late-neg-projection [collapsible-late-neg-proj #f]
|
||||
#:projection [get-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:equivalent [equivalent #f]
|
||||
|
|
@ -162,6 +167,8 @@
|
|||
(maybe-add-wrapper add-prop-val-first-chaperone-check val-first-proj)
|
||||
#:late-neg-projection
|
||||
(maybe-add-wrapper add-prop-late-neg-chaperone-check late-neg-proj)
|
||||
#:collapsible-late-neg-projection
|
||||
(maybe-add-wrapper add-prop-collapsible-late-neg-chaperone-check collapsible-late-neg-proj)
|
||||
#:projection
|
||||
(maybe-add-wrapper add-prop-chaperone-check get-projection)
|
||||
#:stronger stronger
|
||||
|
|
@ -171,6 +178,20 @@
|
|||
#:list-contract? is-list-contract?))
|
||||
build-chaperone-contract-property))
|
||||
|
||||
(define (add-prop-collapsible-late-neg-chaperone-check get-collapsible-late-neg)
|
||||
(λ (c)
|
||||
(add-collapsible-late-neg-chaperone-check (get-collapsible-late-neg c))))
|
||||
|
||||
(define (add-collapsible-late-neg-chaperone-check accepts-blame)
|
||||
(λ (b)
|
||||
(define-values (accepts-val-and-np collapsible-ctc) (accepts-blame b))
|
||||
(values
|
||||
(λ (x neg-party)
|
||||
(check-and-signal x
|
||||
(accepts-val-and-np x neg-party)
|
||||
'make-chaperone-contract::collapsible-late-neg-projection))
|
||||
collapsible-ctc)))
|
||||
|
||||
(define (add-prop-late-neg-chaperone-check get-late-neg)
|
||||
(λ (c)
|
||||
(add-late-neg-chaperone-check (get-late-neg c))))
|
||||
|
|
@ -221,6 +242,7 @@
|
|||
(λ (#:name [name 'anonymous-chaperone-contract]
|
||||
#:first-order [first-order (λ (x) #t)]
|
||||
#:late-neg-projection [late-neg-projection #f]
|
||||
#:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
|
||||
#:val-first-projection [val-first-projection #f]
|
||||
#:projection [projection #f]
|
||||
#:stronger [stronger #f]
|
||||
|
|
@ -230,6 +252,8 @@
|
|||
#:name name
|
||||
#:first-order first-order
|
||||
#:late-neg-projection (force-late-neg-eq late-neg-projection)
|
||||
#:collapsible-late-neg-projection
|
||||
(force-collapsible-late-neg-eq collapsible-late-neg-projection)
|
||||
#:val-first-projection (force-val-first-eq val-first-projection)
|
||||
#:projection (force-projection-eq projection)
|
||||
#:stronger stronger
|
||||
|
|
@ -242,6 +266,7 @@
|
|||
(λ (#:name [name (λ (c) 'anonymous-chaperone-contract)]
|
||||
#:first-order [first-order (λ (c) (λ (x) #t))]
|
||||
#:late-neg-projection [late-neg-projection #f]
|
||||
#:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
|
||||
#:val-first-projection [val-first-projection #f]
|
||||
#:projection [projection #f]
|
||||
#:stronger [stronger #f]
|
||||
|
|
@ -253,6 +278,9 @@
|
|||
#:first-order first-order
|
||||
#:late-neg-projection
|
||||
(and late-neg-projection (λ (c) (force-late-neg-eq (late-neg-projection c))))
|
||||
#:collapsible-late-neg-projection
|
||||
(and collapsible-late-neg-projection
|
||||
(λ (c) (force-collapsible-late-neg-eq (collapsible-late-neg-projection c))))
|
||||
#:val-first-projection
|
||||
(and val-first-projection (λ (c) (force-val-first-eq (val-first-projection c))))
|
||||
#:projection
|
||||
|
|
@ -271,6 +299,15 @@
|
|||
(accepts-val-and-np x neg-party)
|
||||
x))))
|
||||
|
||||
(define (force-collapsible-late-neg-eq accepts-blame)
|
||||
(and accepts-blame
|
||||
(λ (b)
|
||||
(define-values (accepts-val-and-np collapsible-ctc) (accepts-blame b))
|
||||
(values
|
||||
(λ (x neg-party)
|
||||
(accepts-val-and-np x neg-party))
|
||||
collapsible-ctc))))
|
||||
|
||||
(define (force-val-first-eq vfp)
|
||||
(and vfp
|
||||
(λ (b)
|
||||
|
|
|
|||
|
|
@ -152,8 +152,8 @@
|
|||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?
|
||||
#:equivalent and-equivalent?
|
||||
#:generate and/c-generate?))
|
||||
#:generate and/c-generate?
|
||||
#:equivalent and-equivalent?))
|
||||
(define-struct (chaperone-and/c base-and/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -162,8 +162,8 @@
|
|||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?
|
||||
#:equivalent and-equivalent?
|
||||
#:generate and/c-generate?))
|
||||
#:generate and/c-generate?
|
||||
#:equivalent and-equivalent?))
|
||||
(define-struct (impersonator-and/c base-and/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
|
|
@ -172,8 +172,8 @@
|
|||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?
|
||||
#:equivalent and-equivalent?
|
||||
#:generate and/c-generate?))
|
||||
#:generate and/c-generate?
|
||||
#:equivalent and-equivalent?))
|
||||
|
||||
(define-syntax (and/c stx)
|
||||
(syntax-case stx (pair? listof)
|
||||
|
|
@ -359,8 +359,8 @@
|
|||
#:name integer-in-name
|
||||
#:first-order integer-in-first-order
|
||||
#:stronger integer-in-stronger
|
||||
#:equivalent integer-in-equivalent
|
||||
#:generate integer-in-generate))
|
||||
#:generate integer-in-generate
|
||||
#:equivalent integer-in-equivalent))
|
||||
|
||||
(struct renamed-integer-in integer-in-ctc (name)
|
||||
#:property prop:flat-contract
|
||||
|
|
@ -389,4 +389,4 @@
|
|||
(set-some-basic-integer-in-contracts! renamed-integer-in
|
||||
(integer-in #f #f)
|
||||
(integer-in 0 #f)
|
||||
(integer-in 1 #f))
|
||||
(integer-in 1 #f))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ code does the parsing and validation of the syntax.
|
|||
|
||||
|#
|
||||
|
||||
;; istx-is-chaperone-contract? : boolean?
|
||||
;; is-chaperone-contract? : boolean?
|
||||
;; args : (listof arg?)
|
||||
;; rst : (or/c #f arg/res?)
|
||||
;; pre : (listof pre/post?)
|
||||
|
|
@ -589,7 +589,7 @@ code does the parsing and validation of the syntax.
|
|||
(format "expected a sequence of variables and an expression to follow ~a"
|
||||
(syntax-e #'kwd))
|
||||
stx #'a))]
|
||||
[(#:post/name (id ...) str post-cond . leftover)
|
||||
[(#:post/name (id ...) str post-cond . pre-leftover)
|
||||
(begin
|
||||
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...)))
|
||||
(syntax-case range (any)
|
||||
|
|
@ -604,7 +604,7 @@ code does the parsing and validation of the syntax.
|
|||
" declaration to be a string")
|
||||
stx
|
||||
#'str))
|
||||
(loop #'leftover
|
||||
(loop #'pre-leftover
|
||||
(cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond
|
||||
(compute-quoted-src-expression #'post-cond))
|
||||
post-conds)))]
|
||||
|
|
|
|||
|
|
@ -674,7 +674,8 @@ evaluted left-to-right.)
|
|||
;; (listof identifier) -- indy-arg/res-vars, bound to wrapped values with indy blame,
|
||||
;; sorted like the second input
|
||||
;; (listof identifier) (listof arg/var) (listof identifier) (listof arg/var)
|
||||
;; the last four inputs are used only to call arg/res-to-indy-var.
|
||||
;; the last four inputs are used only to call arg/res-to-indy-var.
|
||||
;; boolean?
|
||||
;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values,
|
||||
;; with 'body' in the body of the let also handles adding code to check to see if unsupplied
|
||||
;; args are present (skipping the contract check, if so)
|
||||
|
|
@ -1119,6 +1120,7 @@ evaluted left-to-right.)
|
|||
(coerce-chaperone-contract '->i orig-ctc)
|
||||
(coerce-contract '->i orig-ctc)))
|
||||
(((get/build-late-neg-projection ctc) blame) obj neg-party)]))
|
||||
|
||||
(define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?)
|
||||
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?))
|
||||
|
||||
|
|
|
|||
371
racket/collects/racket/contract/private/arrow-collapsible.rkt
Normal file
371
racket/collects/racket/contract/private/arrow-collapsible.rkt
Normal file
|
|
@ -0,0 +1,371 @@
|
|||
#lang racket/base
|
||||
|
||||
;; collapsible arrow contracts
|
||||
;; supports a subset of full arrow contracts
|
||||
;; based on a prototype by Christophe Scholliers
|
||||
|
||||
(require racket/unsafe/ops
|
||||
"collapsible-common.rkt" "merge-cache.rkt"
|
||||
(submod "collapsible-common.rkt" properties)
|
||||
"prop.rkt" "guts.rkt" "misc.rkt" "blame.rkt" "arrow-common.rkt"
|
||||
"arity-checking.rkt"
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide arrow-enter-collapsible-mode/continue
|
||||
arrow-enter-collapsible-mode/collapse
|
||||
val-has-arrow-collapsible-support?
|
||||
->-contract-has-collapsible-support?
|
||||
build-collapsible-arrow)
|
||||
(module+ for-testing
|
||||
(provide collapsible->? collapsible->-doms collapsible->-rng))
|
||||
|
||||
;; General Strategy
|
||||
|
||||
;; Each function contracted with a collapsible contract has two or three
|
||||
;; chaperone wrappers.
|
||||
;; - Functions that are wrapped in a "top-level" arrow contract (i.e., not a
|
||||
;; subcontract of an arrow contract) are first contracted using a regular
|
||||
;; function contract wrapper (before reaching this code). Upon being
|
||||
;; contracted a second time, they reach this code, and get three chaperone
|
||||
;; wrappers:
|
||||
;; - first, an unsafe-chaperone wrapper, which chaperones the current
|
||||
;; contracted value (to pretend it's it), but actually just calls the
|
||||
;; original, uncontracted function (i.e. skips the original contract)
|
||||
;; - second, a chaperone* wrapper, which gets passed the outermost wrapper,
|
||||
;; and looks at a property on it to figure out what to check, then does
|
||||
;; the actual contract checking
|
||||
;; - third, a property-only chaperone wrapper, which has a collapsible contract
|
||||
;; on a property, to keep track of which contracts to check.
|
||||
;; When additional contracts are applied, this third chaperone is swapped out
|
||||
;; for a new one, which keeps track of the new, merged contract to check.
|
||||
;; Because it's a property-only chaperone, replacing it with a new one doesn't
|
||||
;; affect chaperone-of-ness.
|
||||
;; - Functions that are wrapped in an "internal node" arrow contract (i.e.,
|
||||
;; their arrow contract is a subcontract of another arrow contract) may be
|
||||
;; wrapped with collapsible wrappers from the start (i.e., before getting
|
||||
;; any other contract).
|
||||
;; Note: This could be changed. Just avoid recursively converting contracts in
|
||||
;; `ho/c->collapsible->`, and instead have doms and rngs be `ho-leaf/c` always.
|
||||
;; Because of this, they don't need the first, unsafe chaperone wrapper above.
|
||||
;; They only have the last two wrappers, otherwise the above strategy applies.
|
||||
|
||||
;; Alternatively, we may try to attach an (internal node) collapsible
|
||||
;; contract to a value that doesn't support collapsible contracts (e.g.,
|
||||
;; a function that takes keyword arguments). In this case, we must fall back to
|
||||
;; regular contract wrapping, and convert the collapsible contract to a
|
||||
;; regular checking wrapper, as used elsewhere in the contract system (c.f.
|
||||
;; `bail-to-regular-wrapper`).
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Data structures
|
||||
|
||||
;; we store the most recent blame only. when contracts fail, they assign
|
||||
;; blame based on closed-over blame info, so `latest-blame` is only used
|
||||
;; for things like prop:blame, contract profiling, and tail marks, in which
|
||||
;; case we lose information, but it's ok to be conservative in these places
|
||||
;; (and this behavior is consistent with what would happen in the absence
|
||||
;; of collapsible contracts anyway)
|
||||
;; ditto for `latest-ctc` and prop:contracted
|
||||
(struct collapsible-> collapsible-ho/c (doms rng first-order-checks))
|
||||
|
||||
;; contains all the information necessary to both (1) perform first order checks
|
||||
;; for an arrow contract, and (2) determine which such checks are redundant and
|
||||
;; can be eliminated
|
||||
(struct arrow-first-order-check (n-doms blame missing-party method?))
|
||||
;; stronger really means "the same" here
|
||||
(define (arrow-first-order-check-stronger? x y)
|
||||
(= (arrow-first-order-check-n-doms x) (arrow-first-order-check-n-doms y)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Applicability checks
|
||||
|
||||
(define (->-contract-has-collapsible-support? ctc)
|
||||
(define-syntax-rule (bail reason)
|
||||
(begin
|
||||
(log-collapsible-contract-bailout-info (format "arrow: ~a" reason))
|
||||
#f))
|
||||
(cond [(collapsible->? ctc) ; already one
|
||||
#t]
|
||||
[(base->? ctc) ; only applies to regular arrow contracts (for now)
|
||||
(define doms (base->-doms ctc))
|
||||
(define rngs (base->-rngs ctc))
|
||||
(and
|
||||
;; TODO: we can probably handle more of these cases for an -> contract
|
||||
(or doms
|
||||
(bail "no doms"))
|
||||
(or (= (length doms) (base->-min-arity ctc)) ; no optional args
|
||||
(bail "has optional args"))
|
||||
(or (null? (base->-kwd-infos ctc)) ; no keyword args
|
||||
(bail "has keyword args"))
|
||||
(or (not (base->-rest ctc)) ; no rest arg
|
||||
(bail "has rest arg"))
|
||||
(or (not (base->-pre? ctc)) ; no pre-condition
|
||||
(bail "has pre-condition"))
|
||||
(or (not (base->-post? ctc)) ; no post-condition
|
||||
(bail "has post-condition"))
|
||||
(or rngs
|
||||
(bail "no rngs"))
|
||||
(or (= (length rngs) 1)
|
||||
(bail "multiple return values")))]
|
||||
[else
|
||||
(bail "not base arrow")
|
||||
#f]))
|
||||
|
||||
(define (val-has-arrow-collapsible-support? val)
|
||||
(define-syntax-rule (bail reason)
|
||||
(begin
|
||||
(log-collapsible-value-bailout-info (format "arrow: ~a" reason))
|
||||
#f))
|
||||
(and
|
||||
(or (not (procedure-impersonator*? val))
|
||||
(bail "procedure-impersonator*?"))
|
||||
;; the interposition wrapper has to support a superset of the arity
|
||||
;; of the function it's wrapping, and ours can't support optional
|
||||
;; args, keywords, etc. so just bail out in these cases
|
||||
|
||||
;; TODO: I think we can actually support optional arguments without any additional work
|
||||
;; here ... so maybe this check can be removed
|
||||
(or (integer? (procedure-arity val))
|
||||
(bail "has optional args"))
|
||||
(or (let-values ([(man opt) (procedure-keywords val)]) ; no keyword arguments
|
||||
(and (null? man) (null? opt)))
|
||||
(bail "has keyword args"))
|
||||
;; TODO: we can maybe support non single return value functions
|
||||
(or (equal? (procedure-result-arity val) 1)
|
||||
(bail "can't prove single-return-value"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Wrapper management and contract checking
|
||||
|
||||
(define (arrow-collapsible-guard c-c val neg-party)
|
||||
(do-arrow-first-order-checks c-c val neg-party)
|
||||
(define chap-not-imp? (chaperone-collapsible->? c-c))
|
||||
(define prop (get-impersonator-prop:collapsible val #f))
|
||||
(define safe-for-c-c?
|
||||
(if prop
|
||||
(and (collapsible-property? prop)
|
||||
(eq? (collapsible-property-ref prop) val))
|
||||
(val-has-arrow-collapsible-support? val)))
|
||||
(cond
|
||||
[(not safe-for-c-c?) (bail-to-regular-wrapper c-c val neg-party)]
|
||||
[(collapsible-wrapper-property? prop)
|
||||
(arrow-enter-collapsible-mode/continue
|
||||
c-c
|
||||
val
|
||||
neg-party
|
||||
(collapsible-property-c-c prop)
|
||||
(collapsible-property-neg-party prop)
|
||||
(collapsible-wrapper-property-checking-wrapper prop)
|
||||
chap-not-imp?)]
|
||||
[(collapsible-count-property? prop)
|
||||
(arrow-enter-collapsible-mode/collapse
|
||||
c-c
|
||||
val
|
||||
neg-party
|
||||
prop
|
||||
chap-not-imp?)]
|
||||
;; else enter directly
|
||||
[else
|
||||
(arrow-enter-collapsible-mode/direct c-c val neg-party chap-not-imp?)]))
|
||||
|
||||
(define (add-collapsible-arrow-chaperone merged c-c neg-party checking-wrapper chap-not-imp?)
|
||||
(define chap/imp (if chap-not-imp? chaperone-procedure impersonate-procedure))
|
||||
(define c-c-prop
|
||||
(collapsible-wrapper-property merged neg-party #f checking-wrapper))
|
||||
(define wrapped
|
||||
(chap/imp
|
||||
checking-wrapper
|
||||
#f
|
||||
impersonator-prop:collapsible c-c-prop))
|
||||
(set-collapsible-property-ref! c-c-prop wrapped)
|
||||
wrapped)
|
||||
|
||||
|
||||
(define (make-checking-wrapper unwrapped chap-not-imp?)
|
||||
(if chap-not-imp?
|
||||
(chaperone-procedure* unwrapped arrow-wrapper)
|
||||
(impersonate-procedure* unwrapped arrow-wrapper)))
|
||||
|
||||
(define (make-unsafe-checking-wrapper val unwrapped chap-not-imp?)
|
||||
(if chap-not-imp?
|
||||
(chaperone-procedure*
|
||||
(unsafe-chaperone-procedure val unwrapped)
|
||||
arrow-wrapper)
|
||||
(impersonate-procedure*
|
||||
(unsafe-impersonate-procedure val unwrapped)
|
||||
arrow-wrapper)))
|
||||
|
||||
;; If requested, we can log the arities of the contracts that end up being
|
||||
;; collapsible. That can inform whether we should have arity-specific
|
||||
;; wrappers, and if so, for which arities.
|
||||
(define-logger collapsible-contract-arrow-wrapper-arity)
|
||||
|
||||
;; Create the 2nd chaperone wrapper procedure (see comment at the top),
|
||||
;; as well as "deoptimization" wrappers (see below).
|
||||
;; Checking wrappers come in different varieties, along two axes:
|
||||
;; - chaperone vs impersonator (to know how to wrap for subcontracts)
|
||||
;; - where to find the checks (on an impersonator property, for actual
|
||||
;; collapsible contracts, vs closed over, for cases where we need
|
||||
;; a regular contract wrapper (i.e., a subcontract has to "bail out,
|
||||
;; and can't use the collapsible machinery (but since subcontracts
|
||||
;; always start-out as collapsible, they can't bail out via the
|
||||
;; checks in arrow-higher-order, so we need to handle them here)))
|
||||
(define-syntax (make-interposition-procedure stx)
|
||||
(syntax-case stx ()
|
||||
[(_ maybe-closed-over-m/c maybe-closed-over-neg)
|
||||
;; Note: it would be more efficient to have arity-specific wrappers here,
|
||||
;; as opposed to using a rest arg.
|
||||
#`(λ (outermost-chaperone . args)
|
||||
(define-values (m/c neg-party)
|
||||
#,(if (syntax-e #'maybe-closed-over-m/c)
|
||||
#'(values maybe-closed-over-m/c maybe-closed-over-neg)
|
||||
#'(let ()
|
||||
(define prop (get-impersonator-prop:collapsible outermost-chaperone))
|
||||
(values (collapsible-property-c-c prop)
|
||||
(collapsible-property-neg-party prop)))))
|
||||
(define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
|
||||
(define doms (collapsible->-doms m/c))
|
||||
(define rng (collapsible->-rng m/c))
|
||||
(define blame (collapsible-ho/c-latest-blame m/c))
|
||||
(define blame+neg-party (cons blame neg))
|
||||
(define n-args (length args))
|
||||
(define n-doms (length doms))
|
||||
(log-collapsible-contract-arrow-wrapper-arity-info
|
||||
(number->string n-doms))
|
||||
(unless (= n-args n-doms)
|
||||
(raise-wrong-number-of-args-error blame #:missing-party neg outermost-chaperone
|
||||
n-args n-doms n-doms #f))
|
||||
;; Note: to support (i.e., not bail on) functions that can't be proven
|
||||
;; to return a single value, have a `case-lambda` wrapper here. (With
|
||||
;; the possibility of using return-arity-specific wrappers if return
|
||||
;; arity happens to be known.)
|
||||
;; Note: should add tail-marks-match support here.
|
||||
(define rng-checker
|
||||
(lambda (result)
|
||||
(with-collapsible-contract-continuation-mark
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(collapsible-guard rng result neg)))))
|
||||
(apply values
|
||||
rng-checker
|
||||
(for/list ([dom (in-list doms)]
|
||||
[arg (in-list args)])
|
||||
(with-collapsible-contract-continuation-mark
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(collapsible-guard dom arg neg))))))]))
|
||||
|
||||
(define arrow-wrapper (make-interposition-procedure #f #f))
|
||||
|
||||
;; create a regular checking wrapper from a collapsible wrapper for a value
|
||||
;; that can't use collapsible wrapping
|
||||
(define (bail-to-regular-wrapper m/c val neg-party)
|
||||
(define chap-not-imp? (chaperone-collapsible->? m/c))
|
||||
(define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
|
||||
((if chap-not-imp? chaperone-procedure* impersonate-procedure*)
|
||||
val
|
||||
(make-interposition-procedure m/c neg)
|
||||
impersonator-prop:contracted (collapsible-ho/c-latest-ctc m/c)
|
||||
impersonator-prop:blame (cons
|
||||
(collapsible-ho/c-latest-blame m/c)
|
||||
neg)))
|
||||
|
||||
(define (do-arrow-first-order-checks m/c val neg-party)
|
||||
(define checks (collapsible->-first-order-checks m/c))
|
||||
(for ([c (in-list checks)])
|
||||
(define n-doms (arrow-first-order-check-n-doms c))
|
||||
(define partial-blame (arrow-first-order-check-blame c))
|
||||
(define neg (arrow-first-order-check-missing-party c))
|
||||
(cond [(do-arity-checking
|
||||
partial-blame
|
||||
val
|
||||
(for/list ([i (in-range n-doms)]) #f) ; has to have the right length
|
||||
#f ; no rest arg
|
||||
n-doms ; min-arity = max-arity
|
||||
'() ; no keywords
|
||||
(arrow-first-order-check-method? c))
|
||||
=> (lambda (fail) (fail (or neg neg-party)))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; collapsible contract data structure management
|
||||
|
||||
(define (build-collapsible-arrow rng doms ctc blame chap? [maybe-focs #f] [maybe-neg-blame #f])
|
||||
(define focs
|
||||
(or maybe-focs (list (arrow-first-order-check (length doms) blame maybe-neg-blame (base->-method? ctc)))))
|
||||
(if chap?
|
||||
(chaperone-collapsible-> blame maybe-neg-blame ctc doms rng focs)
|
||||
(impersonator-collapsible-> blame maybe-neg-blame ctc doms rng focs)))
|
||||
|
||||
;; merge two collapsible->
|
||||
(define/merge-cache (arrow-try-merge new-collapsible new-neg old-collapsible old-neg)
|
||||
(define constructor (get-constructor new-collapsible old-collapsible))
|
||||
(and constructor
|
||||
(constructor
|
||||
(collapsible-ho/c-latest-blame new-collapsible)
|
||||
(or (collapsible-ho/c-missing-party new-collapsible) new-neg)
|
||||
(collapsible-ho/c-latest-ctc new-collapsible)
|
||||
;; if old and new don't have the same arity, then one of them will *have*
|
||||
;; to fail its first order checks, so we're fine.
|
||||
;; (we don't support optional arguments)
|
||||
(merge-list (collapsible->-doms old-collapsible) old-neg (collapsible->-doms new-collapsible) new-neg)
|
||||
(merge (collapsible->-rng new-collapsible) new-neg (collapsible->-rng old-collapsible) old-neg)
|
||||
(arrow-first-order-merge
|
||||
(collapsible->-first-order-checks new-collapsible) new-neg
|
||||
(collapsible->-first-order-checks old-collapsible) old-neg))))
|
||||
|
||||
(define (merge-list news new-neg olds old-neg)
|
||||
(for/list ([new (in-list news)]
|
||||
[old (in-list olds)])
|
||||
(merge new new-neg old old-neg)))
|
||||
|
||||
(define (arrow-first-order-merge new new-neg old old-neg)
|
||||
(first-order-check-join
|
||||
(add-f-o-neg-party new new-neg)
|
||||
(add-f-o-neg-party old old-neg)
|
||||
arrow-first-order-check-stronger?))
|
||||
|
||||
(define arrow-enter-collapsible-mode/continue
|
||||
(make-enter-collapsible-mode/continue
|
||||
arrow-try-merge
|
||||
add-collapsible-arrow-chaperone
|
||||
bail-to-regular-wrapper))
|
||||
|
||||
(define arrow-enter-collapsible-mode/collapse
|
||||
(make-enter-collapsible-mode/collapse
|
||||
make-unsafe-checking-wrapper
|
||||
add-collapsible-arrow-chaperone
|
||||
arrow-try-merge
|
||||
bail-to-regular-wrapper))
|
||||
|
||||
(define arrow-enter-collapsible-mode/direct
|
||||
(make-enter-collapsible-mode/direct
|
||||
make-checking-wrapper
|
||||
add-collapsible-arrow-chaperone))
|
||||
|
||||
(define (add-f-o-neg-party focs neg-party)
|
||||
(for/list ([foc (in-list focs)])
|
||||
(define missing-party (arrow-first-order-check-missing-party foc))
|
||||
(struct-copy
|
||||
arrow-first-order-check
|
||||
foc
|
||||
[missing-party (or missing-party neg-party)])))
|
||||
|
||||
(define (get-constructor new old)
|
||||
(or (and (chaperone-collapsible->? new)
|
||||
(chaperone-collapsible->? old)
|
||||
chaperone-collapsible->)
|
||||
(and (impersonator-collapsible->? new)
|
||||
(impersonator-collapsible->? old)
|
||||
impersonator-collapsible->)))
|
||||
|
||||
(define (->-collapsible-contract-property chap?)
|
||||
(build-collapsible-contract-property
|
||||
#:try-merge arrow-try-merge
|
||||
#:collapsible-guard arrow-collapsible-guard))
|
||||
|
||||
(struct chaperone-collapsible-> collapsible-> ()
|
||||
#:property prop:collapsible-contract (->-collapsible-contract-property #t))
|
||||
(struct impersonator-collapsible-> collapsible-> ()
|
||||
#:property prop:collapsible-contract (->-collapsible-contract-property #f))
|
||||
|
|
@ -10,6 +10,9 @@
|
|||
"guts.rkt"
|
||||
"list.rkt"
|
||||
(prefix-in arrow: "arrow-common.rkt")
|
||||
"arrow-collapsible.rkt"
|
||||
"collapsible-common.rkt"
|
||||
(submod "collapsible-common.rkt" properties)
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-chaperone-procedure
|
||||
unsafe-impersonate-procedure))
|
||||
|
|
@ -541,6 +544,9 @@
|
|||
min-arity doms kwd-infos rest pre? rngs post?
|
||||
plus-one-arity-function chaperone-constructor method?
|
||||
late-neg?)
|
||||
(define has-c-c-support?
|
||||
(->-contract-has-collapsible-support? ctc))
|
||||
(define chaperone? (not is-impersonator?))
|
||||
(define optionals-length (- (length doms) min-arity))
|
||||
(define mtd? #f) ;; not yet supported for the new contracts
|
||||
(define okay-to-do-only-arity-check?
|
||||
|
|
@ -555,13 +561,18 @@
|
|||
(define rng-blame (arrow:blame-add-range-context orig-blame))
|
||||
(define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
|
||||
|
||||
(define partial-doms
|
||||
(for/list ([dom (in-list doms)]
|
||||
[n (in-naturals 1)])
|
||||
((get/build-late-neg-projection dom)
|
||||
(blame-add-context orig-blame
|
||||
(nth-argument-of (if method? (sub1 n) n))
|
||||
#:swap? #t))))
|
||||
;; if the ctc supports c-c mode, there are only positional args
|
||||
(define-values (partial-doms c-c-doms)
|
||||
(for/lists (projs ses)
|
||||
([dom (in-list doms)]
|
||||
[n (in-naturals 1)])
|
||||
(define dom-blame
|
||||
(blame-add-context orig-blame
|
||||
(nth-argument-of (if method? (sub1 n) n))
|
||||
#:swap? #t))
|
||||
(define prepared (get/build-collapsible-late-neg-projection dom))
|
||||
(prepared dom-blame)))
|
||||
|
||||
(define rest-blame
|
||||
(if (ellipsis-rest-arg-ctc? rest)
|
||||
(blame-swap orig-blame)
|
||||
|
|
@ -570,11 +581,14 @@
|
|||
(define partial-rest (and rest
|
||||
((get/build-late-neg-projection rest)
|
||||
rest-blame)))
|
||||
(define partial-ranges
|
||||
(if rngs
|
||||
(for/list ([rng (in-list rngs)])
|
||||
((get/build-late-neg-projection rng) rng-blame))
|
||||
'()))
|
||||
(define-values (partial-ranges maybe-c-c-ranges)
|
||||
(cond
|
||||
[rngs
|
||||
(for/lists (proj c-c)
|
||||
([rng (in-list rngs)])
|
||||
(define prepared (get/build-collapsible-late-neg-projection rng))
|
||||
(prepared rng-blame))]
|
||||
[else (values '() #f)]))
|
||||
(define partial-kwds
|
||||
(for/list ([kwd-info (in-list kwd-infos)]
|
||||
[kwd (in-list kwd-infos)])
|
||||
|
|
@ -591,7 +605,9 @@
|
|||
[kwd-info (in-list kwd-infos)]
|
||||
#:unless (kwd-info-mandatory? kwd-info))
|
||||
partial-kwd)))
|
||||
|
||||
(define c-c-mergable
|
||||
(and has-c-c-support?
|
||||
(build-collapsible-arrow (car maybe-c-c-ranges) c-c-doms ctc orig-blame chaperone?)))
|
||||
(define the-args (append partial-doms
|
||||
(if partial-rest (list partial-rest) '())
|
||||
man-then-opt-partial-kwds
|
||||
|
|
@ -603,6 +619,17 @@
|
|||
(if partial-rest (list partial-rest) '())))
|
||||
(define blame-party-info (arrow:get-blame-party-info orig-blame))
|
||||
(define (successfully-got-the-right-kind-of-function val neg-party)
|
||||
(define old-c-c-prop (get-impersonator-prop:collapsible val #f))
|
||||
(define safe-for-c-c?
|
||||
(and has-c-c-support?
|
||||
(if old-c-c-prop
|
||||
(and (collapsible-property? old-c-c-prop)
|
||||
(eq? (collapsible-property-ref old-c-c-prop) val))
|
||||
(val-has-arrow-collapsible-support? val))))
|
||||
(define wrapper-count
|
||||
(if (collapsible-count-property? old-c-c-prop)
|
||||
(collapsible-count-property-count old-c-c-prop)
|
||||
0))
|
||||
(define-values (chap/imp-func use-unsafe-chaperone-procedure?)
|
||||
(apply chaperone-constructor
|
||||
orig-blame val
|
||||
|
|
@ -613,21 +640,60 @@
|
|||
(if is-impersonator? unsafe-impersonate-procedure unsafe-chaperone-procedure)
|
||||
(if is-impersonator? impersonate-procedure chaperone-procedure)))
|
||||
(cond
|
||||
[chap/imp-func
|
||||
[(not chap/imp-func)
|
||||
val]
|
||||
[(not safe-for-c-c?)
|
||||
(if (or post? (not rngs))
|
||||
(chaperone-or-impersonate-procedure
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
|
||||
impersonator-prop:blame (cons orig-blame neg-party))
|
||||
(chaperone-or-impersonate-procedure
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
|
||||
impersonator-prop:blame (cons orig-blame neg-party)
|
||||
impersonator-prop:application-mark
|
||||
(cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
|
||||
[else val]))
|
||||
[(wrapper-count . >= . COLLAPSIBLE-LIMIT)
|
||||
(arrow-enter-collapsible-mode/collapse
|
||||
c-c-mergable
|
||||
val
|
||||
neg-party
|
||||
old-c-c-prop
|
||||
chaperone?)]
|
||||
[(collapsible-wrapper-property? old-c-c-prop)
|
||||
(arrow-enter-collapsible-mode/continue
|
||||
c-c-mergable
|
||||
val
|
||||
neg-party
|
||||
(collapsible-property-c-c old-c-c-prop)
|
||||
(collapsible-property-neg-party old-c-c-prop)
|
||||
(collapsible-wrapper-property-checking-wrapper old-c-c-prop)
|
||||
chaperone?)]
|
||||
[else
|
||||
(define c-c-prop
|
||||
(collapsible-count-property
|
||||
c-c-mergable
|
||||
neg-party
|
||||
#f
|
||||
(add1 wrapper-count)
|
||||
(or old-c-c-prop val)))
|
||||
(define wrapped
|
||||
(if (or post? (not rngs))
|
||||
(chaperone-or-impersonate-procedure
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:collapsible c-c-prop)
|
||||
(chaperone-or-impersonate-procedure
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:collapsible c-c-prop
|
||||
impersonator-prop:application-mark
|
||||
(cons arrow:tail-contract-key (list* neg-party blame-party-info rngs)))))
|
||||
(set-collapsible-property-ref! c-c-prop wrapped)
|
||||
wrapped]))
|
||||
(cond
|
||||
[late-neg?
|
||||
(define (arrow-higher-order:lnp val neg-party)
|
||||
|
|
@ -638,12 +704,18 @@
|
|||
(f neg-party))]
|
||||
[else
|
||||
(successfully-got-the-right-kind-of-function val neg-party)]))
|
||||
(if okay-to-do-only-arity-check?
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(arrow:procedure-arity-exactly/no-kwds val min-arity) val]
|
||||
[else (arrow-higher-order:lnp val neg-party)]))
|
||||
arrow-higher-order:lnp)]
|
||||
(cond
|
||||
[okay-to-do-only-arity-check?
|
||||
(define lnp
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(arrow:procedure-arity-exactly/no-kwds val min-arity) val]
|
||||
[else (arrow-higher-order:lnp val neg-party)])))
|
||||
(values lnp (or c-c-mergable (build-collapsible-leaf lnp ctc orig-blame)))]
|
||||
[else
|
||||
(values
|
||||
arrow-higher-order:lnp
|
||||
(or c-c-mergable (build-collapsible-leaf arrow-higher-order:lnp ctc orig-blame)))])]
|
||||
[else
|
||||
(define (arrow-higher-order:vfp val)
|
||||
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
|
||||
|
|
|
|||
|
|
@ -10,6 +10,8 @@
|
|||
"generate.rkt"
|
||||
"arrow-common.rkt"
|
||||
"arrow-higher-order.rkt"
|
||||
"arrow-collapsible.rkt"
|
||||
"collapsible-common.rkt"
|
||||
"list.rkt"
|
||||
racket/stxparam)
|
||||
|
||||
|
|
@ -1543,7 +1545,7 @@
|
|||
(base->-chaperone-constructor ->stct)
|
||||
(base->-method? ->stct)
|
||||
#f)))
|
||||
(define late-neg-proj
|
||||
(define collapsible-late-neg-proj
|
||||
(λ (->stct)
|
||||
(->-proj is-impersonator? ->stct
|
||||
(base->-min-arity ->stct)
|
||||
|
|
@ -1572,7 +1574,7 @@
|
|||
#:generate ->-generate
|
||||
#:exercise ->-exercise
|
||||
#:val-first-projection val-first-proj
|
||||
#:late-neg-projection late-neg-proj))
|
||||
#:collapsible-late-neg-projection collapsible-late-neg-proj))
|
||||
|
||||
(define (->-stronger this that)
|
||||
(and (base->? that)
|
||||
|
|
|
|||
335
racket/collects/racket/contract/private/collapsible-common.rkt
Normal file
335
racket/collects/racket/contract/private/collapsible-common.rkt
Normal file
|
|
@ -0,0 +1,335 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Common functionality used by all collapsible contracts
|
||||
|
||||
(require "prop.rkt" "merge-cache.rkt")
|
||||
|
||||
(provide (struct-out collapsible-ho/c)
|
||||
(struct-out collapsible-leaf/c)
|
||||
(struct-out collapsible-property)
|
||||
(struct-out collapsible-count-property)
|
||||
(struct-out collapsible-wrapper-property)
|
||||
build-collapsible-leaf
|
||||
prop:collapsible-contract
|
||||
collapsible-contract-property?
|
||||
build-collapsible-contract-property
|
||||
collapsible-contract-property?
|
||||
collapsible-contract?
|
||||
merge
|
||||
collapsible-guard
|
||||
first-order-check-join
|
||||
log-collapsible-value-bailout-info
|
||||
log-collapsible-contract-bailout-info
|
||||
log-collapsible-cache-fail-info
|
||||
make-enter-collapsible-mode/continue
|
||||
make-enter-collapsible-mode/collapse
|
||||
make-enter-collapsible-mode/direct
|
||||
COLLAPSIBLE-LIMIT)
|
||||
|
||||
(module+ for-testing
|
||||
(provide collapsible-leaf/c?
|
||||
collapsible-leaf/c-contract-list
|
||||
collapsible-leaf/c-proj-list
|
||||
collapsible-property-c-c
|
||||
collapsible-property-ref
|
||||
has-impersonator-prop:collapsible?
|
||||
get-impersonator-prop:collapsible
|
||||
collapsible-wrapper-property?
|
||||
collapsible-wrapper-property-checking-wrapper
|
||||
calculate-drops))
|
||||
|
||||
;; object contracts need to propagate properties across procedure->method
|
||||
(module+ properties
|
||||
(provide impersonator-prop:collapsible
|
||||
has-impersonator-prop:collapsible?
|
||||
get-impersonator-prop:collapsible))
|
||||
|
||||
(define-logger collapsible-value-bailout)
|
||||
(define-logger collapsible-contract-bailout)
|
||||
(define-logger collapsible-merging)
|
||||
(define-logger collapsible-cache-fail)
|
||||
|
||||
(define COLLAPSIBLE-LIMIT 10)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Properties
|
||||
(define-values (impersonator-prop:collapsible
|
||||
has-impersonator-prop:collapsible?
|
||||
get-impersonator-prop:collapsible)
|
||||
(make-impersonator-property 'impersonator-prop:collapsible))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; An interface for collapsible contract conversion and merging
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(struct collapsible-contract-property
|
||||
(try-merge
|
||||
collapsible-guard)
|
||||
#:omit-define-syntaxes)
|
||||
|
||||
(define (collapsible-contract-property-guard prop info)
|
||||
(unless (collapsible-contract-property? prop)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(format "~a: expected a collapsible contract property; got: ~e"
|
||||
prop)
|
||||
(current-continuation-marks))))
|
||||
prop)
|
||||
|
||||
(define-values (prop:collapsible-contract collapsible-contract? get-collapsible-contract-property)
|
||||
(make-struct-type-property 'collapsible-contract collapsible-contract-property-guard))
|
||||
|
||||
(define (build-collapsible-contract-property
|
||||
#:try-merge [try-merge #f]
|
||||
#:collapsible-guard
|
||||
[collapsible-guard
|
||||
(lambda (ctc val neg)
|
||||
(error "internal error: contract does not support `collapsible-guard`" ctc))])
|
||||
(collapsible-contract-property
|
||||
(or try-merge (lambda (_1 _2 _3 _4) #f))
|
||||
collapsible-guard))
|
||||
|
||||
;; Parent structure for higher order collapsible contracts
|
||||
;; which must keep track of the latest blame and missing party
|
||||
;; and latest contract applied
|
||||
(struct collapsible-ho/c (latest-blame missing-party latest-ctc))
|
||||
|
||||
(struct collapsible-leaf/c (proj-list contract-list blame-list missing-party-list)
|
||||
#:property prop:collapsible-contract
|
||||
(build-collapsible-contract-property
|
||||
#:try-merge (lambda (new new-neg old old-neg)
|
||||
(and (collapsible-leaf/c? old)
|
||||
(collapsible-leaf/c? new)
|
||||
(join-collapsible-leaf/c new new-neg old old-neg)))
|
||||
#:collapsible-guard
|
||||
(lambda (c-c val neg-party)
|
||||
(apply-proj-list (collapsible-leaf/c-proj-list c-c)
|
||||
(collapsible-leaf/c-missing-party-list c-c)
|
||||
val
|
||||
neg-party))))
|
||||
|
||||
(define (build-collapsible-leaf proj ctc blame)
|
||||
(collapsible-leaf/c (list proj) (list ctc) (list blame) (list #f)))
|
||||
|
||||
;; Allow the bailout to be passed as an optional to avoid
|
||||
;; an extra indirection through the property when possible
|
||||
(define (collapsible->leaf c neg-party [bail #f])
|
||||
(cond
|
||||
[(collapsible-leaf/c? c) c]
|
||||
[else
|
||||
(define bailout (or bail (get-bail c)))
|
||||
(collapsible-leaf/c
|
||||
(list bailout)
|
||||
(list #f) ;; Bail out of ctc comparison when we see #f
|
||||
(list (collapsible-ho/c-latest-blame c))
|
||||
(list neg-party))]))
|
||||
|
||||
;; Apply a list of projections over a value
|
||||
(define (apply-proj-list proj-list missing-parties val neg-party)
|
||||
(for/fold ([val* val])
|
||||
([proj (in-list proj-list)]
|
||||
[missing-party (in-list missing-parties)])
|
||||
(proj val* (or missing-party neg-party))))
|
||||
|
||||
;; checks whether the contract c is already implied by one of the
|
||||
;; contracts in contract-list
|
||||
(define (implied-by-one? contract-list c #:implies implies)
|
||||
(for/or ([e (in-list contract-list)])
|
||||
(implies e c)))
|
||||
|
||||
(define (leaf-implied-by-one? contract-list new-ctc)
|
||||
(and new-ctc
|
||||
(for/or ([old-ctc (in-list contract-list)])
|
||||
(and old-ctc
|
||||
(flat-contract-struct? new-ctc)
|
||||
(contract-struct-stronger? old-ctc new-ctc)))))
|
||||
|
||||
;; join two collapsible-leaf contracts
|
||||
(define (join-collapsible-leaf/c new-collapsible new-neg old-collapsible old-neg)
|
||||
(define new-proj-list (collapsible-leaf/c-proj-list new-collapsible))
|
||||
(define new-flat-list (collapsible-leaf/c-contract-list new-collapsible))
|
||||
(define new-blame-list (collapsible-leaf/c-blame-list new-collapsible))
|
||||
(define new-missing-party-list (collapsible-leaf/c-missing-party-list new-collapsible))
|
||||
(define old-proj-list (collapsible-leaf/c-proj-list old-collapsible))
|
||||
(define old-flat-list (collapsible-leaf/c-contract-list old-collapsible))
|
||||
(define old-blame-list (collapsible-leaf/c-blame-list old-collapsible))
|
||||
;; We have to traverse the list to add the new neg party where it is missing
|
||||
(define old-missing-party-list (add-missing-parties (collapsible-leaf/c-missing-party-list old-collapsible) old-neg))
|
||||
(define-values (not-implied-projs not-implied-flats not-implied-blames not-implied-missing-parties)
|
||||
(for/lists (_1 _2 _3 _4) ([new-proj (in-list new-proj-list)]
|
||||
[new-flat (in-list new-flat-list)]
|
||||
[new-blame (in-list new-blame-list)]
|
||||
[new-missing-party (in-list new-missing-party-list)]
|
||||
#:when (not (leaf-implied-by-one? old-flat-list new-flat)))
|
||||
(values new-proj new-flat new-blame (or new-missing-party new-neg))))
|
||||
(define res-flats (fast-append old-flat-list not-implied-flats))
|
||||
(define res-blames (fast-append old-blame-list not-implied-blames))
|
||||
(define res-missings (fast-append old-missing-party-list not-implied-missing-parties))
|
||||
(define res-projs (fast-append old-proj-list not-implied-projs))
|
||||
(define-values (pruned-projs pruned-flats pruned-blames pruned-missings)
|
||||
(prune res-projs res-flats res-blames res-missings))
|
||||
(collapsible-leaf/c pruned-projs pruned-flats pruned-blames pruned-missings))
|
||||
|
||||
(define (add-missing-parties missing-parties new-neg-party)
|
||||
(for/list ([neg-party (in-list missing-parties)])
|
||||
(or neg-party new-neg-party)))
|
||||
|
||||
(define (calculate-drops flats)
|
||||
(define-values (to-drop _1 _2)
|
||||
(for/fold ([indices '()]
|
||||
[seen (hasheq)]
|
||||
[maybe-drop (hasheq)])
|
||||
([flat (in-list flats)]
|
||||
[i (in-naturals)])
|
||||
(cond
|
||||
[(or (flat-contract-struct? flat) (chaperone-contract-struct? flat))
|
||||
(cond
|
||||
[(hash-ref seen flat #f)
|
||||
(define maybe-index (hash-ref maybe-drop flat #f))
|
||||
(cond
|
||||
[maybe-index
|
||||
(define new-maybe-drop (hash-set maybe-drop flat i))
|
||||
(values (cons maybe-index indices) seen new-maybe-drop)]
|
||||
[else
|
||||
(define new-maybe-drop (hash-set maybe-drop flat i))
|
||||
(values indices seen new-maybe-drop)])]
|
||||
[else
|
||||
(define new-seen (hash-set seen flat #t))
|
||||
(values indices new-seen maybe-drop)])]
|
||||
[else
|
||||
(values indices seen maybe-drop)])))
|
||||
to-drop)
|
||||
|
||||
(define (prune projs flats blames missings)
|
||||
(cond
|
||||
[((length flats) . <= . 10)
|
||||
(define to-drop (calculate-drops flats))
|
||||
(for/lists (_1 _2 _3 _4) ([proj (in-list projs)]
|
||||
[flat (in-list flats)]
|
||||
[blame (in-list blames)]
|
||||
[missing (in-list missings)]
|
||||
[i (in-naturals)]
|
||||
#:when (not (memv i to-drop)))
|
||||
(values proj flat blame missing))]
|
||||
[else (values projs flats blames missings)]))
|
||||
|
||||
;; A specialized version of append that will immediately return if either
|
||||
;; argument is empty
|
||||
(define (fast-append l1 l2)
|
||||
(cond
|
||||
[(null? l2) l1]
|
||||
[(null? l1) l2]
|
||||
[else
|
||||
(cons (car l1) (fast-append (cdr l1) l2))]))
|
||||
|
||||
;; Assuming that merging is symmetric, ie old-can-merge? iff new-can-merge?
|
||||
;; This is true of the current c-c implementation, but if it ever changes
|
||||
;; this function will neef to check both directions for merging
|
||||
(define/merge-cache (merge new-c-c new-neg old-c-c old-neg)
|
||||
(define-values (new-try-merge new-proj) (get-merge-components new-c-c))
|
||||
(define-values (_ old-proj) (get-merge-components old-c-c))
|
||||
(or (new-try-merge new-c-c new-neg old-c-c old-neg)
|
||||
(join-collapsible-leaf/c (collapsible->leaf new-c-c new-neg new-proj)
|
||||
new-neg
|
||||
(collapsible->leaf old-c-c old-neg old-proj)
|
||||
old-neg)))
|
||||
|
||||
(define (get-merge-components collapsible)
|
||||
(define prop (get-collapsible-contract-property collapsible))
|
||||
(define guard (collapsible-contract-property-collapsible-guard prop))
|
||||
(values
|
||||
(collapsible-contract-property-try-merge prop)
|
||||
;; FIXME: don't really want to build a lambda here ...
|
||||
(λ (val neg) (guard collapsible val neg))))
|
||||
|
||||
(define (collapsible-guard collapsible val neg-party)
|
||||
(define prop (get-collapsible-contract-property collapsible))
|
||||
(define guard (collapsible-contract-property-collapsible-guard prop))
|
||||
(guard collapsible val neg-party))
|
||||
|
||||
(define (get-bail collapsible)
|
||||
(define prop (collapsible-contract-property collapsible))
|
||||
(define guard (collapsible-contract-property-collapsible-guard prop))
|
||||
;; FIXME: don't really want to build this lambda ...
|
||||
(λ (val neg) (guard collapsible val neg)))
|
||||
|
||||
(define (first-order-check-join new-checks old-checks stronger?)
|
||||
(fast-append old-checks
|
||||
|
||||
(for/list ([new (in-list new-checks)]
|
||||
#:when (not (implied-by-one?
|
||||
old-checks new
|
||||
#:implies stronger?)))
|
||||
new)))
|
||||
|
||||
(struct collapsible-property (c-c neg-party [ref #:mutable]))
|
||||
(struct collapsible-count-property collapsible-property (count prev))
|
||||
(struct collapsible-wrapper-property collapsible-property (checking-wrapper))
|
||||
|
||||
;; A Collapsible-Property is one of
|
||||
;; - (collapsible-count-property collapsible?
|
||||
;; neg-party?
|
||||
;; impersonator?
|
||||
;; natural-number/c
|
||||
;; (or/c collapsible-count-property?
|
||||
;; (not/c collapsible-count-property?)))
|
||||
;; a count of the contracts currently attached to the value along with other
|
||||
;; necessary collapsible information
|
||||
;; - (collapsible-wrapper-property collapsible? neg-party? impersonator? impersonator?)
|
||||
;; indicates this value is in collapsible mode, holds the attached collapsible contract,
|
||||
;; the most recent neg-party, a pointer to the
|
||||
;; last known collapsible wrapper, and the checking wrapper that has
|
||||
;; the collapsible interposition functions
|
||||
|
||||
(define (make-enter-collapsible-mode/direct
|
||||
make-checking-wrapper
|
||||
add-c-c-chaperone)
|
||||
(λ (c-c val neg-party chap-not-imp?)
|
||||
(define checking-wrapper (make-checking-wrapper val chap-not-imp?))
|
||||
(add-c-c-chaperone c-c c-c neg-party checking-wrapper chap-not-imp?)))
|
||||
|
||||
(define (make-enter-collapsible-mode/continue
|
||||
try-merge
|
||||
add-c-c-chaperone
|
||||
bail)
|
||||
(λ (new-c-c val new-neg-party c-c neg-party checking-wrapper chap-not-imp?)
|
||||
(define merged-c-c (try-merge new-c-c new-neg-party c-c neg-party))
|
||||
(cond
|
||||
[merged-c-c
|
||||
;; Passing #f as the new-neg seems ugly, need to do more to fix this plumbing
|
||||
(add-c-c-chaperone merged-c-c new-c-c #f checking-wrapper chap-not-imp?)]
|
||||
[else (bail new-c-c val new-neg-party)])))
|
||||
|
||||
(define (make-enter-collapsible-mode/collapse
|
||||
make-unsafe-checking-wrapper
|
||||
add-c-c-chaperone
|
||||
try-merge
|
||||
bail)
|
||||
(λ (c-c val neg-party c-c-prop chap-not-imp?)
|
||||
(define-values (merged-c-c checking-wrapper)
|
||||
(let loop ([left c-c]
|
||||
[left-neg neg-party]
|
||||
[prop c-c-prop])
|
||||
(cond
|
||||
[left
|
||||
(define right (collapsible-property-c-c prop))
|
||||
(define right-neg (collapsible-property-neg-party prop))
|
||||
(define prev (collapsible-count-property-prev prop))
|
||||
(define merged (try-merge left left-neg right right-neg))
|
||||
(cond
|
||||
;; there is another contract underneath this one
|
||||
[(collapsible-count-property? prev)
|
||||
(loop merged #f prev)]
|
||||
;; we've reached the bottom of the contract stack
|
||||
[else
|
||||
(define checking-wrapper
|
||||
(make-unsafe-checking-wrapper val prev chap-not-imp?))
|
||||
(values merged checking-wrapper)])]
|
||||
;; a merge failed, so we should return immediately
|
||||
;; indicating the failure
|
||||
[else (values #f #f)])))
|
||||
(cond
|
||||
[merged-c-c
|
||||
(add-c-c-chaperone merged-c-c c-c neg-party checking-wrapper chap-not-imp?)]
|
||||
[else (bail c-c val neg-party)])))
|
||||
|
|
@ -5,6 +5,8 @@
|
|||
"prop.rkt"
|
||||
"rand.rkt"
|
||||
"generate-base.rkt"
|
||||
"collapsible-common.rkt"
|
||||
(submod "collapsible-common.rkt" properties)
|
||||
"../../private/math-predicates.rkt"
|
||||
racket/pretty
|
||||
racket/list
|
||||
|
|
@ -24,12 +26,14 @@
|
|||
contract-stronger?
|
||||
contract-equivalent?
|
||||
list-contract?
|
||||
|
||||
|
||||
contract-first-order
|
||||
contract-first-order-passes?
|
||||
|
||||
prop:contracted prop:blame
|
||||
impersonator-prop:contracted impersonator-prop:blame
|
||||
impersonator-prop:contracted
|
||||
impersonator-prop:blame
|
||||
|
||||
has-contract? value-contract
|
||||
has-blame? value-blame
|
||||
|
||||
|
|
@ -57,6 +61,8 @@
|
|||
|
||||
contract-continuation-mark-key
|
||||
with-contract-continuation-mark
|
||||
collapsible-contract-continuation-mark-key
|
||||
with-collapsible-contract-continuation-mark
|
||||
|
||||
(struct-out wrapped-extra-arg-arrow)
|
||||
contract-custom-write-property-proc
|
||||
|
|
@ -67,6 +73,7 @@
|
|||
contract-late-neg-projection ;; might return #f (if none)
|
||||
get/build-val-first-projection ;; builds one if necc., using contract-projection
|
||||
get/build-late-neg-projection
|
||||
get/build-collapsible-late-neg-projection
|
||||
warn-about-val-first?
|
||||
|
||||
contract-name
|
||||
|
|
@ -90,7 +97,8 @@
|
|||
false/c-contract
|
||||
true/c-contract
|
||||
|
||||
contract-pos/neg-doubling)
|
||||
contract-pos/neg-doubling
|
||||
contract-pos/neg-doubling.2)
|
||||
|
||||
(define (contract-custom-write-property-proc stct port mode)
|
||||
(define (write-prefix)
|
||||
|
|
@ -153,7 +161,9 @@
|
|||
|
||||
(define (has-contract? v)
|
||||
(or (has-prop:contracted? v)
|
||||
(has-impersonator-prop:contracted? v)))
|
||||
(has-impersonator-prop:contracted? v)
|
||||
;; TODO: I think this is the right check, but I'm not positive
|
||||
(has-impersonator-prop:collapsible? v)))
|
||||
|
||||
(define (value-contract v)
|
||||
(cond
|
||||
|
|
@ -161,11 +171,17 @@
|
|||
(get-prop:contracted v)]
|
||||
[(has-impersonator-prop:contracted? v)
|
||||
(get-impersonator-prop:contracted v)]
|
||||
[(get-impersonator-prop:collapsible v #f)
|
||||
=>
|
||||
(λ (p)
|
||||
(collapsible-ho/c-latest-ctc (collapsible-property-c-c p)))]
|
||||
[else #f]))
|
||||
|
||||
(define (has-blame? v)
|
||||
(or (has-prop:blame? v)
|
||||
(has-impersonator-prop:blame? v)))
|
||||
(has-impersonator-prop:blame? v)
|
||||
;; TODO: I think this check is ok, but I'm not sure ...
|
||||
(has-impersonator-prop:collapsible? v)))
|
||||
|
||||
(define (value-blame v)
|
||||
(define bv
|
||||
|
|
@ -174,6 +190,13 @@
|
|||
(get-prop:blame v)]
|
||||
[(has-impersonator-prop:blame? v)
|
||||
(get-impersonator-prop:blame v)]
|
||||
[(get-impersonator-prop:collapsible v #f)
|
||||
=>
|
||||
(λ (p)
|
||||
(define c-c (collapsible-property-c-c p))
|
||||
(cons
|
||||
(collapsible-ho/c-latest-blame c-c)
|
||||
(or (collapsible-ho/c-missing-party c-c) (collapsible-property-neg-party p))))]
|
||||
[else #f]))
|
||||
(cond
|
||||
[(and (pair? bv) (blame? (car bv)))
|
||||
|
|
@ -397,7 +420,8 @@
|
|||
name)
|
||||
x
|
||||
#f
|
||||
(memq x the-known-good-contracts))])]
|
||||
(or (struct-predicate-procedure? x)
|
||||
(memq x the-known-good-contracts)))])]
|
||||
[(null? x)
|
||||
(unless list/c-empty
|
||||
(error 'coerce-contract/f::list/c-empty "too soon!"))
|
||||
|
|
@ -792,12 +816,27 @@
|
|||
|
||||
(define-logger racket/contract)
|
||||
|
||||
(define (get/build-collapsible-late-neg-projection ctc)
|
||||
(cond
|
||||
[(contract-struct-collapsible-late-neg-projection ctc) => values]
|
||||
[else
|
||||
(define lnp (get/build-late-neg-projection ctc))
|
||||
(λ (blame)
|
||||
(define proj (lnp blame))
|
||||
(values proj
|
||||
(build-collapsible-leaf proj ctc blame)))]))
|
||||
|
||||
(define (get/build-late-neg-projection ctc)
|
||||
(cond
|
||||
[(contract-struct-late-neg-projection ctc) => values]
|
||||
[else
|
||||
(log-racket/contract-info "no late-neg-projection for ~s" ctc)
|
||||
(cond
|
||||
[(contract-struct-collapsible-late-neg-projection ctc) =>
|
||||
(lambda (f)
|
||||
(lambda (blame)
|
||||
(define-values (proj _) (f blame))
|
||||
proj))]
|
||||
[(contract-struct-projection ctc)
|
||||
=>
|
||||
(λ (projection)
|
||||
|
|
@ -809,7 +848,7 @@
|
|||
[else
|
||||
(first-order->late-neg-projection (contract-struct-first-order ctc)
|
||||
(contract-struct-name ctc))])]))
|
||||
|
||||
|
||||
(define (projection->late-neg-projection proj)
|
||||
(λ (b)
|
||||
(λ (x neg-party)
|
||||
|
|
@ -914,6 +953,13 @@
|
|||
(with-continuation-mark contract-continuation-mark-key payload
|
||||
(let () code ...))))
|
||||
|
||||
(define collapsible-contract-continuation-mark-key
|
||||
(make-continuation-mark-key 'collapsible-contract))
|
||||
|
||||
(define-syntax-rule (with-collapsible-contract-continuation-mark code ...)
|
||||
(with-continuation-mark collapsible-contract-continuation-mark-key #t
|
||||
(let () code ...)))
|
||||
|
||||
(define (n->th n)
|
||||
(string-append
|
||||
(number->string n)
|
||||
|
|
@ -954,6 +1000,9 @@
|
|||
(define-syntax-rule
|
||||
(contract-pos/neg-doubling e1 e2)
|
||||
(contract-pos/neg-doubling/proc (λ () e1) (λ () e2)))
|
||||
(define-syntax-rule
|
||||
(contract-pos/neg-doubling.2 e1 e2)
|
||||
(contract-pos/neg-doubling.2/proc (λ () e1) (λ () e2)))
|
||||
(define doubling-cm-key (gensym 'racket/contract-doubling-mark))
|
||||
(define (contract-pos/neg-doubling/proc t1 t2)
|
||||
(define depth
|
||||
|
|
@ -965,4 +1014,18 @@
|
|||
(values #f t1 t2)]
|
||||
[else
|
||||
(with-continuation-mark doubling-cm-key (+ depth 1)
|
||||
(values #t (t1) (t2)))]))
|
||||
(values #t (t1) (t2)))]))
|
||||
(define (contract-pos/neg-doubling.2/proc t1 t2)
|
||||
(define depth
|
||||
(or (continuation-mark-set-first (current-continuation-marks)
|
||||
doubling-cm-key)
|
||||
0))
|
||||
(cond
|
||||
[(> depth 5)
|
||||
(values #f t1 #f t2 #f)]
|
||||
[else
|
||||
(with-continuation-mark doubling-cm-key (+ depth 1)
|
||||
(let ()
|
||||
(define-values (t11 t12) (t1))
|
||||
(define-values (t21 t22) (t2))
|
||||
(values #t t11 t12 t21 t22)))]))
|
||||
|
|
|
|||
|
|
@ -332,25 +332,25 @@
|
|||
val
|
||||
(λ (h k)
|
||||
(values (with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(neg-dom-proj k neg-party))
|
||||
blame+neg-party
|
||||
(neg-dom-proj k neg-party))
|
||||
(λ (h k v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((mk-pos-rng-proj k) v neg-party)))))
|
||||
blame+neg-party
|
||||
((mk-pos-rng-proj k) v neg-party)))))
|
||||
(λ (h k v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(values (neg-dom-proj k neg-party)
|
||||
((mk-neg-rng-proj k) v neg-party))))
|
||||
blame+neg-party
|
||||
(values (neg-dom-proj k neg-party)
|
||||
((mk-neg-rng-proj k) v neg-party))))
|
||||
(λ (h k)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(neg-dom-proj k neg-party)))
|
||||
blame+neg-party
|
||||
(neg-dom-proj k neg-party)))
|
||||
(λ (h k)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(pos-dom-proj k neg-party)))
|
||||
blame+neg-party
|
||||
(pos-dom-proj k neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1006,7 +1006,7 @@
|
|||
blame
|
||||
val
|
||||
'(expected: "list?" given: "~e") val)]))))
|
||||
|
||||
|
||||
;; prefix : contract
|
||||
;; suffix : (listof contract)
|
||||
(struct *list-ctc (prefix suffix)
|
||||
|
|
|
|||
60
racket/collects/racket/contract/private/merge-cache.rkt
Normal file
60
racket/collects/racket/contract/private/merge-cache.rkt
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide define/merge-cache)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
;; weak hashtable never cleared
|
||||
(define MERGE-CACHE (make-thread-cell (make-weak-hasheq)))
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(define-syntax (define/merge-cache stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (merge-name new-se new-neg old-se old-neg) body ...)
|
||||
#'(define (merge-name new-se new-neg old-se old-neg)
|
||||
(call-with-merge-cache new-se new-neg old-se old-neg
|
||||
(let ([merge-name (λ () body ...)])
|
||||
merge-name)))]))
|
||||
|
||||
(define (call-with-merge-cache new-se new-neg old-se old-neg body-thunk)
|
||||
(define the-cache (thread-cell-ref MERGE-CACHE))
|
||||
(define h1 (hash-ref the-cache new-se #f))
|
||||
(cond
|
||||
[(and h1 (ephemeron-value h1))
|
||||
=>
|
||||
(λ (h1)
|
||||
(define h2 (hash-ref h1 new-neg #f))
|
||||
(cond
|
||||
[(and h2 (ephemeron-value h2))
|
||||
=>
|
||||
(λ (h2)
|
||||
(define h3 (hash-ref h2 old-se #f))
|
||||
(cond
|
||||
[(and h3 (ephemeron-value h3))
|
||||
=>
|
||||
(λ (h3)
|
||||
(define cached-result (hash-ref h3 old-neg #f))
|
||||
(cond
|
||||
[(ephemeron-value cached-result) => values]
|
||||
[else
|
||||
(define result (body-thunk))
|
||||
(hash-set! h3 old-neg (make-ephemeron old-neg result))
|
||||
result]))]
|
||||
[else
|
||||
(define result (body-thunk))
|
||||
(define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
|
||||
(hash-set! h2 old-se (make-ephemeron old-se h3))
|
||||
result]))]
|
||||
[else
|
||||
(define result (body-thunk))
|
||||
(define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
|
||||
(define h2 (make-hasheq (list (cons old-se (make-ephemeron old-se h3)))))
|
||||
(hash-set! h1 new-neg (make-ephemeron new-neg h2))
|
||||
result]))]
|
||||
[else
|
||||
(define result (body-thunk))
|
||||
(define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
|
||||
(define h2 (make-hasheq (list (cons old-se (make-ephemeron old-se h3)))))
|
||||
(define h1 (make-hasheq (list (cons new-neg (make-ephemeron new-neg h2)))))
|
||||
(hash-set! the-cache new-se (make-ephemeron new-se h1))
|
||||
result]))
|
||||
|
|
@ -477,6 +477,7 @@
|
|||
#:stronger promise-ctc-stronger?
|
||||
#:equivalent promise-ctc-equivalent?
|
||||
#:first-order (λ (ctc) promise?)))
|
||||
|
||||
(struct promise-ctc promise-base-ctc ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
|
|
@ -524,6 +525,7 @@
|
|||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(f x neg-party))))
|
||||
;; TODO this ought to have the `contracted` property, but it's not a chaperone...
|
||||
(make-derived-parameter
|
||||
val
|
||||
(add-profiling in-proj)
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@
|
|||
(barrier/c negative? var)))
|
||||
(define protector
|
||||
(apply (polymorphic-contract-body c) instances))
|
||||
(((get/build-late-neg-projection protector) blame) p neg-party)))
|
||||
(((get/build-late-neg-projection protector) blame) p neg-party)))
|
||||
|
||||
(lambda (p neg-party)
|
||||
(unless (procedure? p)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
contract-struct-projection
|
||||
contract-struct-val-first-projection
|
||||
contract-struct-late-neg-projection
|
||||
contract-struct-collapsible-late-neg-projection
|
||||
contract-struct-stronger?
|
||||
contract-struct-equivalent?
|
||||
contract-struct-generate
|
||||
|
|
@ -68,6 +69,7 @@
|
|||
exercise
|
||||
val-first-projection
|
||||
late-neg-projection
|
||||
collapsible-late-neg-projection
|
||||
list-contract? ]
|
||||
#:omit-define-syntaxes)
|
||||
|
||||
|
|
@ -113,6 +115,12 @@
|
|||
(and get-projection
|
||||
(get-projection c)))
|
||||
|
||||
(define (contract-struct-collapsible-late-neg-projection c)
|
||||
(define prop (contract-struct-property c))
|
||||
(define get-collapsible-projection (contract-property-collapsible-late-neg-projection prop))
|
||||
(and get-collapsible-projection
|
||||
(get-collapsible-projection c)))
|
||||
|
||||
(define (contract-struct-stronger/equivalent?
|
||||
a b
|
||||
trail
|
||||
|
|
@ -296,6 +304,7 @@
|
|||
#:projection [get-projection #f]
|
||||
#:val-first-projection [get-val-first-projection #f]
|
||||
#:late-neg-projection [get-late-neg-projection #f]
|
||||
#:collapsible-late-neg-projection [get-collapsible-late-neg-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:equivalent [equivalent #f]
|
||||
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
||||
|
|
@ -312,12 +321,14 @@
|
|||
" #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order"
|
||||
" argument to not be #f, but all four were #f")))
|
||||
|
||||
;; TODO: update for collapsible late-neg-projection
|
||||
(unless get-late-neg-projection
|
||||
(unless first-order?
|
||||
(log-racket/contract-info
|
||||
"no late-neg-projection passed to ~s~a"
|
||||
proc-name
|
||||
(build-context))))
|
||||
(unless get-collapsible-late-neg-projection
|
||||
(unless first-order?
|
||||
(log-racket/contract-info
|
||||
"no late-neg-projection passed to ~s~a"
|
||||
proc-name
|
||||
(build-context)))))
|
||||
|
||||
(unless (and (procedure? list-contract?)
|
||||
(procedure-arity-includes? list-contract? 1))
|
||||
|
|
@ -344,6 +355,7 @@
|
|||
(λ (c) (late-neg-first-order-projection (get-name c) (get-first-order c)))]
|
||||
[else #f])]
|
||||
[else get-late-neg-projection])
|
||||
get-collapsible-late-neg-projection
|
||||
list-contract?))
|
||||
|
||||
(define (build-context)
|
||||
|
|
@ -406,7 +418,8 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct make-contract [ name first-order projection
|
||||
val-first-projection late-neg-projection
|
||||
val-first-projection late-neg-projection
|
||||
collapsible-late-neg-projection
|
||||
stronger equivalent generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
|
|
@ -421,6 +434,7 @@
|
|||
#:projection (lambda (c) (make-contract-projection c))
|
||||
#:val-first-projection (lambda (c) (make-contract-val-first-projection c))
|
||||
#:late-neg-projection (lambda (c) (make-contract-late-neg-projection c))
|
||||
#:collapsible-late-neg-projection (lambda (c) (make-contract-collapsible-late-neg-projection c))
|
||||
#:stronger (lambda (a b) ((make-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-contract-generate c))
|
||||
#:exercise (lambda (c) (make-contract-exercise c))
|
||||
|
|
@ -428,6 +442,7 @@
|
|||
|
||||
(define-struct make-chaperone-contract [ name first-order projection
|
||||
val-first-projection late-neg-projection
|
||||
collapsible-late-neg-projection
|
||||
stronger equivalent generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
|
|
@ -442,6 +457,7 @@
|
|||
#:projection (lambda (c) (make-chaperone-contract-projection c))
|
||||
#:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c))
|
||||
#:late-neg-projection (lambda (c) (make-chaperone-contract-late-neg-projection c))
|
||||
#:collapsible-late-neg-projection (lambda (c) (make-chaperone-contract-collapsible-late-neg-projection c))
|
||||
#:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-chaperone-contract-generate c))
|
||||
#:exercise (lambda (c) (make-chaperone-contract-exercise c))
|
||||
|
|
@ -449,6 +465,7 @@
|
|||
|
||||
(define-struct make-flat-contract [ name first-order projection
|
||||
val-first-projection late-neg-projection
|
||||
collapsible-late-neg-projection
|
||||
stronger equivalent generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
|
|
@ -462,6 +479,7 @@
|
|||
#:first-order (lambda (c) (make-flat-contract-first-order c))
|
||||
#:val-first-projection (λ (c) (make-flat-contract-val-first-projection c))
|
||||
#:late-neg-projection (λ (c) (make-flat-contract-late-neg-projection c))
|
||||
#:collapsible-late-neg-projection (lambda (c) (make-flat-contract-collapsible-late-neg-projection c))
|
||||
#:projection (lambda (c) (make-flat-contract-projection c))
|
||||
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-flat-contract-generate c))
|
||||
|
|
@ -474,6 +492,7 @@
|
|||
#:projection [projection #f]
|
||||
#:val-first-projection [val-first-projection #f]
|
||||
#:late-neg-projection [late-neg-projection #f]
|
||||
#:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:equivalent [equivalent #f]
|
||||
#:generate [generate (λ (fuel) #f)]
|
||||
|
|
@ -491,12 +510,14 @@
|
|||
" #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order"
|
||||
" argument to not be #f, but all four were #f")))
|
||||
|
||||
;; TODO: handle the addition of the collapsible-late-neg-projection
|
||||
(unless late-neg-projection
|
||||
(unless first-order?
|
||||
(log-racket/contract-info
|
||||
"no late-neg-projection passed to ~s~a"
|
||||
proc-name
|
||||
(build-context))))
|
||||
(unless collapsible-late-neg-projection
|
||||
(unless first-order?
|
||||
(log-racket/contract-info
|
||||
"no late-neg-projection passed to ~s~a"
|
||||
proc-name
|
||||
(build-context)))))
|
||||
|
||||
(mk (or name default-name)
|
||||
(or first-order any?)
|
||||
|
|
@ -509,6 +530,7 @@
|
|||
(late-neg-first-order-projection name first-order)]
|
||||
[else #f])]
|
||||
[else late-neg-projection])
|
||||
collapsible-late-neg-projection
|
||||
(or stronger weakest)
|
||||
(or equivalent (if equivalent-equal? equal? weakest))
|
||||
generate exercise
|
||||
|
|
|
|||
261
racket/collects/racket/contract/private/vector-collapsible.rkt
Normal file
261
racket/collects/racket/contract/private/vector-collapsible.rkt
Normal file
|
|
@ -0,0 +1,261 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "prop.rkt" "guts.rkt" "blame.rkt" "vector-common.rkt"
|
||||
"collapsible-common.rkt" "merge-cache.rkt"
|
||||
(submod "collapsible-common.rkt" properties)
|
||||
(only-in racket/unsafe/ops unsafe-chaperone-vector unsafe-impersonate-vector)
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide build-collapsible-vector
|
||||
build-doubling-collapsible-vector
|
||||
vector-collapsible-guard
|
||||
vector-enter-collapsible-mode/continue
|
||||
vector-enter-collapsible-mode/collapse)
|
||||
|
||||
(module+ for-testing
|
||||
(provide collapsible-vector? collapsible-vector-ref-ctcs collapsible-vector-set-ctcs))
|
||||
|
||||
(struct vector-first-order-check (immutable length blame missing-party))
|
||||
|
||||
;; mutable field are only to support impersonation in `build-doubling-c-c-vector`
|
||||
(struct collapsible-vector collapsible-ho/c (first-order [ref-ctcs #:mutable] [set-ctcs #:mutable]) #:transparent)
|
||||
|
||||
(define (do-vector-first-order-checks m/c val neg-party)
|
||||
(define checks (collapsible-vector-first-order m/c))
|
||||
(for ([c (in-list checks)])
|
||||
(define immutable (vector-first-order-check-immutable c))
|
||||
(define length (vector-first-order-check-length c))
|
||||
(define blame (vector-first-order-check-blame c))
|
||||
(define neg (or (vector-first-order-check-missing-party c) neg-party))
|
||||
(check-vector/c val blame immutable length neg)))
|
||||
|
||||
(define (vector-first-order-check-stronger? f1 f2)
|
||||
(define f1-immutable (vector-first-order-check-immutable f1))
|
||||
(define f1-length (vector-first-order-check-length f1))
|
||||
(define f2-immutable (vector-first-order-check-immutable f2))
|
||||
(define f2-length (vector-first-order-check-length f2))
|
||||
(and (or (eq? f2-immutable 'dont-care)
|
||||
(eq? f1-immutable f2-immutable))
|
||||
(or (not f2-length)
|
||||
(and f1-length (= f1-length f2-length)))))
|
||||
|
||||
(define (build-collapsible-vector c-c-pos c-c-neg ctc blame chap-not-imp?)
|
||||
(define focs (list (build-vector-first-order-checks ctc blame)))
|
||||
(if chap-not-imp?
|
||||
(chaperone-collapsible-vector blame #f ctc focs c-c-pos c-c-neg)
|
||||
(impersonator-collapsible-vector blame #f ctc focs c-c-pos c-c-neg)))
|
||||
|
||||
(define (build-doubling-collapsible-vector fetch-c-c-pos fetch-c-c-neg ctc blame chap-not-imp?)
|
||||
(define focs (list (build-vector-first-order-checks ctc blame)))
|
||||
(define dummy
|
||||
(if chap-not-imp?
|
||||
(chaperone-collapsible-vector blame #f ctc focs 'dummy-c-c-pos 'dummy-c-c-neg)
|
||||
(impersonator-collapsible-vector blame #f ctc focs 'dummy-c-c-pos 'dummy-c-c-neg)))
|
||||
(impersonate-struct dummy
|
||||
collapsible-vector-ref-ctcs
|
||||
(λ (self field-v) (fetch-c-c-pos))
|
||||
collapsible-vector-set-ctcs
|
||||
(λ (self field-v) (fetch-c-c-neg))))
|
||||
|
||||
(define (build-vector-first-order-checks ctc blame)
|
||||
(cond
|
||||
[(base-vectorof? ctc)
|
||||
(vector-first-order-check
|
||||
(base-vectorof-immutable ctc)
|
||||
#f
|
||||
blame
|
||||
#f)]
|
||||
[(base-vector/c? ctc)
|
||||
(vector-first-order-check
|
||||
(base-vector/c-immutable ctc)
|
||||
(length (base-vector/c-elems ctc))
|
||||
blame
|
||||
#f)]))
|
||||
|
||||
(define (add-f-o-neg-party focs neg-party)
|
||||
(for/list ([foc (in-list focs)])
|
||||
(define missing-party (vector-first-order-check-missing-party foc))
|
||||
(struct-copy
|
||||
vector-first-order-check
|
||||
foc
|
||||
[missing-party (or missing-party neg-party)])))
|
||||
|
||||
(define (vector-first-order-merge new new-neg old old-neg)
|
||||
(first-order-check-join
|
||||
(add-f-o-neg-party new new-neg)
|
||||
(add-f-o-neg-party old old-neg)
|
||||
vector-first-order-check-stronger?))
|
||||
|
||||
(define/merge-cache (vector-try-merge new-collapsible new-neg old-collapsible old-neg)
|
||||
(define constructor (get-constructor new-collapsible old-collapsible))
|
||||
(and constructor
|
||||
(constructor
|
||||
(collapsible-ho/c-latest-blame new-collapsible)
|
||||
(or (collapsible-ho/c-missing-party new-collapsible) new-neg)
|
||||
(collapsible-ho/c-latest-ctc new-collapsible)
|
||||
(vector-first-order-merge
|
||||
(collapsible-vector-first-order new-collapsible) new-neg
|
||||
(collapsible-vector-first-order old-collapsible) old-neg)
|
||||
(merge* (collapsible-vector-ref-ctcs new-collapsible)
|
||||
new-neg
|
||||
(collapsible-vector-ref-ctcs old-collapsible)
|
||||
old-neg)
|
||||
(merge* (collapsible-vector-set-ctcs old-collapsible)
|
||||
old-neg
|
||||
(collapsible-vector-set-ctcs new-collapsible)
|
||||
new-neg))))
|
||||
|
||||
(define (merge* new new-neg old old-neg)
|
||||
(cond
|
||||
[(and (vector? new) (vector? old))
|
||||
(for/vector ([nc (in-vector new)]
|
||||
[oc (in-vector old)])
|
||||
(merge nc new-neg oc old-neg))]
|
||||
[(vector? new)
|
||||
(for/vector ([nc (in-vector new)])
|
||||
(merge nc new-neg old old-neg))]
|
||||
[(vector? old)
|
||||
(for/vector ([oc (in-vector old)])
|
||||
(merge new new-neg oc old-neg))]
|
||||
[else
|
||||
(merge new new-neg old old-neg)]))
|
||||
|
||||
(define (get-constructor new old)
|
||||
(or (and (chaperone-collapsible-vector? new)
|
||||
(chaperone-collapsible-vector? old)
|
||||
chaperone-collapsible-vector)
|
||||
(and (impersonator-collapsible-vector? new)
|
||||
(impersonator-collapsible-vector? old)
|
||||
impersonator-collapsible-vector)))
|
||||
|
||||
(define (vector-collapsible-guard c-c val neg-party)
|
||||
(do-vector-first-order-checks c-c val neg-party)
|
||||
(define chap-not-imp? (chaperone-collapsible-vector? c-c))
|
||||
(define prop (get-impersonator-prop:collapsible val #f))
|
||||
(define safe-for-c-c?
|
||||
(if prop
|
||||
(and (collapsible-property? prop)
|
||||
(eq? (collapsible-property-ref prop) val))
|
||||
(not (impersonator? val))))
|
||||
(cond
|
||||
;; not safe, bail out
|
||||
[(not safe-for-c-c?)
|
||||
(bail-to-regular-wrapper c-c val neg-party)]
|
||||
;; already in c-c mode, so stay in
|
||||
[(collapsible-wrapper-property? prop)
|
||||
(vector-enter-collapsible-mode/continue
|
||||
c-c
|
||||
val
|
||||
neg-party
|
||||
(collapsible-property-c-c prop)
|
||||
(collapsible-property-neg-party prop)
|
||||
(collapsible-wrapper-property-checking-wrapper prop)
|
||||
chap-not-imp?)]
|
||||
;; need to collapse contracts ...
|
||||
[(collapsible-count-property? prop)
|
||||
(vector-enter-collapsible-mode/collapse
|
||||
c-c
|
||||
val
|
||||
neg-party
|
||||
prop
|
||||
chap-not-imp?)]
|
||||
;; else enter directly
|
||||
[else
|
||||
(vector-enter-collapsible-mode/direct c-c val neg-party chap-not-imp?)]))
|
||||
|
||||
(define (add-collapsible-vector-chaperone merged c-c neg-party checking-wrapper chap-not-imp?)
|
||||
(define chap/imp (if chap-not-imp? chaperone-vector impersonate-vector))
|
||||
(define c-c-prop
|
||||
(collapsible-wrapper-property merged neg-party #f checking-wrapper))
|
||||
(define wrapped
|
||||
(chap/imp
|
||||
checking-wrapper
|
||||
#f
|
||||
#f
|
||||
impersonator-prop:collapsible c-c-prop))
|
||||
(set-collapsible-property-ref! c-c-prop wrapped)
|
||||
wrapped)
|
||||
|
||||
(define (make-checking-wrapper unwrapped chap-not-imp?)
|
||||
(if chap-not-imp?
|
||||
(chaperone-vector* unwrapped ref-wrapper set-wrapper)
|
||||
(impersonate-vector* unwrapped ref-wrapper set-wrapper)))
|
||||
|
||||
(define (make-unsafe-checking-wrapper val unwrapped chap-not-imp?)
|
||||
(if chap-not-imp?
|
||||
(chaperone-vector*
|
||||
(unsafe-chaperone-vector val unwrapped)
|
||||
ref-wrapper
|
||||
set-wrapper)
|
||||
(impersonate-vector*
|
||||
(unsafe-impersonate-vector val unwrapped)
|
||||
ref-wrapper
|
||||
set-wrapper)))
|
||||
|
||||
(define-syntax (make-vector-checking-wrapper stx)
|
||||
(syntax-case stx ()
|
||||
[(_ set? maybe-closed-over-m/c maybe-closed-over-neg)
|
||||
#`(λ (outermost v i elt)
|
||||
(define-values (m/c neg-party)
|
||||
#,(if (syntax-e #'maybe-closed-over-m/c)
|
||||
#'(values maybe-closed-over-m/c maybe-closed-over-neg)
|
||||
#'(let ()
|
||||
(define prop (get-impersonator-prop:collapsible outermost))
|
||||
(values (collapsible-property-c-c prop)
|
||||
(collapsible-property-neg-party prop)))))
|
||||
(define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
|
||||
(define field
|
||||
#,(if (syntax-e #'set?)
|
||||
#'(collapsible-vector-set-ctcs m/c)
|
||||
#'(collapsible-vector-ref-ctcs m/c)))
|
||||
(define c-c
|
||||
(if (vector? field) (vector-ref field i) field))
|
||||
(define blame (cons (collapsible-ho/c-latest-blame m/c) neg))
|
||||
(with-collapsible-contract-continuation-mark
|
||||
(with-contract-continuation-mark
|
||||
blame
|
||||
(collapsible-guard c-c elt neg))))]))
|
||||
|
||||
(define ref-wrapper (make-vector-checking-wrapper #f #f #f))
|
||||
(define set-wrapper (make-vector-checking-wrapper #t #f #f))
|
||||
|
||||
(define (bail-to-regular-wrapper m/c val neg-party)
|
||||
(define chap-not-imp? (chaperone-collapsible-vector? m/c))
|
||||
(define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
|
||||
(define blame (cons (collapsible-ho/c-latest-blame m/c) neg))
|
||||
(define ctc (collapsible-ho/c-latest-ctc m/c))
|
||||
(define merged+neg-party (cons m/c neg))
|
||||
((if chap-not-imp? chaperone-vector* impersonate-vector*)
|
||||
val
|
||||
(make-vector-checking-wrapper #f m/c neg)
|
||||
(make-vector-checking-wrapper #t m/c neg)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))
|
||||
|
||||
(define vector-enter-collapsible-mode/continue
|
||||
(make-enter-collapsible-mode/continue
|
||||
vector-try-merge
|
||||
add-collapsible-vector-chaperone
|
||||
bail-to-regular-wrapper))
|
||||
|
||||
(define vector-enter-collapsible-mode/collapse
|
||||
(make-enter-collapsible-mode/collapse
|
||||
make-unsafe-checking-wrapper
|
||||
add-collapsible-vector-chaperone
|
||||
vector-try-merge
|
||||
bail-to-regular-wrapper))
|
||||
|
||||
(define vector-enter-collapsible-mode/direct
|
||||
(make-enter-collapsible-mode/direct
|
||||
make-checking-wrapper
|
||||
add-collapsible-vector-chaperone))
|
||||
|
||||
(define (vector-collapsible-contract-property chap-not-imp?)
|
||||
(build-collapsible-contract-property
|
||||
#:try-merge vector-try-merge
|
||||
#:collapsible-guard vector-collapsible-guard))
|
||||
|
||||
(struct chaperone-collapsible-vector collapsible-vector ()
|
||||
#:property prop:collapsible-contract (vector-collapsible-contract-property #t))
|
||||
(struct impersonator-collapsible-vector collapsible-vector ()
|
||||
#:property prop:collapsible-contract (vector-collapsible-contract-property #f))
|
||||
67
racket/collects/racket/contract/private/vector-common.rkt
Normal file
67
racket/collects/racket/contract/private/vector-common.rkt
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "blame.rkt")
|
||||
|
||||
(provide (struct-out base-vectorof)
|
||||
(struct-out base-vector/c)
|
||||
do-check-vectorof
|
||||
check-vector/c)
|
||||
|
||||
;; eager is one of:
|
||||
;; - #t: always perform an eager check of the elements of an immutable vector
|
||||
;; - #f: never perform an eager check of the elements of an immutable vector
|
||||
;; - N (for N>=0): perform an eager check of immutable vectors size <= N
|
||||
(define-struct base-vectorof (elem immutable eager))
|
||||
|
||||
(define-struct base-vector/c (elems immutable))
|
||||
|
||||
|
||||
(define (do-check-vectorof val immutable blame neg-party raise-blame?)
|
||||
(cond
|
||||
[(vector? val)
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(cond
|
||||
[(immutable? val) #t]
|
||||
[raise-blame?
|
||||
(raise-blame-error
|
||||
blame
|
||||
#:missing-party neg-party
|
||||
val
|
||||
'(expected "an immutable vector" given: "~e")
|
||||
val)]
|
||||
[else #f])]
|
||||
[(eq? immutable #f)
|
||||
(cond
|
||||
[(not (immutable? val)) #t]
|
||||
[raise-blame?
|
||||
(raise-blame-error
|
||||
blame
|
||||
#:missing-party neg-party
|
||||
val
|
||||
'(expected "an mutable vector" given: "~e")
|
||||
val)]
|
||||
[else #f])]
|
||||
[else #t])]
|
||||
[raise-blame?
|
||||
(raise-blame-error
|
||||
blame
|
||||
#:missing-party neg-party
|
||||
val
|
||||
'(expected "an immutable vector" given: "~e")
|
||||
val)]
|
||||
[else #f]))
|
||||
|
||||
(define (check-vector/c val blame immutable length neg-party)
|
||||
(define (raise-blame val . args)
|
||||
(apply raise-blame-error blame #:missing-party neg-party val args))
|
||||
(do-check-vectorof val immutable blame neg-party #t)
|
||||
(unless (or (not length) (= (vector-length val) length))
|
||||
(raise-blame-error
|
||||
blame
|
||||
#:missing-party neg-party
|
||||
val
|
||||
'(expected: "a vector of ~a element~a" given: "~e")
|
||||
length
|
||||
(if (= length 1) "" "s")
|
||||
val)))
|
||||
|
|
@ -4,18 +4,16 @@
|
|||
"guts.rkt"
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"misc.rkt")
|
||||
"misc.rkt"
|
||||
"collapsible-common.rkt"
|
||||
(submod "collapsible-common.rkt" properties)
|
||||
"vector-common.rkt"
|
||||
"vector-collapsible.rkt")
|
||||
|
||||
(provide (rename-out [wrap-vectorof vectorof]
|
||||
[wrap-vector/c vector/c])
|
||||
vector-immutable/c vector-immutableof)
|
||||
|
||||
;; eager is one of:
|
||||
;; - #t: always perform an eager check of the elements of an immutable vector
|
||||
;; - #f: never perform an eager check of the elements of an immutable vector
|
||||
;; - N (for N>=0): perform an eager check of immutable vectors size <= N
|
||||
(define-struct base-vectorof (elem immutable eager))
|
||||
|
||||
(define-for-syntax (convert-args args this-one)
|
||||
(let loop ([args args]
|
||||
[new-args null])
|
||||
|
|
@ -50,32 +48,29 @@
|
|||
(list '#:immutable immutable)
|
||||
null)))))
|
||||
|
||||
(define (check-vectorof c)
|
||||
(let ([elem-ctc (base-vectorof-elem c)]
|
||||
[immutable (base-vectorof-immutable c)]
|
||||
[flat? (flat-vectorof? c)])
|
||||
(λ (val fail first-order?)
|
||||
(unless (vector? val)
|
||||
(fail val '(expected "a vector," given: "~e") val))
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(unless (immutable? val)
|
||||
(fail val '(expected "an immutable vector" given: "~e") val))]
|
||||
[(eq? immutable #f)
|
||||
(when (immutable? val)
|
||||
(fail val '(expected "a mutable vector" given: "~e") val))]
|
||||
[else (void)])
|
||||
(when first-order?
|
||||
(let loop ([n 0])
|
||||
(cond
|
||||
[(= n (vector-length val))
|
||||
(void)]
|
||||
[else
|
||||
(define e (vector-ref val n))
|
||||
(unless (contract-first-order-passes? elem-ctc e)
|
||||
(fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e))
|
||||
(contract-first-order-try-less-hard (loop (+ n 1)))])))
|
||||
#t)))
|
||||
(define (check-vectorof elem-ctc immutable val blame neg-party first-order? raise-blame?)
|
||||
(and
|
||||
(do-check-vectorof val immutable blame neg-party raise-blame?)
|
||||
(if first-order?
|
||||
(let loop ([n 0])
|
||||
(cond
|
||||
[(= n (vector-length val)) #t]
|
||||
[else
|
||||
(define e (vector-ref val n))
|
||||
(cond
|
||||
[(contract-first-order-passes? elem-ctc e)
|
||||
(contract-first-order-try-less-hard (loop (+ n 1)))]
|
||||
[raise-blame?
|
||||
(raise-blame-error
|
||||
blame
|
||||
#:missing-party neg-party
|
||||
val
|
||||
'(expected: "~s for element ~s" given: "~e")
|
||||
(contract-name elem-ctc)
|
||||
n
|
||||
e)]
|
||||
[else #f])]))
|
||||
#t)))
|
||||
|
||||
(define (check-late-neg-vectorof c)
|
||||
(define immutable (base-vectorof-immutable c))
|
||||
|
|
@ -103,10 +98,10 @@
|
|||
val)])))
|
||||
|
||||
(define (vectorof-first-order ctc)
|
||||
(let ([check (check-vectorof ctc)])
|
||||
(let ([elem-ctc (base-vectorof-elem ctc)]
|
||||
[immutable (base-vectorof-immutable ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
(check-vectorof elem-ctc immutable val #f #f #t #f))))
|
||||
|
||||
(define (vectorof-stronger this that)
|
||||
(define this-elem (base-vectorof-elem this))
|
||||
|
|
@ -157,107 +152,161 @@
|
|||
|
||||
(define (blame-add-element-of-context blame #:swap? [swap? #f])
|
||||
(blame-add-context blame "an element of" #:swap? swap?))
|
||||
|
||||
(define (vectorof-late-neg-ho-projection chaperone-or-impersonate-vector)
|
||||
|
||||
(define (vectorof-collapsible-late-neg-ho-projection chap-not-imp?)
|
||||
(define chaperone-or-impersonate-vector
|
||||
(if chap-not-imp? chaperone-vector impersonate-vector))
|
||||
(λ (ctc)
|
||||
(define elem-ctc (base-vectorof-elem ctc))
|
||||
(define immutable (base-vectorof-immutable ctc))
|
||||
(define flat-subcontract? (flat-contract-struct? elem-ctc))
|
||||
(define eager (base-vectorof-eager ctc))
|
||||
(define check (check-vectorof ctc))
|
||||
(define immutable (base-vectorof-immutable ctc))
|
||||
(define vfp (get/build-collapsible-late-neg-projection elem-ctc))
|
||||
(λ (blame)
|
||||
(define pos-blame (blame-add-element-of-context blame))
|
||||
(define neg-blame (blame-add-element-of-context blame #:swap? #t))
|
||||
(define vfp (get/build-late-neg-projection elem-ctc))
|
||||
(define-values (filled? elem-pos-proj elem-neg-proj)
|
||||
(contract-pos/neg-doubling (vfp pos-blame) (vfp neg-blame)))
|
||||
(define-values (checked-ref checked-set)
|
||||
(define-values (filled? maybe-elem-pos-proj maybe-c-c-pos maybe-elem-neg-proj maybe-c-c-neg)
|
||||
(contract-pos/neg-doubling.2 (vfp pos-blame) (vfp neg-blame)))
|
||||
(define-values (fetch-tc-pos fetch-tc-neg)
|
||||
(cond
|
||||
[filled? (values #f #f)]
|
||||
[else
|
||||
(define tc-pos (make-thread-cell #f))
|
||||
(define tc-neg (make-thread-cell #f))
|
||||
(define (fetch-from-tc tc maybe-elem-proj maybe-c-c)
|
||||
(cond
|
||||
[(thread-cell-ref tc) => values]
|
||||
[else
|
||||
(define-values (elem-proj c-c) (maybe-elem-proj))
|
||||
(define pr (cons elem-proj c-c))
|
||||
(thread-cell-set! tc pr)
|
||||
pr]))
|
||||
(values (λ () (fetch-from-tc tc-pos maybe-elem-pos-proj maybe-c-c-pos))
|
||||
(λ () (fetch-from-tc tc-neg maybe-elem-neg-proj maybe-c-c-neg)))]))
|
||||
(define c-c-vector
|
||||
(cond
|
||||
[filled? (build-collapsible-vector maybe-c-c-pos maybe-c-c-neg ctc blame chap-not-imp?)]
|
||||
[else
|
||||
(build-doubling-collapsible-vector (λ () (cdr (fetch-tc-pos)))
|
||||
(λ () (cdr (fetch-tc-neg)))
|
||||
ctc blame chap-not-imp?)]))
|
||||
|
||||
(define checked-ref
|
||||
(cond
|
||||
[filled?
|
||||
(define checked-ref (λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-pos-proj val neg-party)))))
|
||||
(define checked-set (λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-neg-proj val neg-party)))))
|
||||
(values checked-ref checked-set)]
|
||||
(λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(maybe-elem-pos-proj val neg-party))))]
|
||||
[else
|
||||
(define ref-tc (make-thread-cell #f))
|
||||
(define set-tc (make-thread-cell #f))
|
||||
(define checked-ref (λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define real-elem-pos-proj
|
||||
(cond
|
||||
[(thread-cell-ref ref-tc) => values]
|
||||
[else
|
||||
(define real-elem-pos-proj (elem-pos-proj))
|
||||
(thread-cell-set! ref-tc real-elem-pos-proj)
|
||||
real-elem-pos-proj]))
|
||||
(real-elem-pos-proj val neg-party)))))
|
||||
(define checked-set (λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define real-elem-neg-proj
|
||||
(cond
|
||||
[(thread-cell-ref set-tc) => values]
|
||||
[else
|
||||
(define real-elem-neg-proj (elem-neg-proj))
|
||||
(thread-cell-set! set-tc real-elem-neg-proj)
|
||||
real-elem-neg-proj]))
|
||||
(real-elem-neg-proj val neg-party)))))
|
||||
(values checked-ref checked-set)]))
|
||||
(cond
|
||||
[(flat-contract? elem-ctc)
|
||||
(define p? (flat-contract-predicate elem-ctc))
|
||||
(λ (val neg-party)
|
||||
(define (raise-blame val . args)
|
||||
(apply raise-blame-error blame #:missing-party neg-party val args))
|
||||
(check val raise-blame #f)
|
||||
;; avoid traversing large vectors
|
||||
;; unless `eager` is specified
|
||||
(cond
|
||||
[(and (or (equal? eager #t)
|
||||
(and eager (<= (vector-length val) eager)))
|
||||
(immutable? val)
|
||||
(not (chaperone? val)))
|
||||
(for ([e (in-vector val)])
|
||||
(unless (p? e)
|
||||
(elem-pos-proj e neg-party)))
|
||||
val]
|
||||
[else
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]
|
||||
[else
|
||||
(λ (val neg-party)
|
||||
(define (raise-blame val . args)
|
||||
(apply raise-blame-error blame #:missing-party neg-party val args))
|
||||
(check val raise-blame #f)
|
||||
(cond
|
||||
[(and (immutable? val) (not (chaperone? val)))
|
||||
(vector->immutable-vector
|
||||
(for/vector #:length (vector-length val) ([e (in-vector val)])
|
||||
(elem-pos-proj e neg-party)))]
|
||||
[else
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]))))
|
||||
(λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define elem-pos-proj (car (fetch-tc-pos)))
|
||||
(elem-pos-proj val neg-party))))]))
|
||||
(define checked-set
|
||||
(cond
|
||||
[filled?
|
||||
(λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(maybe-elem-neg-proj val neg-party))))]
|
||||
[else
|
||||
(λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define elem-neg-proj (car (fetch-tc-neg)))
|
||||
(elem-neg-proj val neg-party))))]))
|
||||
(define p? (and (flat-contract-struct? elem-ctc)
|
||||
(flat-contract-predicate elem-ctc)))
|
||||
(define late-neg-proj
|
||||
(λ (val neg-party)
|
||||
(check-vectorof elem-ctc immutable val blame neg-party #f #t)
|
||||
(define immutable-non-chaperone?
|
||||
(and (immutable? val) (not (chaperone? val))))
|
||||
;; avoid traversing large vectors
|
||||
;; unless `eager` is specified
|
||||
(cond
|
||||
[(and flat-subcontract?
|
||||
immutable-non-chaperone?
|
||||
(or (equal? eager #t)
|
||||
(and eager (<= (vector-length val) eager))))
|
||||
(define elem-pos-proj (if filled?
|
||||
maybe-elem-pos-proj
|
||||
(car (fetch-tc-pos))))
|
||||
(for ([e (in-vector val)])
|
||||
(unless (p? e)
|
||||
(elem-pos-proj e neg-party)))
|
||||
val]
|
||||
[(and (not flat-subcontract?) immutable-non-chaperone?)
|
||||
(define elem-pos-proj (if filled?
|
||||
maybe-elem-pos-proj
|
||||
(car (fetch-tc-pos))))
|
||||
(vector->immutable-vector
|
||||
(for/vector #:length (vector-length val) ([e (in-vector val)])
|
||||
(elem-pos-proj e neg-party)))]
|
||||
[else
|
||||
(define old-c-c-prop (get-impersonator-prop:collapsible val #f))
|
||||
(define safe-for-c-c?
|
||||
(if old-c-c-prop
|
||||
(and (collapsible-property? old-c-c-prop)
|
||||
(eq? (collapsible-property-ref old-c-c-prop) val))
|
||||
(not (impersonator? val))))
|
||||
(define wrapper-count
|
||||
(if (collapsible-count-property? old-c-c-prop)
|
||||
(collapsible-count-property-count old-c-c-prop)
|
||||
0))
|
||||
(cond
|
||||
[(not safe-for-c-c?)
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (cons blame neg-party))]
|
||||
[(wrapper-count . >= . COLLAPSIBLE-LIMIT)
|
||||
(vector-enter-collapsible-mode/collapse
|
||||
c-c-vector
|
||||
val
|
||||
neg-party
|
||||
old-c-c-prop
|
||||
chap-not-imp?)]
|
||||
[(collapsible-wrapper-property? old-c-c-prop)
|
||||
(vector-enter-collapsible-mode/continue
|
||||
c-c-vector
|
||||
val
|
||||
neg-party
|
||||
(collapsible-property-c-c old-c-c-prop)
|
||||
(collapsible-property-neg-party old-c-c-prop)
|
||||
(collapsible-wrapper-property-checking-wrapper old-c-c-prop)
|
||||
chap-not-imp?)]
|
||||
[else
|
||||
(define c-c-prop
|
||||
(collapsible-count-property
|
||||
c-c-vector
|
||||
neg-party
|
||||
#f
|
||||
(add1 wrapper-count)
|
||||
(or old-c-c-prop val)))
|
||||
(define wrapped
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:collapsible c-c-prop))
|
||||
(set-collapsible-property-ref! c-c-prop wrapped)
|
||||
wrapped])])))
|
||||
(values
|
||||
late-neg-proj
|
||||
c-c-vector))))
|
||||
|
||||
(define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
|
||||
(make-impersonator-property 'prop:neg-blame-party))
|
||||
|
|
@ -270,7 +319,7 @@
|
|||
#:first-order vectorof-first-order
|
||||
#:equivalent vectorof-equivalent
|
||||
#:stronger vectorof-stronger
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
|
||||
#:collapsible-late-neg-projection (vectorof-collapsible-late-neg-ho-projection #t)))
|
||||
|
||||
(define-struct (impersonator-vectorof base-vectorof) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -280,7 +329,7 @@
|
|||
#:first-order vectorof-first-order
|
||||
#:equivalent vectorof-equivalent
|
||||
#:stronger vectorof-stronger
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector)))
|
||||
#:collapsible-late-neg-projection (vectorof-collapsible-late-neg-ho-projection #f)))
|
||||
|
||||
(define-syntax (wrap-vectorof stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -331,8 +380,6 @@
|
|||
(define/subexpression-pos-prop (vector-immutableof c)
|
||||
(vectorof c #:immutable #t))
|
||||
|
||||
(define-struct base-vector/c (elems immutable))
|
||||
|
||||
(define (vector/c-name c)
|
||||
(let ([immutable (base-vector/c-immutable c)])
|
||||
(apply build-compound-type-name 'vector/c
|
||||
|
|
@ -346,32 +393,6 @@
|
|||
(list '#:immutable immutable)
|
||||
null)))))
|
||||
|
||||
(define (check-vector/c ctc val blame neg-party)
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(unless (vector? val)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a vector" given: "~e") val))
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "an immutable vector" given: "~e")
|
||||
val))]
|
||||
[(eq? immutable #f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a mutable vector" given: "~e")
|
||||
val))]
|
||||
[else (void)])
|
||||
(define elem-count (length elem-ctcs))
|
||||
(unless (= (vector-length val) elem-count)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a vector of ~a element~a" given: "~e")
|
||||
elem-count
|
||||
(if (= elem-count 1) "" "s")
|
||||
val)))
|
||||
|
||||
(define (vector/c-first-order ctc)
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
|
|
@ -442,88 +463,184 @@
|
|||
#:stronger vector/c-stronger
|
||||
#:equivalent vector/c-equivalent
|
||||
#:late-neg-projection
|
||||
(λ (ctc)
|
||||
(λ (ctc)
|
||||
(define elems (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(λ (blame)
|
||||
(define blame+ctxt (blame-add-element-of-context blame))
|
||||
(define val+np-acceptors
|
||||
(for/list ([c (in-list (base-vector/c-elems ctc))])
|
||||
(for/list ([c (in-list elems)])
|
||||
((get/build-late-neg-projection c) blame+ctxt)))
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(check-vector/c val blame immutable (length elems) neg-party)
|
||||
(for ([e (in-vector val)]
|
||||
[p (in-list val+np-acceptors)])
|
||||
(p e neg-party))
|
||||
val)))))
|
||||
|
||||
(define (vector/c-ho-late-neg-projection vector-wrapper)
|
||||
(define (vector/c-collapsible-late-neg-ho-projection chap-not-imp?)
|
||||
(define vector-wrapper (if chap-not-imp? chaperone-vector impersonate-vector))
|
||||
(λ (ctc)
|
||||
(let ([elem-ctcs (base-vector/c-elems ctc)]
|
||||
[immutable (base-vector/c-immutable ctc)])
|
||||
(λ (blame)
|
||||
(define-values (filled? maybe-elem-pos-projs maybe-elem-neg-projs)
|
||||
(contract-pos/neg-doubling
|
||||
(for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (nth-element-of i))))
|
||||
(for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (nth-element-of i) #:swap? #t)))))
|
||||
(cond
|
||||
[filled?
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
[i (in-naturals)])
|
||||
((vector-ref maybe-elem-pos-projs i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-pos-projs i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-neg-projs i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame)))]
|
||||
[else
|
||||
(define pos-tc (make-thread-cell #f))
|
||||
(define neg-tc (make-thread-cell #f))
|
||||
(define (get-projs tc get-ele-projs)
|
||||
(cond
|
||||
[(thread-cell-ref tc) => values]
|
||||
[else
|
||||
(define projs (get-ele-projs))
|
||||
(thread-cell-set! tc projs)
|
||||
projs]))
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
[i (in-naturals)])
|
||||
((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref (get-projs neg-tc maybe-elem-neg-projs) i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame)))])))))
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(define elems-length (length elem-ctcs))
|
||||
(define selnps
|
||||
(for/list ([elem-ctc (in-list elem-ctcs)])
|
||||
(get/build-collapsible-late-neg-projection elem-ctc)))
|
||||
(λ (blame)
|
||||
(define-values (filled? maybe-elem-pos-projs maybe-c-c-poss maybe-elem-neg-projs maybe-c-c-negs)
|
||||
(contract-pos/neg-doubling.2
|
||||
(let ()
|
||||
(define elem-pos-projs (make-vector elems-length #f))
|
||||
(define elem-c-c-poss (make-vector elems-length #f))
|
||||
(for ([selnp (in-list selnps)]
|
||||
[i (in-naturals)])
|
||||
(define pos-blame (blame-add-context blame (nth-element-of i)))
|
||||
(define-values (elem-pos-proj elem-c-c-pos) (selnp pos-blame))
|
||||
(vector-set! elem-pos-projs i elem-pos-proj)
|
||||
(vector-set! elem-c-c-poss i elem-c-c-pos))
|
||||
(values elem-pos-projs elem-c-c-poss))
|
||||
(let ()
|
||||
(define elem-neg-projs (make-vector elems-length #f))
|
||||
(define elem-c-c-negs (make-vector elems-length #f))
|
||||
(for ([selnp (in-list selnps)]
|
||||
[i (in-naturals)])
|
||||
(define neg-blame (blame-add-context blame (nth-element-of i)
|
||||
#:swap? #t))
|
||||
(define-values (elem-neg-proj elem-c-c-neg) (selnp neg-blame))
|
||||
(vector-set! elem-neg-projs i elem-neg-proj)
|
||||
(vector-set! elem-c-c-negs i elem-c-c-neg))
|
||||
(values elem-neg-projs elem-c-c-negs))))
|
||||
|
||||
(define-values (fetch-tc-pos fetch-tc-neg)
|
||||
(cond
|
||||
[filled? (values (void) (void))]
|
||||
[else
|
||||
(define tc-pos (make-thread-cell #f))
|
||||
(define tc-neg (make-thread-cell #f))
|
||||
(values (λ ()
|
||||
(cond
|
||||
[(thread-cell-ref tc-pos) => values]
|
||||
[else
|
||||
(define-values (elem-pos-projs maybe-c-c-pos) (maybe-elem-pos-projs))
|
||||
(define pr (cons elem-pos-projs maybe-c-c-pos))
|
||||
(thread-cell-set! tc-pos pr)
|
||||
pr]))
|
||||
(λ ()
|
||||
(cond
|
||||
[(thread-cell-ref tc-neg) => values]
|
||||
[else
|
||||
(define-values (elem-neg-projs maybe-c-c-neg) (maybe-elem-neg-projs))
|
||||
(define pr (cons elem-neg-projs maybe-c-c-neg))
|
||||
(thread-cell-set! tc-neg pr)
|
||||
pr])))]))
|
||||
(define c-c-vector
|
||||
(cond
|
||||
[filled?
|
||||
(build-collapsible-vector maybe-c-c-poss maybe-c-c-negs ctc blame chap-not-imp?)]
|
||||
[else
|
||||
(build-doubling-collapsible-vector (λ () (cdr (fetch-tc-pos)))
|
||||
(λ () (cdr (fetch-tc-neg)))
|
||||
ctc blame chap-not-imp?)]))
|
||||
|
||||
(define chaperone-get-proc
|
||||
(cond
|
||||
[filled?
|
||||
(λ (neg-party blame+neg-party)
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-pos-projs i) val neg-party))))]
|
||||
[else
|
||||
(λ (neg-party blame+neg-party)
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define elem-pos-projs (car (fetch-tc-pos)))
|
||||
((vector-ref elem-pos-projs i) val neg-party))))]))
|
||||
(define chaperone-set-proc
|
||||
(cond
|
||||
[filled?
|
||||
(λ (neg-party blame+neg-party)
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-neg-projs i) val neg-party))))]
|
||||
[else
|
||||
(λ (neg-party blame+neg-party)
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define elem-neg-projs (car (fetch-tc-neg)))
|
||||
((vector-ref elem-neg-projs i) val neg-party))))]))
|
||||
|
||||
(define late-neg-proj
|
||||
(λ (val neg-party)
|
||||
(define old-c-c-prop (get-impersonator-prop:collapsible val #f))
|
||||
(define safe-for-c-c
|
||||
(if old-c-c-prop
|
||||
(and (collapsible-property? old-c-c-prop)
|
||||
(eq? (collapsible-property-ref old-c-c-prop) val))
|
||||
(not (impersonator? val))))
|
||||
(define wrapper-count
|
||||
(if (collapsible-count-property? old-c-c-prop)
|
||||
(collapsible-count-property-count old-c-c-prop)
|
||||
0))
|
||||
(check-vector/c val blame immutable elems-length neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(cond
|
||||
[(and (immutable? val) (not (chaperone? val)))
|
||||
(define elem-pos-projs
|
||||
(if filled?
|
||||
maybe-elem-pos-projs
|
||||
(car (fetch-tc-pos))))
|
||||
(apply vector-immutable
|
||||
(for/list ([i (in-naturals)]
|
||||
[elem-val (in-vector val)])
|
||||
((vector-ref elem-pos-projs i) elem-val neg-party)))]
|
||||
[(not safe-for-c-c)
|
||||
(vector-wrapper
|
||||
val
|
||||
(chaperone-get-proc neg-party blame+neg-party)
|
||||
(chaperone-set-proc neg-party blame+neg-party)
|
||||
;; TODO: should this be a collapsible property instead??
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame+neg-party)]
|
||||
[(wrapper-count . >= . COLLAPSIBLE-LIMIT)
|
||||
(vector-enter-collapsible-mode/collapse
|
||||
c-c-vector
|
||||
val
|
||||
neg-party
|
||||
old-c-c-prop
|
||||
chap-not-imp?)]
|
||||
[(collapsible-wrapper-property? old-c-c-prop)
|
||||
(vector-enter-collapsible-mode/continue
|
||||
c-c-vector
|
||||
val
|
||||
neg-party
|
||||
(collapsible-property-c-c old-c-c-prop)
|
||||
(collapsible-property-neg-party old-c-c-prop)
|
||||
(collapsible-wrapper-property-checking-wrapper old-c-c-prop)
|
||||
chap-not-imp?)]
|
||||
[else
|
||||
(define c-c-prop
|
||||
(collapsible-count-property
|
||||
c-c-vector
|
||||
neg-party
|
||||
#f
|
||||
(add1 wrapper-count)
|
||||
(or old-c-c-prop val)))
|
||||
(define wrapped
|
||||
(vector-wrapper
|
||||
val
|
||||
(chaperone-get-proc neg-party blame+neg-party)
|
||||
(chaperone-set-proc neg-party blame+neg-party)
|
||||
impersonator-prop:collapsible c-c-prop))
|
||||
(set-collapsible-property-ref! c-c-prop wrapped)
|
||||
wrapped])))
|
||||
(values
|
||||
late-neg-proj
|
||||
c-c-vector))))
|
||||
|
||||
(define-struct (chaperone-vector/c base-vector/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -532,8 +649,8 @@
|
|||
#:name vector/c-name
|
||||
#:first-order vector/c-first-order
|
||||
#:stronger vector/c-stronger
|
||||
#:equivalent vector/c-equivalent
|
||||
#:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector)))
|
||||
#:collapsible-late-neg-projection (vector/c-collapsible-late-neg-ho-projection #t)
|
||||
#:equivalent vector/c-equivalent))
|
||||
|
||||
(define-struct (impersonator-vector/c base-vector/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -542,8 +659,8 @@
|
|||
#:name vector/c-name
|
||||
#:first-order vector/c-first-order
|
||||
#:stronger vector/c-stronger
|
||||
#:equivalent vector/c-equivalent
|
||||
#:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector)))
|
||||
#:collapsible-late-neg-projection (vector/c-collapsible-late-neg-ho-projection #f)
|
||||
#:equivalent vector/c-equivalent))
|
||||
|
||||
(define-syntax (wrap-vector/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
"../contract/combinator.rkt"
|
||||
(only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
|
||||
(only-in "../contract/private/case-arrow.rkt" case->-internal)
|
||||
(only-in "../contract/private/arr-d.rkt" ->d-internal))
|
||||
(only-in "../contract/private/arr-d.rkt" ->d-internal)
|
||||
(submod "../contract/private/collapsible-common.rkt" properties))
|
||||
|
||||
(provide make-class/c class/c-late-neg-proj
|
||||
blame-add-method-context blame-add-field-context blame-add-init-context
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user