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

contract stronger fix for contract structs

Browse Source
This commit is contained in:
Robby Findler 2012-04-05 23:16:43 -05:00
parent f6a8024aed
commit aaa15946fc
3 changed files with 30 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/racket/contract/private/ds-helpers.rkt
View File

@ -82,11 +82,14 @@ which are then called when the contract's fields are explored
[(id (x ...) ctc-exp) [(id (x ...) ctc-exp)
(and (identifier? (syntax id)) (and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) (let* ([proc-name (string->symbol (string-append (symbol->string (syntax-e #'id)) "-dep-proc"))]
[maker-arg #`(let ([#,proc-name
(λ #,(match-up (reverse prior-ac-ids)
(syntax (x ...)) (syntax (x ...))
field-names) field-names)
#,(defeat-inlining #,(defeat-inlining
#`(#,coerce-contract '#,name ctc-exp)))]) #`(#,coerce-contract '#,name ctc-exp)))])
#,proc-name)])
(loop (cdr clauses) (loop (cdr clauses)
(cdr ac-ids) (cdr ac-ids)
(cons (car ac-ids) prior-ac-ids) (cons (car ac-ids) prior-ac-ids)

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

@ -232,9 +232,18 @@ it around flattened out.
(define (stronger-lazy-contract? a b) (define (stronger-lazy-contract? a b)
(and (contract-predicate b) (and (contract-predicate b)
(contract-stronger? (let ([a-sel (contract-get a selector-indices)]
(contract-get a selector-indices) [b-sel (contract-get b selector-indices)])
(contract-get b selector-indices)) ...)) (if (contract-struct? a-sel)
(if (contract-struct? b-sel)
(contract-stronger? a-sel b-sel)
#f)
(if (contract-struct? b-sel)
#f
(begin
(printf "comparing ~s ~s ~s\n" a-sel b-sel (procedure-closure-contents-eq? a-sel b-sel))
(procedure-closure-contents-eq? a-sel b-sel)))))
...))
(define (lazy-contract-proj ctc) (define (lazy-contract-proj ctc)
(λ (blame) (λ (blame)

11
collects/tests/racket/contract-test.rktl
View File

@ -8770,6 +8770,7 @@
(contract-eval '(define-contract-struct couple (hd tl))) (contract-eval '(define-contract-struct couple (hd tl)))
(contract-eval '(contract-struct triple (a b c)))
(test/spec-passed (test/spec-passed
'd-c-s-match1 'd-c-s-match1
@ -9205,6 +9206,7 @@
'#t) '#t)
; ;
; ;
; ;
@ -10410,7 +10412,14 @@ so that propagation occurs.
(,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) (,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4))
(,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) (,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5))
(,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) (,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4))
(,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5)))) (,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5))
(letrec ([mk-c
(λ (x)
(triple/dc [a (<=/c x)]
[b any/c]
[c (a b) (or/c #f (mk-c a))]))])
(,test #t contract-stronger? (mk-c 1) (mk-c 2)))))