aboutsummaryrefslogtreecommitdiffhomepage
path: root/checker
diff options
context:
space:
mode:
Diffstat (limited to 'checker')
-rw-r--r--checker/checker.ml2
-rw-r--r--checker/cic.mli4
-rw-r--r--checker/declarations.ml6
-rw-r--r--checker/include1
-rw-r--r--checker/indtypes.ml17
-rw-r--r--checker/reduction.ml17
-rw-r--r--checker/subtyping.ml8
-rw-r--r--checker/univ.ml41
-rw-r--r--checker/univ.mli15
-rw-r--r--checker/values.ml13
10 files changed, 87 insertions, 37 deletions
diff --git a/checker/checker.ml b/checker/checker.ml
index b8b4d5dc2..e8eff889c 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -18,7 +18,7 @@ let () = at_exit flush_all
let chk_pp = Pp.pp_with Format.std_formatter
let fatal_error info anomaly =
- flush_all (); Feedback.msg_error info; flush_all ();
+ flush_all (); Format.eprintf "@[Fatal Error: @[%a@]@]%!@\n" Pp.pp_with info; flush_all ();
exit (if anomaly then 129 else 1)
let coq_root = Id.of_string "Coq"
diff --git a/checker/cic.mli b/checker/cic.mli
index 95dd18f5f..1f4322dff 100644
--- a/checker/cic.mli
+++ b/checker/cic.mli
@@ -358,9 +358,7 @@ type ('ty,'a) functorize =
and won't play any role into the kernel after that : they are kept
only for short module printing and for extraction. *)
-type with_declaration =
- | WithMod of Id.t list * ModPath.t
- | WithDef of Id.t list * (constr * Univ.universe_context)
+type with_declaration
type module_alg_expr =
| MEident of ModPath.t
diff --git a/checker/declarations.ml b/checker/declarations.ml
index 15b1f0a0c..2fe930dca 100644
--- a/checker/declarations.ml
+++ b/checker/declarations.ml
@@ -573,14 +573,10 @@ let implem_map fs fa = function
| Algebraic a -> Algebraic (fa a)
| impl -> impl
-let subst_with_body sub = function
- | WithMod(id,mp) -> WithMod(id,subst_mp sub mp)
- | WithDef(id,(c,ctx)) -> WithDef(id,(subst_mps sub c,ctx))
-
let rec subst_expr sub = function
| MEident mp -> MEident (subst_mp sub mp)
| MEapply (me1,mp2)-> MEapply (subst_expr sub me1, subst_mp sub mp2)
- | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd)
+ | MEwith (me,wd)-> MEwith (subst_expr sub me, wd)
let rec subst_expression sub me =
functor_map (subst_module_type sub) (subst_expr sub) me
diff --git a/checker/include b/checker/include
index 09bf2826c..da0346359 100644
--- a/checker/include
+++ b/checker/include
@@ -13,7 +13,6 @@
#directory "kernel";;
#directory "checker";;
#directory "+threads";;
-#directory "+camlp4";;
#directory "+camlp5";;
#load "unix.cma";;
diff --git a/checker/indtypes.ml b/checker/indtypes.ml
index 4de597766..1807ae0ec 100644
--- a/checker/indtypes.ml
+++ b/checker/indtypes.ml
@@ -564,14 +564,23 @@ let check_subtyping cumi paramsctxt env inds =
We must produce the substitution σ : [ Var(i) -> Var (i + n) | 0 <= i < n]
and push the constraints [ Var(n) ... Var(2n - 1) |- cst{σ} ], together
with the cumulativity constraints [ cumul_cst ]. *)
- let len = AUContext.size (ACumulativityInfo.univ_context cumi) in
- let inst = Instance.of_array (Array.init len (fun i -> Level.var (i + len))) in
+ let uctx = ACumulativityInfo.univ_context cumi in
+ let len = AUContext.size uctx in
+ let inst = Instance.of_array @@ Array.init len (fun i -> Level.var (i + len)) in
+
let other_context = ACumulativityInfo.univ_context cumi in
let uctx_other = UContext.make (inst, AUContext.instantiate inst other_context) in
- let cumul_context = AUContext.repr (ACumulativityInfo.subtyp_context cumi) in
- let cumul_cst = UContext.constraints cumul_context in
+ let cumul_cst =
+ Array.fold_left_i (fun i csts var ->
+ match var with
+ | Variance.Irrelevant -> csts
+ | Variance.Covariant -> Constraint.add (Level.var i,Le,Level.var (i+len)) csts
+ | Variance.Invariant -> Constraint.add (Level.var i,Eq,Level.var (i+len)) csts)
+ Constraint.empty (ACumulativityInfo.variance cumi)
+ in
let env = Environ.push_context uctx_other env in
let env = Environ.add_constraints cumul_cst env in
+
(* process individual inductive types: *)
Array.iter (fun { mind_user_lc = lc; mind_arity = arity } ->
match arity with
diff --git a/checker/reduction.ml b/checker/reduction.ml
index b91674b1e..d7d742d8a 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -158,24 +158,17 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 =
let convert_inductive_instances cv_pb cumi u u' univs =
let len_instance =
Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in
- let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in
if not ((len_instance = Univ.Instance.length u) &&
(len_instance = Univ.Instance.length u')) then
anomaly (Pp.str "Invalid inductive subtyping encountered!")
else
- let comp_cst =
- let comp_subst = (Univ.Instance.append u u') in
- Univ.AUContext.instantiate comp_subst ind_subtypctx
- in
+ let variance = Univ.ACumulativityInfo.variance cumi in
let comp_cst =
match cv_pb with
- CONV ->
- let comp_cst' =
- let comp_subst = (Univ.Instance.append u' u) in
- Univ.AUContext.instantiate comp_subst ind_subtypctx
- in
- Univ.Constraint.union comp_cst comp_cst'
- | CUMUL -> comp_cst
+ | CONV ->
+ Univ.Variance.eq_constraints variance u u' Univ.Constraint.empty
+ | CUMUL ->
+ Univ.Variance.leq_constraints variance u u' Univ.Constraint.empty
in
if (Univ.check_constraints comp_cst univs) then () else raise NotConvertible
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
index 98a9c8250..77201c25b 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 7d01657df..ebc37bc10 100644
--- a/checker/univ.ml
+++ b/checker/univ.ml
@@ -1003,12 +1003,49 @@ end
type abstract_universe_context = AUContext.t
+module Variance =
+struct
+ (** A universe position in the instance given to a cumulative
+ inductive can be the following. Note there is no Contravariant
+ case because [forall x : A, B <= forall x : A', B'] requires [A =
+ 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
+ | Covariant -> Constraint.add (u, Le, u') csts
+ | Invariant -> Constraint.add (u, Eq, u') csts
+
+ let eq_constraint csts variance u u' =
+ match variance with
+ | Irrelevant -> csts
+ | Covariant | Invariant -> Constraint.add (u, Eq, u') csts
+
+ let leq_constraints variance u u' csts =
+ let len = Array.length u in
+ assert (len = Array.length u' && len = Array.length variance);
+ Array.fold_left3 leq_constraint csts variance u u'
+
+ let eq_constraints variance u u' csts =
+ let len = Array.length u in
+ assert (len = Array.length u' && len = Array.length variance);
+ Array.fold_left3 eq_constraint csts variance u u'
+end
+
module CumulativityInfo =
struct
- type t = universe_context * universe_context
+ type t = universe_context * Variance.t array
let univ_context (univcst, subtypcst) = univcst
- let subtyp_context (univcst, subtypcst) = subtypcst
+ let variance (univs, variance) = variance
end
diff --git a/checker/univ.mli b/checker/univ.mli
index 21c94d952..32e48f593 100644
--- a/checker/univ.mli
+++ b/checker/univ.mli
@@ -218,12 +218,25 @@ end
type abstract_universe_context = AUContext.t
+module Variance :
+sig
+ (** A universe position in the instance given to a cumulative
+ inductive can be the following. Note there is no Contravariant
+ 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
+
+
module ACumulativityInfo :
sig
type t
val univ_context : t -> abstract_universe_context
- val subtyp_context : t -> abstract_universe_context
+ val variance : t -> Variance.t array
end
diff --git a/checker/values.ml b/checker/values.ml
index 313067cb6..283adca03 100644
--- a/checker/values.ml
+++ b/checker/values.ml
@@ -13,7 +13,7 @@
To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli
with a copy we maintain here:
-MD5 483493b20fe91cc1bea4350a2db2f82d checker/cic.mli
+MD5 79ed7b5c069b1994bf1a8d2cec22bdce checker/cic.mli
*)
@@ -110,10 +110,12 @@ let v_cstrs =
(v_tuple "univ_constraint"
[|v_level;v_enum "order_request" 3;v_level|]))
+let v_variance = v_enum "variance" 3
+
let v_instance = Annot ("instance", Array v_level)
let v_context = v_tuple "universe_context" [|v_instance;v_cstrs|]
let v_abs_context = v_context (* only for clarity *)
-let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; v_context|]
+let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; Array v_variance|]
let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|]
(** kernel/term *)
@@ -293,16 +295,11 @@ let v_ind_pack = v_tuple "mutual_inductive_body"
Opt v_bool;
v_typing_flags|]
-let v_with =
- Sum ("with_declaration_body",0,
- [|[|List v_id;v_mp|];
- [|List v_id;v_tuple "with_def" [|v_constr;v_context|]|]|])
-
let rec v_mae =
Sum ("module_alg_expr",0,
[|[|v_mp|]; (* SEBident *)
[|v_mae;v_mp|]; (* SEBapply *)
- [|v_mae;v_with|] (* SEBwith *)
+ [|v_mae; Any|] (* SEBwith *)
|])
let rec v_sfb =
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 04:11:37 +0000