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

improve contract-stronger and related things

Browse Source 
Specifically, add a mechanism so that contract combinators
can accumulate contracts on a value (instead just storing
only one) and then use that in instanceof/c to avoid
putting contracts on values more often.

Also, fill in better contract-stronger implementations in
some of the combinators
This commit is contained in:
Robby Findler 2014-09-19 12:53:33 -05:00
parent 837abdd51a
commit a0880f7403
6 changed files with 92 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/collects/racket/contract/base.rkt
View File

@ -64,6 +64,7 @@
;; from private/guts.rkt
has-contract?
value-contract
value-contracts-and-blames
has-blame?
value-blame
contract-continuation-mark-key

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

@ -845,22 +845,22 @@ evaluted left-to-right.)
#`(λ #,wrapper-proc-arglist
(λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(let ([arg-checker
(λ #,(args/vars->arglist an-istx wrapper-args this-param)
#,wrapper-body)])
(impersonate-procedure
val
(make-keyword-procedure
(λ (kwds kwd-args . args)
(with-continuation-mark
contract-continuation-mark-key blame
(keyword-apply arg-checker kwds kwd-args args)))
(λ args
(with-continuation-mark
contract-continuation-mark-key blame
(apply arg-checker args))))
(let ([arg-checker
(λ #,(args/vars->arglist an-istx wrapper-args this-param)
#,wrapper-body)])
(make-keyword-procedure
(λ (kwds kwd-args . args)
(with-continuation-mark
contract-continuation-mark-key blame
(keyword-apply arg-checker kwds kwd-args args)))
(λ args
(with-continuation-mark
contract-continuation-mark-key blame
(apply arg-checker args)))))
impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))))
impersonator-prop:blame blame))))))
(define-for-syntax (arg/res-to-indy-var indy-arg-vars ordered-args indy-res-vars ordered-ress var)
(define (try vars ordered)

19
racket/collects/racket/contract/private/base.rkt
View File

@ -131,7 +131,8 @@
(define (force-recursive-contract ctc)
(define current (recursive-contract-ctc ctc))
(cond
[(or (symbol? current) (not current))
[(already-forced? ctc) current]
[else
(define thunk (recursive-contract-thunk ctc))
(define old-name (recursive-contract-name ctc))
(set-recursive-contract-name! ctc (or current '<recursive-contract>))
@ -149,9 +150,12 @@
(set-recursive-contract-ctc! ctc forced-ctc)
(set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
(cddr old-name)))
forced-ctc]
[else current]))
forced-ctc]))
(define (already-forced? ctc)
(define current (recursive-contract-ctc ctc))
(and current (not (symbol? current))))
(define (recursive-contract-projection ctc)
(cond
[(recursive-contract-list-contract? ctc)
@ -176,8 +180,13 @@
(define (recursive-contract-stronger this that)
(and (recursive-contract? that)
(procedure-closure-contents-eq? (recursive-contract-thunk this)
(recursive-contract-thunk that))))
(or (procedure-closure-contents-eq? (recursive-contract-thunk this)
(recursive-contract-thunk that))
(if (and (already-forced? this)
(already-forced? that))
(contract-stronger? (recursive-contract-ctc this)
(recursive-contract-ctc that))
#f))))
(define ((recursive-contract-first-order ctc) val)
(contract-first-order-passes? (force-recursive-contract ctc)

6
racket/collects/racket/contract/private/blame.rkt
View File

@ -19,11 +19,17 @@
blame-add-missing-party
blame-same-parties?
raise-blame-error
current-blame-format
(struct-out exn:fail:contract:blame)
blame-fmt->-string)
(define (blame-same-parties? a b)
(and (equal? (blame-positive a) (blame-positive b))
(equal? (blame-negative a) (blame-negative b))))
(define (blame=? a b equal?/recur)
(and (equal?/recur (blame-source a) (blame-source b))
(equal?/recur (blame-value a) (blame-value b))

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

@ -27,8 +27,14 @@
contract-first-order-passes?
prop:contracted prop:blame
impersonator-prop:contracted impersonator-prop:blame
impersonator-prop:contracts+blames
value-contracts-and-blames
impersonator-prop:contracted
has-contract? value-contract
impersonator-prop:blame
has-blame? value-blame
;; for opters
@ -64,12 +70,29 @@
(or (has-prop:contracted? v)
(has-impersonator-prop:contracted? v)))
(define (value-contracts-and-blames v)
(cond
[(and (has-prop:contracted? v)
(has-prop:blame? v))
(list (list (get-prop:contracted v)
(get-prop:blame v)))]
[(and (has-impersonator-prop:contracted? v)
(has-impersonator-prop:blame? v))
(list (list (get-prop:contracted v)
(get-prop:blame v)))]
[(has-impersonator-prop:contracts+blames? v)
(get-impersonator-prop:contracts+blames v)]
[else '()]))
(define (value-contract v)
(cond
[(has-prop:contracted? v)
(get-prop:contracted v)]
[(has-impersonator-prop:contracted? v)
(get-impersonator-prop:contracted v)]
[(has-impersonator-prop:contracts+blames? v)
(define l (get-impersonator-prop:contracts+blames v))
(list-ref (car l) 0)]
[else #f]))
(define (has-blame? v)
@ -82,6 +105,9 @@
(get-prop:blame v)]
[(has-impersonator-prop:blame? v)
(get-impersonator-prop:blame v)]
[(has-impersonator-prop:contracts+blames? v)
(define l (get-impersonator-prop:contracts+blames v))
(list-ref (car l) 1)]
[else #f]))
(define-values (prop:contracted has-prop:contracted? get-prop:contracted)
@ -111,8 +137,14 @@
get-impersonator-prop:contracted)
(make-impersonator-property 'impersonator-prop:contracted))
;; bound to (non-empty-listof (list contract blame))
(define-values (impersonator-prop:contracts+blames
has-impersonator-prop:contracts+blames?
get-impersonator-prop:contracts+blames)
(make-impersonator-property 'impersonator-prop:contracts+blames))
(define-values (impersonator-prop:blame
has-impersonator-prop:blame?
has-impersonator-prop:blame?
get-impersonator-prop:blame)
(make-impersonator-property 'impersonator-prop:blame))

28
racket/collects/racket/private/class-c-old.rkt
View File

@ -825,6 +825,7 @@
absents absent-fields
internal opaque? name)
#:omit-define-syntaxes
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:projection class/c-proj
@ -1118,6 +1119,7 @@
(λ args (ret #f))))))
(define-struct base-object/c (methods method-contracts fields field-contracts)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:projection object/c-proj
@ -1177,9 +1179,20 @@
(wrapped-class-info-neg-field-projs the-info)
neg-party)]
[else
(impersonate-struct val object-ref (λ (o c) new-cls)
impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj)]))))
(define old-contracts-and-blames (value-contracts-and-blames val))
(cond
[(ormap (λ (pr)
(define old-ctc (list-ref pr 0))
(define old-blame (list-ref pr 1))
(and (contract-stronger? old-ctc ctc)
(blame-same-parties? old-blame blame)))
old-contracts-and-blames)
val]
[else
(impersonate-struct val object-ref (λ (o c) new-cls)
impersonator-prop:contracts+blames
(cons (list ctc blame) old-contracts-and-blames)
impersonator-prop:original-object original-obj)])]))))
(define (instanceof/c-first-order ctc)
(let ([cls-ctc (base-instanceof/c-class-ctc ctc)])
@ -1187,14 +1200,21 @@
(and (object? val)
(contract-first-order-passes? cls-ctc (object-ref val))))))
(define (instanceof/c-stronger this that)
(and (base-instanceof/c? that)
(contract-stronger? (base-instanceof/c-class-ctc this)
(base-instanceof/c-class-ctc that))))
(define-struct base-instanceof/c (class-ctc)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:projection instanceof/c-proj
#:name
(λ (ctc)
(build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
#:first-order instanceof/c-first-order))
#:first-order instanceof/c-first-order
#:stronger instanceof/c-stronger))
(define (instanceof/c cctc)
(let ([ctc (coerce-contract 'instanceof/c cctc)])