fix struct/dc's flat-contract mode predicate

This commit is contained in:
Robby Findler 2014-05-12 10:04:13 -05:00
parent a1fd690201
commit 8b0e23d15a
2 changed files with 25 additions and 7 deletions

View File

@ -1074,6 +1074,20 @@
'pos 'pos
'neg))) 'neg)))
(test/spec-passed/result
'struct/dc-inv6
'(let ()
(struct s (f))
((struct/dc s [f any/c] #:inv (f) (equal? f 11)) (s 12)))
#f)
(test/spec-passed/result
'struct/dc-inv7
'(let ()
(struct s (f))
((struct/dc s [f any/c] #:inv (f) (equal? f 11)) (s 11)))
#t)
(contract-error-test (contract-error-test
'struct/dc-imp-nondep-runtime-error 'struct/dc-imp-nondep-runtime-error
'(let () '(let ()

View File

@ -176,15 +176,19 @@
(cond (cond
[(null? subcs) #t] [(null? subcs) #t]
[else [else
(define subc (car subcs)) (define subc (car subcs))
(define val ((subcontract-ref subc) v))
(cond (cond
[(indep? subc) [(invariant? subc)
(and ((flat-contract-predicate (indep-ctc subc)) val) (apply (invariant-dep-proc subc) args)]
(loop (cdr subcs) (cons val args)))]
[else [else
(and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val) (define val ((subcontract-ref subc) v))
(loop (cdr subcs) (cons val args)))])]))))) (cond
[(indep? subc)
(and ((flat-contract-predicate (indep-ctc subc)) val)
(loop (cdr subcs) (cons val args)))]
[else
(and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
(loop (cdr subcs) (cons val args)))])])])))))
(define (struct/dc-first-order ctc) (define (struct/dc-first-order ctc)
(base-struct/dc-pred ctc)) (base-struct/dc-pred ctc))