aboutsummaryrefslogtreecommitdiff
path: root/checker
diff options
context:
space:
mode:
Diffstat (limited to 'checker')
-rw-r--r--checker/cic.mli11
-rw-r--r--checker/closure.ml3
-rw-r--r--checker/environ.ml11
-rw-r--r--checker/mod_checking.ml27
-rw-r--r--checker/subtyping.ml102
-rw-r--r--checker/typeops.ml2
-rw-r--r--checker/univ.ml42
-rw-r--r--checker/univ.mli2
-rw-r--r--checker/values.ml12
9 files changed, 40 insertions, 172 deletions
diff --git a/checker/cic.mli b/checker/cic.mli
index 3304b032e6..a890f2cef5 100644
--- a/checker/cic.mli
+++ b/checker/cic.mli
@@ -207,7 +207,7 @@ type inline = int option
always transparent. *)
type projection_body = {
- proj_ind : MutInd.t;
+ proj_ind : inductive;
proj_npars : int;
proj_arg : int;
proj_type : constr; (* Type under params *)
@@ -252,9 +252,10 @@ type recarg =
type wf_paths = recarg Rtree.t
-type record_body = (Id.t * Constant.t array * projection_body array) option
- (* The body is empty for non-primitive records, otherwise we get its
- binder name in projections and list of projections if it is primitive. *)
+type record_info =
+| NotRecord
+| FakeRecord
+| PrimRecord of (Id.t * Constant.t array * projection_body array) array
type regular_inductive_arity = {
mind_user_arity : constr;
@@ -322,7 +323,7 @@ type mutual_inductive_body = {
mind_packets : one_inductive_body array; (** The component of the mutual inductive block *)
- mind_record : record_body option; (** Whether the inductive type has been declared as a record. *)
+ mind_record : record_info; (** Whether the inductive type has been declared as a record. *)
mind_finite : recursivity_kind; (** Whether the type is inductive or coinductive *)
diff --git a/checker/closure.ml b/checker/closure.ml
index b9ae4daa86..2dcc1a9840 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -619,7 +619,8 @@ let drop_parameters depth n argstk =
let eta_expand_ind_stack env ind m s (f, s') =
let mib = lookup_mind (fst ind) env in
match mib.mind_record with
- | Some (Some (_,projs,pbs)) when mib.mind_finite <> CoFinite ->
+ | PrimRecord info when mib.mind_finite <> CoFinite ->
+ let (_, projs, pbs) = info.(snd ind) in
(* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
let pars = mib.mind_nparams in
diff --git a/checker/environ.ml b/checker/environ.ml
index 3d5fac8066..ba1eb0ddb4 100644
--- a/checker/environ.ml
+++ b/checker/environ.ml
@@ -192,11 +192,12 @@ let add_mind kn mib env =
(MutInd.to_string kn);
let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
let new_projections = match mib.mind_record with
- | None | Some None -> env.env_globals.env_projections
- | Some (Some (id, kns, pbs)) ->
- Array.fold_left2 (fun projs kn pb ->
- Cmap_env.add kn pb projs)
- env.env_globals.env_projections kns pbs
+ | NotRecord | FakeRecord -> env.env_globals.env_projections
+ | PrimRecord projs ->
+ Array.fold_left (fun accu (id, kns, pbs) ->
+ Array.fold_left2 (fun accu kn pb ->
+ Cmap_env.add kn pb accu) accu kns pbs)
+ env.env_globals.env_projections projs
in
let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in
let new_inds_eq = if KerName.equal kn1 kn2 then
diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml
index ca9581167f..6b2af71f33 100644
--- a/checker/mod_checking.ml
+++ b/checker/mod_checking.ml
@@ -2,7 +2,6 @@ open Pp
open Util
open Names
open Cic
-open Term
open Reduction
open Typeops
open Indtypes
@@ -13,17 +12,6 @@ open Environ
(** {6 Checking constants } *)
-let refresh_arity ar =
- let ctxt, hd = decompose_prod_assum ar in
- match hd with
- Sort (Type u) when not (Univ.is_univ_variable u) ->
- let ul = Univ.Level.make DirPath.empty 1 in
- let u' = Univ.Universe.make ul in
- let cst = Univ.enforce_leq u u' Univ.empty_constraint in
- let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in
- mkArity (ctxt,Prop Null), ctx
- | _ -> ar, Univ.ContextSet.empty
-
let check_constant_declaration env kn cb =
Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ prcon kn);
(** Locally set the oracle for further typechecking *)
@@ -37,18 +25,13 @@ let check_constant_declaration env kn cb =
let ctx = Univ.AUContext.repr auctx in
push_context ~strict:false ctx env
in
- let envty, ty =
- let ty = cb.const_type in
- let ty', cu = refresh_arity ty in
- let envty = push_context_set cu env' in
- let _ = infer_type envty ty' in
- envty, ty
- in
- let () =
+ let ty = cb.const_type in
+ let _ = infer_type env' ty in
+ let () =
match body_of_constant cb with
| Some bd ->
- let j = infer envty bd in
- conv_leq envty j ty
+ let j = infer env' bd in
+ conv_leq env' j ty
| None -> ()
in
let env =
diff --git a/checker/subtyping.ml b/checker/subtyping.ml
index f4ae02084d..6d0d6f6c6d 100644
--- a/checker/subtyping.ml
+++ b/checker/subtyping.ml
@@ -9,7 +9,6 @@
(************************************************************************)
(*i*)
-open CErrors
open Util
open Names
open Cic
@@ -126,46 +125,13 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2=
in
let eq_projection_body p1 p2 =
let check eq f = if not (eq (f p1) (f p2)) then error () in
- check MutInd.equal (fun x -> x.proj_ind);
+ check eq_ind (fun x -> x.proj_ind);
check (==) (fun x -> x.proj_npars);
check (==) (fun x -> x.proj_arg);
check (eq_constr) (fun x -> x.proj_type);
true
in
- let check_inductive_type t1 t2 =
-
- (* Due to template polymorphism, the conclusions of
- t1 and t2, if in Type, are generated as the least upper bounds
- of the types of the constructors.
-
- By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U
- |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
- universe in the conclusion of t1 has an bounding universe in
- the conclusion of t2, so that we don't need to check the
- subtyping of the conclusions of t1 and t2.
-
- Even if we'd like to recheck it, the inference of constraints
- is not designed to deal with algebraic constraints of the form
- max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy
- to recheck it (in short, we would need the actual graph of
- constraints as input while type checking is currently designed
- to output a set of constraints instead) *)
-
- (* So we cheat and replace the subtyping problem on algebraic
- constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n)
- (that we know are necessary true) by trivial constraints that
- the constraint generator knows how to deal with *)
-
- let (ctx1,s1) = dest_arity env t1 in
- let (ctx2,s2) = dest_arity env t2 in
- let s1,s2 =
- match s1, s2 with
- | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null
- | (Prop _, Type _) | (Type _,Prop _) -> error ()
- | _ -> (s1, s2) in
- check_conv conv_leq env
- (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
- in
+ let check_inductive_type t1 t2 = check_conv conv_leq env t1 t2 in
let check_packet p1 p2 =
let check eq f = if not (eq (f p1) (f p2)) then error () in
@@ -218,16 +184,19 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2=
(* we check that records and their field names are preserved. *)
let record_equal x y =
match x, y with
- | None, None -> true
- | Some None, Some None -> true
- | Some (Some (id1,p1,pb1)), Some (Some (id2,p2,pb2)) ->
- Id.equal id1 id2 &&
- Array.for_all2 Constant.UserOrd.equal p1 p2 &&
- Array.for_all2 eq_projection_body pb1 pb2
+ | NotRecord, NotRecord -> true
+ | FakeRecord, FakeRecord -> true
+ | PrimRecord info1, PrimRecord info2 ->
+ let check (id1, p1, pb1) (id2, p2, pb2) =
+ Id.equal id1 id2 &&
+ Array.for_all2 Constant.UserOrd.equal p1 p2 &&
+ Array.for_all2 eq_projection_body pb1 pb2
+ in
+ Array.equal check info1 info2
| _, _ -> false
in
check record_equal (fun mib -> mib.mind_record);
- if mib1.mind_record != None then begin
+ if mib1.mind_record != NotRecord then begin
let rec names_prod_letin t = match t with
| Prod(n,_,t) -> n::(names_prod_letin t)
| LetIn(n,_,_,t) -> n::(names_prod_letin t)
@@ -251,52 +220,7 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2=
let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 =
let error () = error_not_match l spec2 in
let check_conv f = check_conv_error error f in
- let check_type env t1 t2 =
-
- (* If the type of a constant is generated, it may mention
- non-variable algebraic universes that the general conversion
- algorithm is not ready to handle. Anyway, generated types of
- constants are functions of the body of the constant. If the
- bodies are the same in environments that are subtypes one of
- the other, the types are subtypes too (i.e. if Gamma <= Gamma',
- Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
- Hence they don't have to be checked again *)
-
- let t1,t2 =
- if isArity t2 then
- let (ctx2,s2) = destArity t2 in
- match s2 with
- | Type v when not (Univ.is_univ_variable v) ->
- (* The type in the interface is inferred and is made of algebraic
- universes *)
- begin try
- let (ctx1,s1) = dest_arity env t1 in
- match s1 with
- | Type u when not (Univ.is_univ_variable u) ->
- (* Both types are inferred, no need to recheck them. We
- cheat and collapse the types to Prop *)
- mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
- | Prop _ ->
- (* The type in the interface is inferred, it may be the case
- that the type in the implementation is smaller because
- the body is more reduced. We safely collapse the upper
- type to Prop *)
- mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null)
- | Type _ ->
- (* The type in the interface is inferred and the type in the
- implementation is not inferred or is inferred but from a
- more reduced body so that it is just a variable. Since
- constraints of the form "univ <= max(...)" are not
- expressible in the system of algebraic universes: we fail
- (the user has to use an explicit type in the interface *)
- error ()
- with UserError _ (* "not an arity" *) ->
- error () end
- | _ -> t1,t2
- else
- (t1,t2) in
- check_conv conv_leq env t1 t2
- in
+ let check_type env t1 t2 = check_conv conv_leq env t1 t2 in
match info1 with
| Constant cb1 ->
let cb1 = subst_const_body subst1 cb1 in
diff --git a/checker/typeops.ml b/checker/typeops.ml
index 18f07dc0b7..345ee5b8ff 100644
--- a/checker/typeops.ml
+++ b/checker/typeops.ml
@@ -203,7 +203,7 @@ let judge_of_projection env p c ct =
try find_rectype env ct
with Not_found -> error_case_not_inductive env (c, ct)
in
- assert(MutInd.equal pb.proj_ind (fst ind));
+ assert(eq_ind pb.proj_ind ind);
let ty = subst_instance_constr u pb.proj_type in
substl (c :: List.rev args) ty
diff --git a/checker/univ.ml b/checker/univ.ml
index 15673736f2..e50e883adf 100644
--- a/checker/univ.ml
+++ b/checker/univ.ml
@@ -190,13 +190,6 @@ struct
(let (u,n) = x and (v,n') = y in
Int.equal n n' && Level.equal u v)
- let leq (u,n) (v,n') =
- let cmp = Level.compare u v in
- if Int.equal cmp 0 then n <= n'
- else if n <= n' then
- (Level.is_prop u && Level.is_small v)
- else false
-
let successor (u,n) =
if Level.is_prop u then type1
else (u, n + 1)
@@ -833,41 +826,6 @@ type 'a constrained = 'a * constraints
type 'a constraint_function = 'a -> 'a -> constraints -> constraints
-let constraint_add_leq v u c =
- (* We just discard trivial constraints like u<=u *)
- if Expr.equal v u then c
- else
- match v, u with
- | (x,n), (y,m) ->
- let j = m - n in
- if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then
- Constraint.add (x,Lt,y) c
- else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then
- if Level.equal x y then (* u+(k+1) <= u *)
- raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u))
- else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.")
- else if j = 0 then
- Constraint.add (x,Le,y) c
- else (* j >= 1 *) (* m = n + k, u <= v+k *)
- if Level.equal x y then c (* u <= u+k, trivial *)
- else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *)
- else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints.")
-
-let check_univ_leq_one u v = Universe.exists (Expr.leq u) v
-
-let check_univ_leq u v =
- Universe.for_all (fun u -> check_univ_leq_one u v) u
-
-let enforce_leq u v c =
- match v with
- | [v] ->
- List.fold_right (fun u -> constraint_add_leq u v) u c
- | _ -> anomaly (Pp.str"A universe bound can only be a variable.")
-
-let enforce_leq u v c =
- if check_univ_leq u v then c
- else enforce_leq u v c
-
let check_constraint g (l,d,r) =
match d with
| Eq -> check_equal g l r
diff --git a/checker/univ.mli b/checker/univ.mli
index 6cd3b36382..3b29b158f2 100644
--- a/checker/univ.mli
+++ b/checker/univ.mli
@@ -109,8 +109,6 @@ type 'a constrained = 'a * constraints
type 'a constraint_function = 'a -> 'a -> constraints -> constraints
-val enforce_leq : universe constraint_function
-
(** {6 ... } *)
(** Merge of constraints in a universes graph.
The function [merge_constraints] merges a set of constraints in a given
diff --git a/checker/values.ml b/checker/values.ml
index 31e65729b2..4f28d6e448 100644
--- a/checker/values.ml
+++ b/checker/values.ml
@@ -15,7 +15,7 @@
To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli
with a copy we maintain here:
-MD5 07651f61f86d91b22ff7056c6a8d86bc checker/cic.mli
+MD5 42fb0781dc5f7f2cbe3ca127f8249264 checker/cic.mli
*)
@@ -225,7 +225,7 @@ let v_cst_def =
let v_projbody =
v_tuple "projection_body"
- [|v_cst;Int;Int;v_constr|]
+ [|v_ind;Int;Int;v_constr|]
let v_typing_flags =
v_tuple "typing_flags" [|v_bool; v_bool; v_oracle|]
@@ -274,8 +274,10 @@ let v_one_ind = v_tuple "one_inductive_body"
Any|]
let v_finite = v_enum "recursivity_kind" 3
-let v_mind_record = Annot ("mind_record",
- Opt (Opt (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |])))
+
+let v_record_info =
+ v_sum "record_info" 2
+ [| [| Array (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |]) |] |]
let v_ind_pack_univs =
v_sum "abstract_inductive_universes" 0
@@ -283,7 +285,7 @@ let v_ind_pack_univs =
let v_ind_pack = v_tuple "mutual_inductive_body"
[|Array v_one_ind;
- v_mind_record;
+ v_record_info;
v_finite;
Int;
v_section_ctxt;
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 22:50:14 +0000