suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Revert "change or/c so that it takes the first ho projection"

Browse Source 
This reverts commit 5a33856802.

Merge to 6.3.
This commit is contained in:
Sam Tobin-Hochstadt 2015-11-06 08:41:10 -05:00
parent 5e2421b1a0
commit f126fd2356
3 changed files with 68 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -182,25 +182,21 @@ If there are multiple higher-order contracts, @racket[or/c] uses
them. More precisely, when an @racket[or/c] is checked, it first
checks all of the @tech{flat contracts}. If none of them pass, it
calls @racket[contract-first-order-passes?] with each of the
higher-order contracts, taking the first one that returns
true as the contract for the value.
higher-order contracts. If only one returns true, @racket[or/c] uses
that contract. If none of them return true, it signals a contract
violation. If more than one returns true, it also signals a contract
violation.
For example, this contract
@racketblock[
(or/c (-> number? number?)
(-> string? string? string?))
]
accepts a function like this one: @racket[(lambda args ...)],
using the @racket[(-> number? number?)] contract on it, ignoring
the @racket[(-> string? string? string?)] contract since it came
second.
does not accept a function like this one: @racket[(lambda args ...)]
since it cannot tell which of the two arrow contracts should be used
with the function.
If all of its arguments are @racket[list-contract?]s, then @racket[or/c]
returns a @racket[list-contract?].
@history[#:changed "6.3" @list{Adjusted @racket[or/c] so that it
takes the first higher-order contract instead of insisting that
there be exactly one higher-order contract for a given value.}]
}
@defproc[(and/c [contract contract?] ...) contract?]{

22
pkgs/racket-test/tests/racket/contract/or-and.rkt
View File

@ -86,6 +86,14 @@
1)
1)
(contract-error-test
'contract-error-test4
#'(contract (or/c (-> integer? integer?) (-> boolean? boolean?))
(λ (x) x)
'pos
'neg)
exn:fail?)
(test/spec-passed/result
'or/c-ordering
'(let ([x '()])
@ -223,21 +231,11 @@
'pos 'neg)
(lambda (x y z) 1)))
(test/spec-passed/result
(test/neg-blame
'ho-or/c-val-first2
'((contract (or/c (-> integer? integer?) (-> boolean? boolean?))
(λ (x) x)
'pos
'neg)
1)
1)
(test/spec-passed/result
'ho-or/c-val-first3
'((contract (-> (or/c (-> number? number?)
(-> number? number?))
number?)
(λ (x) 1)
'pos 'neg)
(lambda (x) 1))
1))
(lambda (x) 1))))

64
racket/collects/racket/contract/private/orc.rkt
View File

@ -22,7 +22,7 @@
[flat-contracts '()]
[args args])
(cond
[(null? args) (values (reverse ho-contracts) (reverse flat-contracts))]
[(null? args) (values ho-contracts (reverse flat-contracts))]
[else
(let ([arg (car args)])
(cond
@ -242,18 +242,36 @@
[else
(let loop ([checks first-order-checks]
[procs partial-contracts]
[contracts ho-contracts])
[contracts ho-contracts]
[candidate-proc #f]
[candidate-contract #f])
(cond
[(null? checks)
(raise-blame-error blame val
'("none of the branches of the or/c matched" given: "~e")
val)]
(if candidate-proc
(candidate-proc val)
(raise-blame-error blame val
'("none of the branches of the or/c matched" given: "~e")
val))]
[((car checks) val)
((car procs) val)]
(if candidate-proc
(raise-blame-error blame val
'("two of the clauses in the or/c might both match: ~s and ~s"
given:
"~e")
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr procs)
(cdr contracts)
(car procs)
(car contracts)))]
[else
(loop (cdr checks)
(cdr procs)
(cdr contracts))]))])))))
(cdr contracts)
candidate-proc
candidate-contract)]))])))))
(define (multi-or/c-late-neg-proj ctc)
(define ho-contracts (multi-or/c-ho-ctcs ctc))
@ -271,18 +289,38 @@
[else
(let loop ([checks first-order-checks]
[c-projs c-projs+blame]
[contracts ho-contracts])
[contracts ho-contracts]
[candidate-c-proj #f]
[candidate-contract #f])
(cond
[(null? checks)
(raise-blame-error blame val #:missing-party neg-party
'("none of the branches of the or/c matched" given: "~e")
val)]
(cond
[candidate-c-proj
(candidate-c-proj val neg-party)]
[else
(raise-blame-error blame val #:missing-party neg-party
'("none of the branches of the or/c matched" given: "~e")
val)])]
[((car checks) val)
((car c-projs) val neg-party)]
(if candidate-c-proj
(raise-blame-error blame val #:missing-party neg-party
'("two of the clauses in the or/c might both match: ~s and ~s"
given:
"~e")
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr c-projs)
(cdr contracts)
(car c-projs)
(car contracts)))]
[else
(loop (cdr checks)
(cdr c-projs)
(cdr contracts))]))]))))
(cdr contracts)
candidate-c-proj
candidate-contract)]))]))))
(define (multi-or/c-first-order ctc)
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]