generalize tail contract checking for function contracts
Specifically, remove reliance on procedure-closure-contents-eq? to
tell when a pending check is stronger in favor of usint
contract-stronger?
Also, tighten up the specification of contract-stronger? to require
that any contract is stronger than itself
With this commit, this program gets about 10% slower:
#lang racket/base
(require racket/contract/base)
(define f
(contract
(-> any/c integer?)
(λ (x) (if (zero? x)
0
(f (- x 1))))
'pos 'neg))
(time (f 2000000))
becuase the checking is doing work more explicitly now but because the
checking in more general, it identifies the redundant checking in this
program
#lang racket/base
(require racket/contract/base)
(define f
(contract
(-> any/c integer?)
(contract
(-> any/c integer?)
(λ (x) (if (zero? x)
0
(f (- x 1))))
'pos 'neg)
'pos 'neg))
(time (f 200000))
which makes it run about 13x faster than it did before
I'm not sure if this is a win overall, since the checking can be more
significant in the case of "near misses". For example, with this
program, where neither the new nor the old checking detects the
redundancy is about 40% slower after this commit than it was before:
#lang racket/base
(require racket/contract/base)
(define f
(contract
(-> any/c (<=/c 0))
(contract
(-> any/c (>=/c 0))
(λ (x) (if (zero? x)
0
(f (- x 1))))
'pos 'neg)
'pos 'neg))
(time (f 50000))
(The redundancy isn't detected here because the contract system only
looks at the first pending contract check.)
Overall, despite the fact that it slows down some programs and speeds
up others, my main thought is that it is worth doing because it
eliminates a (painful) reliance on procedure-closure-contents-eq? that
inhibits other approaches to optimizing these contracts we might try.
This commit is contained in:
Robby Findler
parent
f0f85549ce
commit
d927d04efd
|
|
@ -2024,8 +2024,8 @@ flat contracts do not need to supply an explicit projection.
|
|||
The @racket[stronger] argument is used to implement @racket[contract-stronger?]. The
|
||||
first argument is always the contract itself and the second argument is whatever
|
||||
was passed as the second argument to @racket[contract-stronger?]. If no
|
||||
@racket[stronger] argument is supplied, then a default that always returns
|
||||
@racket[#f] is used.
|
||||
@racket[stronger] argument is supplied, then a default that compares its arguments
|
||||
with @racket[equal?] is used.
|
||||
|
||||
The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate
|
||||
to determine if this is a contract that accepts only @racket[list?] values.
|
||||
|
|
@ -2721,6 +2721,9 @@ are below):
|
|||
Returns @racket[#t] if the contract @racket[x] accepts either fewer
|
||||
or the same number of values as @racket[y] does.
|
||||
|
||||
Contracts that are the same (i.e., where @racket[x] is @racket[equal?]
|
||||
to @racket[y]) are considered to always be stronger than each other.
|
||||
|
||||
This function is conservative, so it may return @racket[#f] when
|
||||
@racket[x] does, in fact, accept fewer values.
|
||||
|
||||
|
|
@ -2730,8 +2733,8 @@ are below):
|
|||
(contract-stronger? (between/c 0 100) (between/c 25 75))
|
||||
(contract-stronger? (between/c -10 0) (between/c 0 10))
|
||||
|
||||
(contract-stronger? (λ (x) (and (real? x) (<= x (random 10))))
|
||||
(λ (x) (and (real? x) (<= x (+ 100 (random 10))))))]
|
||||
(contract-stronger? (λ (x) (and (real? x) (<= x 0)))
|
||||
(λ (x) (and (real? x) (<= x 100))))]
|
||||
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -340,6 +340,21 @@
|
|||
;; pass; this is fixed in a separate branch that can't
|
||||
(regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b"
|
||||
(exn-message x)))))
|
||||
|
||||
;; need to preserve the inner contract here
|
||||
;; (not the outer one)
|
||||
;; when dropping redundant tail contracts
|
||||
(test/pos-blame
|
||||
'tail-wrapping-preserves-blame
|
||||
'(let ([c (-> number? number?)])
|
||||
((contract
|
||||
c
|
||||
(contract
|
||||
c
|
||||
(λ (x) #f)
|
||||
'pos 'neg)
|
||||
'something-else 'yet-another-thing)
|
||||
1)))
|
||||
|
||||
(test/pos-blame
|
||||
'predicate/c1
|
||||
|
|
|
|||
|
|
@ -85,6 +85,29 @@
|
|||
(c)))
|
||||
|
||||
(ctest/rewrite '(1)
|
||||
mut-rec-with-any
|
||||
(let ()
|
||||
(define f
|
||||
(contract (-> number? any)
|
||||
(lambda (x)
|
||||
(if (zero? x)
|
||||
(continuation-mark-set->list (current-continuation-marks)
|
||||
'tail-test)
|
||||
(with-continuation-mark 'tail-test x
|
||||
(g (- x 1)))))
|
||||
'something-that-is-not-pos
|
||||
'neg))
|
||||
|
||||
(define g
|
||||
(contract (-> number? any)
|
||||
(lambda (x)
|
||||
(f x))
|
||||
'also-this-is-not-pos
|
||||
'neg))
|
||||
|
||||
(f 3)))
|
||||
|
||||
(ctest/rewrite '(1 2 3)
|
||||
mut-rec-with-any/c
|
||||
(let ()
|
||||
(define f
|
||||
|
|
|
|||
|
|
@ -32,15 +32,15 @@
|
|||
[(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)]
|
||||
[(rng-proj ...) (if rngs (generate-temporaries rngs) '())]
|
||||
[(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())])
|
||||
#`(λ (blame f neg-party
|
||||
#`(λ (blame f neg-party blame-party-info rng-ctcs
|
||||
mandatory-dom-proj ...
|
||||
optional-dom-proj ...
|
||||
rest-proj ...
|
||||
mandatory-dom-kwd-proj ...
|
||||
optional-dom-kwd-proj ...
|
||||
rng-proj ...)
|
||||
#,(create-chaperone
|
||||
#'blame #'f
|
||||
#,(create-chaperone
|
||||
#'blame #'neg-party #'blame-party-info #'f #'rng-ctcs
|
||||
this-args
|
||||
(syntax->list #'(mandatory-dom-proj ...))
|
||||
(syntax->list #'(optional-dom-proj ...))
|
||||
|
|
@ -114,7 +114,8 @@
|
|||
(if pre? "pre" "post")
|
||||
condition-result)]))
|
||||
|
||||
(define-for-syntax (create-chaperone blame val
|
||||
(define-for-syntax (create-chaperone blame neg-party blame-party-info
|
||||
val rng-ctcs
|
||||
this-args
|
||||
doms opt-doms
|
||||
req-kwds opt-kwds
|
||||
|
|
@ -150,7 +151,7 @@
|
|||
[(opt-kwd ...) (map car opt-kwds)]
|
||||
[(opt-kwd-ctc ...) (map cadr opt-kwds)]
|
||||
[(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
|
||||
[(rng-ctc ...) (if rngs rngs '())]
|
||||
[(rng-late-neg-projs ...) (if rngs rngs '())]
|
||||
[(rng-x ...) (if rngs (generate-temporaries rngs) '())])
|
||||
(with-syntax ([(rng-checker-name ...)
|
||||
(if rngs
|
||||
|
|
@ -161,7 +162,7 @@
|
|||
(list
|
||||
(with-syntax ([rng-len (length rngs)])
|
||||
(with-syntax ([rng-results
|
||||
#'(values (rng-ctc rng-x neg-party)
|
||||
#'(values (rng-late-neg-projs rng-x neg-party)
|
||||
...)])
|
||||
#'(case-lambda
|
||||
[(rng-x ...)
|
||||
|
|
@ -248,7 +249,9 @@
|
|||
dom-projd-args ...)))])
|
||||
(if no-rng-checking?
|
||||
(inner-stx-gen #'())
|
||||
(arrow:check-tail-contract #'(rng-ctc ...)
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'(rng-checker-name ...)
|
||||
inner-stx-gen)))]
|
||||
[kwd-return
|
||||
|
|
@ -273,7 +276,9 @@
|
|||
#`(let ([kwd-results kwd-stx])
|
||||
#,(if no-rng-checking?
|
||||
(outer-stx-gen #'())
|
||||
(arrow:check-tail-contract #'(rng-ctc ...)
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'(rng-checker-name ...)
|
||||
outer-stx-gen))))])
|
||||
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
|
||||
|
|
@ -398,12 +403,15 @@
|
|||
man-then-opt-partial-kwds
|
||||
partial-ranges
|
||||
(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 chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
|
||||
(define chap/imp-func (apply chaperone-constructor
|
||||
orig-blame val
|
||||
neg-party blame-party-info
|
||||
rngs the-args))
|
||||
(cond
|
||||
[chap/imp-func
|
||||
(if post?
|
||||
(if (or post? (not rngs))
|
||||
(chaperone-or-impersonate-procedure
|
||||
val
|
||||
chap/imp-func
|
||||
|
|
@ -414,9 +422,8 @@
|
|||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
|
||||
impersonator-prop:application-mark (cons arrow:contract-key
|
||||
;; is this right?
|
||||
partial-ranges)))]
|
||||
impersonator-prop:application-mark
|
||||
(cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
|
||||
[else val]))
|
||||
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -895,7 +895,7 @@
|
|||
optional-keywords
|
||||
(and rest-contract #t)
|
||||
rng-len)
|
||||
(λ (blame f neg-party . args)
|
||||
(λ (blame f neg-party blame-party-info rng-ctc-x . args)
|
||||
(define-next next args)
|
||||
(define mandatory-dom-projs (next min-arity))
|
||||
(define optional-dom-projs (next optionals))
|
||||
|
|
@ -1242,7 +1242,7 @@
|
|||
(make--> 0 '() '() #f #f
|
||||
(list (coerce-contract 'whatever void?))
|
||||
#f
|
||||
(λ (blame f _ignored-rng-contract)
|
||||
(λ (blame f _ignored-rng-ctcs _ignored-rng-proj)
|
||||
(λ (neg-party)
|
||||
(call-with-values
|
||||
(λ () (f))
|
||||
|
|
@ -1276,7 +1276,11 @@
|
|||
(call-with-values
|
||||
(λ () (f argument))
|
||||
(rng-checker f blame neg-party))))
|
||||
(λ (blame f neg-party _ignored-dom-contract _ignored-rng-contract)
|
||||
(λ (blame f neg-party
|
||||
_ignored-blame-party-info
|
||||
_ignored-rng-ctcs
|
||||
_ignored-dom-contract
|
||||
_ignored-rng-contract)
|
||||
(unless (procedure? f)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party f
|
||||
|
|
|
|||
|
|
@ -32,8 +32,9 @@
|
|||
(for-syntax check-tail-contract
|
||||
make-this-parameters
|
||||
parse-leftover->*)
|
||||
contract-key
|
||||
tail-contract-key
|
||||
tail-marks-match?
|
||||
get-blame-party-info
|
||||
values/drop
|
||||
arity-checking-wrapper
|
||||
unspecified-dom
|
||||
|
|
@ -49,34 +50,51 @@
|
|||
(list id)
|
||||
null))
|
||||
|
||||
(define contract-key (gensym 'contract-key))
|
||||
(define tail-contract-key (gensym 'tail-contract-key))
|
||||
|
||||
(define-for-syntax (check-tail-contract rng-ctcs rng-checkers call-gen)
|
||||
(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen)
|
||||
(unless (identifier? rng-ctcs)
|
||||
(raise-argument-error 'check-tail-contract
|
||||
"identifier?"
|
||||
0
|
||||
rng-ctcs rng-checkers call-gen))
|
||||
#`(call-with-immediate-continuation-mark
|
||||
contract-key
|
||||
tail-contract-key
|
||||
(λ (m)
|
||||
(if (tail-marks-match? m . #,rng-ctcs)
|
||||
(if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party)
|
||||
#,(call-gen #'())
|
||||
#,(call-gen rng-checkers)))))
|
||||
|
||||
(begin-encourage-inline
|
||||
(define tail-marks-match?
|
||||
(case-lambda
|
||||
[(m) (and m (null? m))]
|
||||
[(m rng-ctc)
|
||||
(and m
|
||||
(not (null? m))
|
||||
(null? (cdr m))
|
||||
(procedure-closure-contents-eq? (car m) rng-ctc))]
|
||||
[(m rng-ctc1 rng-ctc2)
|
||||
(and m
|
||||
(= (length m) 2)
|
||||
(procedure-closure-contents-eq? (car m) rng-ctc1)
|
||||
(procedure-closure-contents-eq? (cadr m) rng-ctc1))]
|
||||
[(m . rng-ctcs)
|
||||
(and m
|
||||
(= (length m) (length rng-ctcs))
|
||||
(andmap procedure-closure-contents-eq? m rng-ctcs))])))
|
||||
;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc))))
|
||||
;; rng-ctc : (or/c #f (listof ctc))
|
||||
;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
|
||||
;; neg-party : neg-party
|
||||
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party)
|
||||
(and m
|
||||
rng-ctcs
|
||||
(eq? (car m) neg-party)
|
||||
(let ([mark-blame-part-info (cadr m)])
|
||||
(and (eq? (car mark-blame-part-info) (car blame-party-info))
|
||||
(eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
|
||||
(let loop ([m (cddr m)]
|
||||
[rng-ctcs rng-ctcs])
|
||||
(cond
|
||||
[(null? m) (null? rng-ctcs)]
|
||||
[(null? rng-ctcs) (null? m)]
|
||||
[else
|
||||
(define m1 (car m))
|
||||
(define rng-ctc1 (car rng-ctcs))
|
||||
(cond
|
||||
[(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
|
||||
[(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
|
||||
[else #f])]))))
|
||||
|
||||
;; used as part of the information in the continuation mark
|
||||
;; that records what is to be checked for a pending contract
|
||||
(define (get-blame-party-info blame)
|
||||
(define swapped? (blame-swapped? blame))
|
||||
(list (if swapped? (blame-negative blame) (blame-positive blame))
|
||||
swapped?))
|
||||
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -86,9 +104,11 @@
|
|||
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([proj-x (get/build-late-neg-projection rngs-x)] ...)
|
||||
(let ([rngs-list (list rngs-x ...)]
|
||||
[proj-x (get/build-late-neg-projection rngs-x)] ...)
|
||||
(define (projection wrapper get-ctc)
|
||||
(λ (orig-blame)
|
||||
(define blame-party-info (get-blame-party-info orig-blame))
|
||||
(define ctc (get-ctc))
|
||||
(let ([rng-blame (blame-add-range-context orig-blame)])
|
||||
(let* ([p-app-x (proj-x rng-blame)] ...)
|
||||
|
|
@ -102,19 +122,23 @@
|
|||
(with-contract-continuation-mark
|
||||
(cons orig-blame neg-party)
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
#'rngs-list
|
||||
#'blame-party-info
|
||||
#'neg-party
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s kwd-vals args)))))
|
||||
(λ args
|
||||
(with-contract-continuation-mark
|
||||
(cons orig-blame neg-party)
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
#'rngs-list
|
||||
#'blame-party-info
|
||||
#'neg-party
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args))))))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark
|
||||
(cons contract-key (list p-app-x ...))))))))
|
||||
(cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
|
||||
(make-unconstrained-domain-> (list rngs-x ...)
|
||||
projection))))]))
|
||||
|
||||
|
|
@ -200,9 +224,9 @@
|
|||
(loop (cdr accepted) req-kwds (cdr opt-kwds))]
|
||||
[else #f]))])))
|
||||
|
||||
(define-for-syntax (create-chaperone blame neg-party val pre post this-args
|
||||
(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args
|
||||
doms opt-doms dom-rest req-kwds opt-kwds
|
||||
rngs)
|
||||
rngs rng-ctc-id)
|
||||
(with-syntax ([blame blame]
|
||||
[neg-party neg-party]
|
||||
[val val])
|
||||
|
|
@ -318,7 +342,9 @@
|
|||
(dom-ctc dom-x neg-party) ...)))])
|
||||
(if no-rng-checking?
|
||||
(inner-stx-gen #'())
|
||||
(check-tail-contract #'(rng-ctc ...)
|
||||
(check-tail-contract rng-ctc-id
|
||||
blame-party-info
|
||||
#'neg-party
|
||||
#'(rng-checker-name ...)
|
||||
inner-stx-gen)))]
|
||||
[kwd-return
|
||||
|
|
@ -340,7 +366,11 @@
|
|||
#`(let ([kwd-results kwd-stx])
|
||||
#,(if no-rng-checking?
|
||||
(outer-stx-gen #'())
|
||||
(check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))])
|
||||
(check-tail-contract rng-ctc-id
|
||||
blame-party-info
|
||||
#'neg-party
|
||||
#'(rng-checker-name ...)
|
||||
outer-stx-gen))))])
|
||||
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
|
||||
[basic-lambda #'(λ basic-params
|
||||
;; Arrow contract domain checking is instrumented
|
||||
|
|
@ -534,7 +564,8 @@
|
|||
(append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
|
||||
(base->-doms/c ctc)))]
|
||||
[doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))]
|
||||
[rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))]
|
||||
[rngs-ctc (base->-rngs/c ctc)]
|
||||
[rngs-proj (map get/build-late-neg-projection rngs-ctc)]
|
||||
[mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))]
|
||||
[optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
|
||||
[mandatory-keywords (base->-mandatory-kwds ctc)]
|
||||
|
|
@ -578,16 +609,18 @@
|
|||
(kwd-proj (blame-add-context orig-blame
|
||||
(format "the ~a argument of" kwd)
|
||||
#:swap? #t))))
|
||||
(define the-args (append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))
|
||||
(define the-args (cons rngs-ctc
|
||||
(append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges)))
|
||||
(define blame-party-info (get-blame-party-info orig-blame))
|
||||
(λ (val neg-party)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
|
||||
orig-blame neg-party)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords
|
||||
orig-blame neg-party))
|
||||
(define chap/imp-func (apply func orig-blame neg-party val the-args))
|
||||
(define chap/imp-func (apply func orig-blame neg-party blame-party-info val the-args))
|
||||
(if post
|
||||
(wrapper
|
||||
val
|
||||
|
|
@ -597,9 +630,8 @@
|
|||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key
|
||||
;; is this right?
|
||||
partial-ranges)))))))
|
||||
impersonator-prop:application-mark
|
||||
(cons tail-contract-key (list* neg-party blame-party-info rngs-ctc))))))))
|
||||
|
||||
(define (->-name ctc)
|
||||
(single-arrow-name-maker
|
||||
|
|
@ -811,19 +843,22 @@
|
|||
[(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
|
||||
(syntax->list kwd-ctcs))]
|
||||
[(kwds ...) kwds]
|
||||
[(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
|
||||
[use-any? use-any?])
|
||||
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
|
||||
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
|
||||
[outer-lambda
|
||||
#`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...)
|
||||
#`(lambda (blame neg-party blame-party-info val rng-ctc-x
|
||||
dom-names ... kwd-names ... rng-names ...)
|
||||
#,(create-chaperone
|
||||
#'blame #'neg-party #'val #f #f
|
||||
#'blame #'neg-party #'blame-party-info #'val #f #f
|
||||
(syntax->list #'(this-params ...))
|
||||
(syntax->list #'(dom-names ...)) null #f
|
||||
(map list (syntax->list #'(kwds ...))
|
||||
(syntax->list #'(kwd-names ...)))
|
||||
null
|
||||
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))])
|
||||
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))
|
||||
#'rng-ctc-x))])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(build--> '->
|
||||
|
|
@ -976,6 +1011,7 @@
|
|||
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
|
||||
[(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
|
||||
[(rng ...) (generate-temporaries (or rng-ctc '()))]
|
||||
[(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (car (generate-temporaries '(this))))])
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -996,7 +1032,7 @@
|
|||
#''())
|
||||
#,(if rng-ctc #f #t)
|
||||
mtd? ->m-ctc?
|
||||
(λ (blame neg-party f
|
||||
(λ (blame neg-party blame-party-info f rng-ctc-x
|
||||
mandatory-dom-proj ...
|
||||
#,@(if rest-ctc
|
||||
#'(rest-proj)
|
||||
|
|
@ -1006,7 +1042,7 @@
|
|||
optional-dom-kwd-proj ...
|
||||
rng-proj ...)
|
||||
#,(create-chaperone
|
||||
#'blame #'neg-party #'f pre post
|
||||
#'blame #'neg-party #'blame-party-info #'f pre post
|
||||
(syntax->list #'(this-parameter ...))
|
||||
(syntax->list #'(mandatory-dom-proj ...))
|
||||
(syntax->list #'(optional-dom-proj ...))
|
||||
|
|
@ -1015,7 +1051,8 @@
|
|||
(syntax->list #'(mandatory-dom-kwd-proj ...)))
|
||||
(map list (syntax->list #'(optional-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd-proj ...)))
|
||||
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))]))
|
||||
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)
|
||||
#'rng-ctc-x))))))))))]))
|
||||
|
||||
(define (convert-pre-post/desc-to-boolean pre? b)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -52,27 +52,29 @@
|
|||
[_
|
||||
(raise-syntax-error #f "expected ->" stx case)]))
|
||||
|
||||
(define-for-syntax (parse-out-case stx case n)
|
||||
(let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)])
|
||||
(with-syntax ([(dom-proj-x ...) (generate-temporaries doms)]
|
||||
(define-for-syntax (parse-out-case stx neg-party blame-party-info case n)
|
||||
(let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)])
|
||||
(with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)]
|
||||
[(rst-proj-x) (generate-temporaries '(rest-proj-x))]
|
||||
[(rng-proj-x ...) (generate-temporaries (if rng rng '()))])
|
||||
(with-syntax ([(dom-formals ...) (generate-temporaries doms)]
|
||||
[(rng-proj-x ...) (generate-temporaries (if rng-ctc-exprs rng-ctc-exprs '()))]
|
||||
[(rng-ctcs-x) (generate-temporaries '(rng-ctc-x))])
|
||||
(with-syntax ([(dom-formals ...) (generate-temporaries dom-ctc-exprs)]
|
||||
[(rst-formal) (generate-temporaries '(rest-param))]
|
||||
[(rng-id ...) (if rng
|
||||
(generate-temporaries rng)
|
||||
[(rng-id ...) (if rng-ctc-exprs
|
||||
(generate-temporaries rng-ctc-exprs)
|
||||
'())]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (car (generate-temporaries '(this))))])
|
||||
#`(#,doms
|
||||
#,rst
|
||||
#,(if rng #`(list #,@rng) #f)
|
||||
#,(length (syntax->list doms)) ;; spec
|
||||
(dom-proj-x ... #,@(if rst #'(rst-proj-x) #'()))
|
||||
#`(#,dom-ctc-exprs
|
||||
#,rst-ctc-expr
|
||||
#,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
|
||||
#,(length (syntax->list dom-ctc-exprs)) ;; spec
|
||||
(dom-proj-x ... #,@(if rst-ctc-expr #'(rst-proj-x) #'()))
|
||||
(rng-proj-x ...)
|
||||
(this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
|
||||
rng-ctcs-x
|
||||
(this-parameter ... dom-formals ... . #,(if rst-ctc-expr #'rst-formal '()))
|
||||
#,(cond
|
||||
[rng
|
||||
[rng-ctc-exprs
|
||||
(let ([rng-checkers
|
||||
(list #`(case-lambda
|
||||
[(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)]
|
||||
|
|
@ -81,19 +83,21 @@
|
|||
#,(length (syntax->list #'(rng-id ...)))
|
||||
args
|
||||
#,n)]))]
|
||||
[rng-length (length (syntax->list rng))])
|
||||
(if rst
|
||||
(check-tail-contract #'(rng-proj-x ...) rng-checkers
|
||||
[rng-length (length (syntax->list rng-ctc-exprs))])
|
||||
(if rst-ctc-expr
|
||||
(check-tail-contract #'rng-ctcs-x
|
||||
blame-party-info neg-party
|
||||
rng-checkers
|
||||
(λ (rng-checks)
|
||||
#`(apply values #,@rng-checks this-parameter ...
|
||||
(dom-proj-x dom-formals neg-party) ...
|
||||
(rst-proj-x rst-formal neg-party))))
|
||||
(check-tail-contract
|
||||
#'(rng-proj-x ...) rng-checkers
|
||||
#'rng-ctcs-x blame-party-info neg-party rng-checkers
|
||||
(λ (rng-checks)
|
||||
#`(values/drop #,@rng-checks this-parameter ...
|
||||
(dom-proj-x dom-formals neg-party) ...)))))]
|
||||
[rst
|
||||
[rst-ctc-expr
|
||||
#`(apply values this-parameter ...
|
||||
(dom-proj-x dom-formals neg-party) ...
|
||||
(rst-proj-x rst-formal neg-party))]
|
||||
|
|
@ -106,30 +110,33 @@
|
|||
[(_ cases ...)
|
||||
(let ()
|
||||
(define name (syntax-local-infer-name stx))
|
||||
(with-syntax ([(((dom-proj ...)
|
||||
rst-proj
|
||||
rng-proj
|
||||
(with-syntax ([(((dom-ctc-expr ...)
|
||||
rst-ctc-expr
|
||||
rng-ctc-exprs
|
||||
spec
|
||||
(dom-proj-x ...)
|
||||
(rng-proj-x ...)
|
||||
rng-ctcs-x
|
||||
formals
|
||||
body) ...)
|
||||
(for/list ([x (in-list (syntax->list #'(cases ...)))]
|
||||
[n (in-naturals)])
|
||||
(parse-out-case stx x n))]
|
||||
(parse-out-case stx #'neg-party #'blame-party-info x n))]
|
||||
[mctc? (and (syntax-parameter-value #'method-contract?) #t)])
|
||||
#`(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
(build-case->
|
||||
(list (list dom-proj ...) ...)
|
||||
(list rst-proj ...)
|
||||
(list rng-proj ...)
|
||||
(list (list dom-ctc-expr ...) ...)
|
||||
(list rst-ctc-expr ...)
|
||||
(list rng-ctc-exprs ...)
|
||||
'(spec ...)
|
||||
mctc?
|
||||
(λ (chk
|
||||
wrapper
|
||||
blame
|
||||
blame-party-info
|
||||
ctc
|
||||
rng-ctcs-x ...
|
||||
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
|
||||
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
|
||||
(λ (f neg-party)
|
||||
|
|
@ -139,12 +146,12 @@
|
|||
(if name
|
||||
#`(let ([#,name #,case-lam]) #,name)
|
||||
case-lam))
|
||||
(list (list rng-proj-x ...) ...)
|
||||
f blame neg-party wrapper ctc
|
||||
f blame neg-party blame-party-info wrapper ctc
|
||||
chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
|
||||
|
||||
(define (put-it-together the-case-lam range-projections f blame neg-party wrapper ctc chk mtd?)
|
||||
(define (put-it-together the-case-lam f blame neg-party blame-party-info wrapper ctc chk mtd?)
|
||||
(chk f mtd?)
|
||||
(define rng-ctcs (base-case->-rng-ctcs ctc))
|
||||
(define checker
|
||||
(make-keyword-procedure
|
||||
(raise-no-keywords-error f blame neg-party)
|
||||
|
|
@ -152,14 +159,15 @@
|
|||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(apply the-case-lam args)))))
|
||||
(define same-rngs (same-range-projections range-projections))
|
||||
(define same-rngs (same-range-contracts rng-ctcs))
|
||||
(if same-rngs
|
||||
(wrapper
|
||||
f
|
||||
checker
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party)
|
||||
impersonator-prop:application-mark (cons contract-key same-rngs))
|
||||
impersonator-prop:application-mark
|
||||
(cons tail-contract-key (list* neg-party blame-party-info same-rngs)))
|
||||
(wrapper
|
||||
f
|
||||
checker
|
||||
|
|
@ -184,13 +192,17 @@
|
|||
(define (case->-proj wrapper)
|
||||
(λ (ctc)
|
||||
(define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
|
||||
(define rng-late-neg-ctcs (map get/build-late-neg-projection (get-case->-rng-ctcs ctc)))
|
||||
(define rng-ctcs (get-case->-rng-ctcs ctc))
|
||||
(define rng-lol-ctcs (base-case->-rng-ctcs ctc))
|
||||
(define rng-late-neg-ctcs (map get/build-late-neg-projection rng-ctcs))
|
||||
(define rst-ctcs (base-case->-rst-ctcs ctc))
|
||||
(define specs (base-case->-specs ctc))
|
||||
(λ (blame)
|
||||
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
|
||||
(define rng-blame (blame-add-context blame "the range of"))
|
||||
(define projs (append (map (λ (f) ((cdr f)
|
||||
(define blame-party-info (get-blame-party-info blame))
|
||||
(define projs (append rng-lol-ctcs
|
||||
(map (λ (f) ((cdr f)
|
||||
(blame-add-context
|
||||
(blame-add-context
|
||||
blame
|
||||
|
|
@ -231,6 +243,7 @@
|
|||
chk
|
||||
wrapper
|
||||
blame
|
||||
blame-party-info
|
||||
ctc
|
||||
projs))))
|
||||
|
||||
|
|
@ -303,18 +316,23 @@
|
|||
|
||||
(define (get-case->-rng-ctcs ctc)
|
||||
(for/fold ([acc '()])
|
||||
([x (in-list (base-case->-rng-ctcs ctc))]
|
||||
#:when x)
|
||||
([x (in-list (base-case->-rng-ctcs ctc))]
|
||||
#:when x)
|
||||
(append acc x)))
|
||||
|
||||
;; Takes a list of (listof projection), and returns one of the
|
||||
;; lists if all the lists contain the same projections. If the list is
|
||||
;; null, it returns #f.
|
||||
(define (same-range-projections rng-ctcss)
|
||||
(if (null? rng-ctcss)
|
||||
#f
|
||||
(let* ([fst (car rng-ctcss)]
|
||||
[all-same? (for/and ([ps (in-list (cdr rng-ctcss))])
|
||||
(and (= (length fst) (length ps))
|
||||
(andmap procedure-closure-contents-eq? fst ps)))])
|
||||
(and all-same? fst))))
|
||||
(define (same-range-contracts rng-ctcss)
|
||||
(cond
|
||||
[(null? rng-ctcss) #f]
|
||||
[else
|
||||
(define fst (car rng-ctcss))
|
||||
(and (for/and ([ps (in-list (cdr rng-ctcss))])
|
||||
(and ps
|
||||
(= (length fst) (length ps))
|
||||
(for/and ([c (in-list ps)]
|
||||
[fst-c (in-list fst)])
|
||||
(and (contract-stronger? c fst-c)
|
||||
(contract-stronger? fst-c c)))))
|
||||
fst)]))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
opt/info-add-blame-context
|
||||
opt/info-change-val
|
||||
opt/info-positive-blame
|
||||
opt/info-negative-blame
|
||||
|
||||
opt/unknown
|
||||
opt-error-name
|
||||
|
|
@ -164,6 +165,10 @@
|
|||
(if (opt/info-swap-blame? oi)
|
||||
#`(blame-positive #,(opt/info-blame-original-id oi))
|
||||
#`(blame-negative #,(opt/info-blame-original-id oi))))
|
||||
(define (opt/info-negative-blame oi)
|
||||
(if (opt/info-swap-blame? oi)
|
||||
#`(blame-negative #,(opt/info-blame-original-id oi))
|
||||
#`(blame-positive #,(opt/info-blame-original-id oi))))
|
||||
|
||||
;; opt/info-swap-blame : opt/info -> opt/info
|
||||
;; swaps pos and neg
|
||||
|
|
|
|||
|
|
@ -576,7 +576,9 @@
|
|||
(syntax-case stx ()
|
||||
[(x) #'x]
|
||||
[(x ...) #'(values x ...)]))
|
||||
#`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)]
|
||||
#`(let* ([cont-mark-value (list* #,(opt/info-positive-blame opt/info)
|
||||
#,(opt/info-negative-blame opt/info)
|
||||
'#,rngs)]
|
||||
[exact-proc (case-lambda
|
||||
[(dom-arg ...)
|
||||
(let-values ([(rng-checker dom-vars ...)
|
||||
|
|
|
|||
|
|
@ -115,42 +115,50 @@
|
|||
|
||||
(define trail (make-parameter #f))
|
||||
(define (contract-struct-stronger? a b)
|
||||
(define prop (contract-struct-property a))
|
||||
(define stronger? (contract-property-stronger prop))
|
||||
(cond
|
||||
[(let ([th (trail)])
|
||||
(and th
|
||||
(for/or ([(a2 bs-h) (in-hash th)])
|
||||
(and (eq? a a2)
|
||||
(for/or ([(b2 _) (in-hash bs-h)])
|
||||
(eq? b b2))))))
|
||||
#t]
|
||||
[(or (prop:recursive-contract? a) (prop:recursive-contract? b))
|
||||
(parameterize ([trail (or (trail) (make-hasheq))])
|
||||
(define trail-h (trail))
|
||||
(let ([a-h (hash-ref trail-h a #f)])
|
||||
(cond
|
||||
[a-h
|
||||
(hash-set! a-h b #t)]
|
||||
[else
|
||||
(define a-h (make-hasheq))
|
||||
(hash-set! trail-h a a-h)
|
||||
(hash-set! a-h b #t)]))
|
||||
(contract-struct-stronger? (if (prop:recursive-contract? a)
|
||||
((prop:recursive-contract-unroll a) a)
|
||||
a)
|
||||
(if (prop:recursive-contract? b)
|
||||
((prop:recursive-contract-unroll b) b)
|
||||
b)))]
|
||||
[(equal? a b) #t]
|
||||
[else
|
||||
(let loop ([b b])
|
||||
(cond
|
||||
[(stronger? a b) #t]
|
||||
[(prop:orc-contract? b)
|
||||
(define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
|
||||
(for/or ([sub-contract (in-list sub-contracts)])
|
||||
(loop sub-contract))]
|
||||
[else #f]))]))
|
||||
(define prop (contract-struct-property a))
|
||||
(define stronger? (contract-property-stronger prop))
|
||||
(cond
|
||||
[(stronger? a b)
|
||||
;; optimistically try skip some of the more complex work below
|
||||
#t]
|
||||
[(let ([th (trail)])
|
||||
(and th
|
||||
(for/or ([(a2 bs-h) (in-hash th)])
|
||||
(and (eq? a a2)
|
||||
(for/or ([(b2 _) (in-hash bs-h)])
|
||||
(eq? b b2))))))
|
||||
#t]
|
||||
[(or (prop:recursive-contract? a) (prop:recursive-contract? b))
|
||||
(parameterize ([trail (or (trail) (make-hasheq))])
|
||||
(define trail-h (trail))
|
||||
(let ([a-h (hash-ref trail-h a #f)])
|
||||
(cond
|
||||
[a-h
|
||||
(hash-set! a-h b #t)]
|
||||
[else
|
||||
(define a-h (make-hasheq))
|
||||
(hash-set! trail-h a a-h)
|
||||
(hash-set! a-h b #t)]))
|
||||
(contract-struct-stronger? (if (prop:recursive-contract? a)
|
||||
((prop:recursive-contract-unroll a) a)
|
||||
a)
|
||||
(if (prop:recursive-contract? b)
|
||||
((prop:recursive-contract-unroll b) b)
|
||||
b)))]
|
||||
[else
|
||||
(let loop ([b b])
|
||||
(cond
|
||||
[(stronger? a b)
|
||||
#t]
|
||||
[(prop:orc-contract? b)
|
||||
(define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
|
||||
(for/or ([sub-contract (in-list sub-contracts)])
|
||||
(loop sub-contract))]
|
||||
[else
|
||||
#f]))])]))
|
||||
|
||||
(define (contract-struct-generate c)
|
||||
(define prop (contract-struct-property c))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user