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

improve ->i in the case that the dependent contract

Browse Source 
turns out to be a predicate.

In that case, just call it instead of creating all of the extra junk
that would normally be created by coercing the predicate to a contract
and invoking it
This commit is contained in:
Robby Findler 2015-12-29 11:15:31 -06:00
parent a516304f6b
commit 7056cd5f2a
2 changed files with 30 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -1089,17 +1089,29 @@ evaluted left-to-right.)
(begin-encourage-inline
(define (un-dep/chaperone orig-ctc obj blame neg-party)
(let ([ctc (coerce-contract '->i orig-ctc)])
(unless (chaperone-contract? ctc)
(raise-argument-error '->i
"chaperone-contract?"
orig-ctc))
(((get/build-late-neg-projection ctc) blame) obj neg-party))))
(cond
[(and (procedure? orig-ctc)
(procedure-arity-includes? orig-ctc 1))
(if (orig-ctc obj)
obj
(raise-predicate-blame-error-failure blame obj neg-party
(object-name orig-ctc)))]
[else
(define ctc (coerce-chaperone-contract '->i orig-ctc))
(((get/build-late-neg-projection ctc) blame) obj neg-party)])))
(begin-encourage-inline
(define (un-dep orig-ctc obj blame neg-party)
(let ([ctc (coerce-contract '->i orig-ctc)])
(((get/build-late-neg-projection ctc) blame) obj neg-party))))
(cond
[(and (procedure? orig-ctc)
(procedure-arity-includes? orig-ctc 1))
(if (orig-ctc obj)
obj
(raise-predicate-blame-error-failure blame obj neg-party
(object-name orig-ctc)))]
[else
(define ctc (coerce-contract '->i orig-ctc))
(((get/build-late-neg-projection ctc) blame) obj neg-party)])))
(define-for-syntax (mk-used-indy-vars an-istx)
(let ([vars (make-free-identifier-mapping)])

15
racket/collects/racket/contract/private/guts.rkt
View File

@ -74,7 +74,9 @@
contract-first-order-okay-to-give-up?
contract-first-order-try-less-hard
contract-first-order-only-try-so-hard)
contract-first-order-only-try-so-hard
raise-predicate-blame-error-failure)
(define (contract-custom-write-property-proc stct port mode)
(define (write-prefix)
@ -617,10 +619,7 @@
(λ (v neg-party)
(if (p? v)
v
(raise-blame-error blame v #:missing-party neg-party
'(expected: "~s" given: "~e")
name
v))))))
(raise-predicate-blame-error-failure blame v neg-party name))))))
#:generate (λ (ctc)
(let ([generate (predicate-contract-generate ctc)])
(cond
@ -635,6 +634,12 @@
#:list-contract? (λ (ctc) (or (equal? (predicate-contract-pred ctc) null?)
(equal? (predicate-contract-pred ctc) empty?)))))
(define (raise-predicate-blame-error-failure blame v neg-party predicate-name)
(raise-blame-error blame v #:missing-party neg-party
'(expected: "~s" given: "~e")
predicate-name
v))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (build-flat-contract name pred [generate #f])