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

fix cons/dc's predicate

Browse Source
This commit is contained in:
Robby Findler 2017-05-12 11:09:42 -05:00
parent 8f34b702ab
commit 65beb4de4c
2 changed files with 13 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -200,6 +200,9 @@
(list #t 1)
#f)
(test-flat-contract '(cons/dc [hd 1] [tl (hd) 3] #:flat) (cons 1 3) (cons 1 4))
(test-flat-contract '(cons/dc [hd (tl) 1] [tl 3] #:flat) (cons 1 3) (cons 1 4))
(test-flat-contract '(box/c boolean? #:flat? #t) (box #f) (box 1))
(test-flat-contract '(box/c (flat-contract boolean?) #:flat? #t) (box #t) #f)
(test-flat-contract '(box-immutable/c boolean?) (box-immutable #f) (box-immutable 1))

13
racket/collects/racket/contract/private/list.rkt
View File

@ -484,9 +484,16 @@
(define (cons/dc-first-order ctc)
(λ (val)
(and (pair? val)
(contract-first-order-passes?
(the-cons/dc-undep ctc)
(if (the-cons/dc-forwards? ctc) (car val) (cdr val))))))
(let-values ([(undep-val dep-val)
(if (the-cons/dc-forwards? ctc)
(values (car val) (cdr val))
(values (cdr val) (car val)))])
(and (contract-first-order-passes?
(the-cons/dc-undep ctc)
undep-val)
(contract-first-order-passes?
((the-cons/dc-dep ctc) undep-val)
dep-val))))))
(define (cons/dc-stronger? this that) #f)