fix struct/dc's flat-contract mode predicate
This commit is contained in:
parent
a1fd690201
commit
8b0e23d15a
|
@ -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 ()
|
||||||
|
|
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user