diff options
Diffstat (limited to 'checker')
| -rw-r--r-- | checker/reduction.ml | 2 | ||||
| -rw-r--r-- | checker/subtyping.ml | 8 | ||||
| -rw-r--r-- | checker/univ.ml | 7 | ||||
| -rw-r--r-- | checker/univ.mli | 2 |
4 files changed, 16 insertions, 3 deletions
diff --git a/checker/reduction.ml b/checker/reduction.ml index 2297c90b3f..d7d742d8a0 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -582,7 +582,6 @@ let dest_prod_assum env = | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (d::l) c - | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_all env rty in if Term.eq_constr rty' rty then l, rty @@ -600,7 +599,6 @@ let dest_lam_assum env = | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (d::l) c - | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in lamec_rec env empty_rel_context diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 98a9c8250d..77201c25b1 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -108,6 +108,14 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let env = check_polymorphic_instance error env auctx auctx' in env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> + (** Currently there is no way to control variance of inductive types, but + just in case we require that they are in a subtyping relation. *) + let () = + let v = Univ.ACumulativityInfo.variance cumi in + let v' = Univ.ACumulativityInfo.variance cumi' in + if not (Array.for_all2 Univ.Variance.check_subtype v' v) then + CErrors.anomaly Pp.(str "Variance mismatch for " ++ MutInd.print kn) + in let auctx = Univ.ACumulativityInfo.univ_context cumi in let auctx' = Univ.ACumulativityInfo.univ_context cumi' in let env = check_polymorphic_instance error env auctx auctx' in diff --git a/checker/univ.ml b/checker/univ.ml index 46b3ce6808..ebc37bc10c 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -1011,6 +1011,13 @@ struct A'] as opposed to [A' <= A]. *) type t = Irrelevant | Covariant | Invariant + let check_subtype x y = match x, y with + | (Irrelevant | Covariant | Invariant), Irrelevant -> true + | Irrelevant, Covariant -> false + | (Covariant | Invariant), Covariant -> true + | (Irrelevant | Covariant), Invariant -> false + | Invariant, Invariant -> true + let leq_constraint csts variance u u' = match variance with | Irrelevant -> csts diff --git a/checker/univ.mli b/checker/univ.mli index 8c0685e0b2..32e48f5931 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -225,7 +225,7 @@ sig case because [forall x : A, B <= forall x : A', B'] requires [A = A'] as opposed to [A' <= A]. *) type t = Irrelevant | Covariant | Invariant - + val check_subtype : t -> t -> bool val leq_constraints : t array -> Instance.t constraint_function val eq_constraints : t array -> Instance.t constraint_function end |