aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/cClosure.ml14
-rw-r--r--kernel/cbytecodes.ml4
-rw-r--r--kernel/cbytegen.ml8
-rw-r--r--kernel/clambda.ml12
-rw-r--r--kernel/constr.ml38
-rw-r--r--kernel/context.ml8
-rw-r--r--kernel/conv_oracle.ml8
-rw-r--r--kernel/cooking.ml2
-rw-r--r--kernel/csymtable.ml6
-rw-r--r--kernel/declareops.ml10
-rw-r--r--kernel/dune5
-rw-r--r--kernel/environ.ml20
-rw-r--r--kernel/indtypes.ml16
-rw-r--r--kernel/inductive.ml46
-rw-r--r--kernel/mod_subst.ml8
-rw-r--r--kernel/modops.ml10
-rw-r--r--kernel/names.ml10
-rw-r--r--kernel/nativecode.ml26
-rw-r--r--kernel/nativeconv.ml6
-rw-r--r--kernel/nativelambda.ml10
-rw-r--r--kernel/nativelib.ml6
-rw-r--r--kernel/opaqueproof.ml14
-rw-r--r--kernel/reduction.ml26
-rw-r--r--kernel/subtyping.ml14
-rw-r--r--kernel/term.ml14
-rw-r--r--kernel/term_typing.ml22
-rw-r--r--kernel/typeops.ml24
-rw-r--r--kernel/uGraph.ml12
-rw-r--r--kernel/univ.ml30
-rw-r--r--kernel/vars.ml4
-rw-r--r--kernel/vconv.ml4
-rw-r--r--kernel/vm.ml2
-rw-r--r--kernel/vmvalues.ml18
33 files changed, 233 insertions, 224 deletions
diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index fd9394025a..c4c96c9b55 100644
--- a/kernel/cClosure.ml
+++ b/kernel/cClosure.ml
@@ -281,7 +281,7 @@ let assoc_defined id env = match Environ.lookup_named id env with
| LocalDef (_, c, _) -> c
| _ -> raise Not_found
-let ref_value_cache ({i_cache = cache} as infos) tab ref =
+let ref_value_cache ({i_cache = cache;_} as infos) tab ref =
try
Some (KeyTable.find tab ref)
with Not_found ->
@@ -289,7 +289,7 @@ let ref_value_cache ({i_cache = cache} as infos) tab ref =
let body =
match ref with
| RelKey n ->
- let open Context.Rel.Declaration in
+ let open! Context.Rel.Declaration in
let i = n - 1 in
let (d, _) =
try Range.get cache.i_rels i
@@ -837,7 +837,7 @@ let eta_expand_ind_stack env ind m s (f, s') =
arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
let pars = mib.Declarations.mind_nparams in
let right = fapp_stack (f, s') in
- let (depth, args, s) = strip_update_shift_app m s in
+ let (depth, args, _s) = strip_update_shift_app m s in
(** Try to drop the params, might fail on partially applied constructors. *)
let argss = try_drop_parameters depth pars args in
let hstack = Array.map (fun p ->
@@ -925,7 +925,7 @@ and knht info e t stk =
| Fix _ -> knh info (mk_clos2 e t) stk
| Cast(a,_,_) -> knht info e a stk
| Rel n -> knh info (clos_rel e n) stk
- | Proj (p,c) -> knh info (mk_clos2 e t) stk
+ | Proj (_p,_c) -> knh info (mk_clos2 e t) stk
| (Lambda _|Prod _|Construct _|CoFix _|Ind _|
LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
(mk_clos2 e t, stk)
@@ -952,7 +952,7 @@ let rec knr info tab m stk =
(match ref_value_cache info tab (RelKey k) with
Some v -> kni info tab v stk
| None -> (set_norm m; (m,stk)))
- | FConstruct((ind,c),u) ->
+ | FConstruct((_ind,c),_u) ->
let use_match = red_set info.i_flags fMATCH in
let use_fix = red_set info.i_flags fFIX in
if use_match || use_fix then
@@ -1018,7 +1018,7 @@ let rec zip_term zfun m stk =
zip_term zfun h s
| Zshift(n)::s ->
zip_term zfun (lift n m) s
- | Zupdate(rf)::s ->
+ | Zupdate(_rf)::s ->
zip_term zfun m s
(* Computes the strong normal form of a term.
@@ -1038,7 +1038,7 @@ let rec kl info tab m =
and norm_head info tab m =
if is_val m then (incr prune; term_of_fconstr m) else
match m.term with
- | FLambda(n,tys,f,e) ->
+ | FLambda(_n,tys,f,e) ->
let (e',rvtys) =
List.fold_left (fun (e,ctxt) (na,ty) ->
(subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt))
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index ed3bd866a4..c63795b295 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -126,8 +126,8 @@ let compare e1 e2 = match e1, e2 with
| FVrel r1, FVrel r2 -> Int.compare r1 r2
| FVrel _, (FVuniv_var _ | FVevar _) -> -1
| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2
-| FVuniv_var i1, (FVnamed _ | FVrel _) -> 1
-| FVuniv_var i1, FVevar _ -> -1
+| FVuniv_var _i1, (FVnamed _ | FVrel _) -> 1
+| FVuniv_var _i1, FVevar _ -> -1
| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1
| FVevar e1, FVevar e2 -> Evar.compare e1 e2
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 5362f9a814..73620ae578 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -413,7 +413,7 @@ let code_makeblock ~stack_size ~arity ~tag cont =
Kpush :: nest_block tag arity cont
end
-let compile_structured_constant cenv sc sz cont =
+let compile_structured_constant _cenv sc sz cont =
set_max_stack_size sz;
Kconst sc :: cont
@@ -534,7 +534,7 @@ let rec compile_lam env cenv lam sz cont =
comp_app compile_structured_constant compile_get_univ cenv
(Const_sort (Sorts.Type u)) (Array.of_list s) sz cont
- | Llet (id,def,body) ->
+ | Llet (_id,def,body) ->
compile_lam env cenv def sz
(Kpush ::
compile_lam env (push_local sz cenv) body (sz+1) (add_pop 1 cont))
@@ -561,7 +561,7 @@ let rec compile_lam env cenv lam sz cont =
| _ -> comp_app (compile_lam env) (compile_lam env) cenv f args sz cont
end
- | Lfix ((rec_args, init), (decl, types, bodies)) ->
+ | Lfix ((rec_args, init), (_decl, types, bodies)) ->
let ndef = Array.length types in
let rfv = ref empty_fv in
let lbl_types = Array.make ndef Label.no in
@@ -594,7 +594,7 @@ let rec compile_lam env cenv lam sz cont =
(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
- | Lcofix(init, (decl,types,bodies)) ->
+ | Lcofix(init, (_decl,types,bodies)) ->
let ndef = Array.length types in
let lbl_types = Array.make ndef Label.no in
let lbl_bodies = Array.make ndef Label.no in
diff --git a/kernel/clambda.ml b/kernel/clambda.ml
index 31dede6f5d..c21ce22421 100644
--- a/kernel/clambda.ml
+++ b/kernel/clambda.ml
@@ -107,7 +107,7 @@ let rec pp_lam lam =
| Lval _ -> str "values"
| Lsort s -> pp_sort s
| Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i
- | Lprim((kn,_u),ar,op,args) ->
+ | Lprim((kn,_u),_ar,_op,args) ->
hov 1
(str "(PRIM " ++ pr_con kn ++ spc() ++
prlist_with_sep spc pp_lam (Array.to_list args) ++
@@ -215,7 +215,7 @@ let rec map_lam_with_binders g f n lam =
let u' = map_uint g f n u in
if u == u' then lam else Luint u'
-and map_uint g f n u =
+and map_uint _g f n u =
match u with
| UintVal _ -> u
| UintDigits(args) ->
@@ -532,7 +532,7 @@ struct
size = 0;
}
- let extend v =
+ let extend (v : 'a t) =
if v.size = Array.length v.elems then
let new_size = min (2*v.size) Sys.max_array_length in
if new_size <= v.size then raise (Invalid_argument "Vect.extend");
@@ -545,12 +545,12 @@ struct
v.elems.(v.size) <- a;
v.size <- v.size + 1
- let popn v n =
+ let popn (v : 'a t) n =
v.size <- max 0 (v.size - n)
let pop v = popn v 1
- let get_last v n =
+ let get_last (v : 'a t) n =
if v.size <= n then raise
(Invalid_argument "Vect.get:index out of bounds");
v.elems.(v.size - n - 1)
@@ -715,7 +715,7 @@ let rec lambda_of_constr env c =
and lambda_of_app env f args =
match Constr.kind f with
- | Const (kn,u as c) ->
+ | Const (kn,_u as c) ->
let kn = get_alias env.global_env kn in
(* spiwack: checks if there is a specific way to compile the constant
if there is not, Not_found is raised, and the function
diff --git a/kernel/constr.ml b/kernel/constr.ml
index c73fe7fbde..b25f38d630 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -360,17 +360,17 @@ let destConst c = match kind c with
(* Destructs an existential variable *)
let destEvar c = match kind c with
- | Evar (kn, a as r) -> r
+ | Evar (_kn, _a as r) -> r
| _ -> raise DestKO
(* Destructs a (co)inductive type named kn *)
let destInd c = match kind c with
- | Ind (kn, a as r) -> r
+ | Ind (_kn, _a as r) -> r
| _ -> raise DestKO
(* Destructs a constructor *)
let destConstruct c = match kind c with
- | Construct (kn, a as r) -> r
+ | Construct (_kn, _a as r) -> r
| _ -> raise DestKO
(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
@@ -421,12 +421,12 @@ let fold f acc c = match kind c with
| Lambda (_,t,c) -> f (f acc t) c
| LetIn (_,b,t,c) -> f (f (f acc b) t) c
| App (c,l) -> Array.fold_left f (f acc c) l
- | Proj (p,c) -> f acc c
+ | Proj (_p,c) -> f acc c
| Evar (_,l) -> Array.fold_left f acc l
| Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
- | Fix (_,(lna,tl,bl)) ->
+ | Fix (_,(_lna,tl,bl)) ->
Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
- | CoFix (_,(lna,tl,bl)) ->
+ | CoFix (_,(_lna,tl,bl)) ->
Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
(* [iter f c] iters [f] on the immediate subterms of [c]; it is
@@ -441,7 +441,7 @@ let iter f c = match kind c with
| Lambda (_,t,c) -> f t; f c
| LetIn (_,b,t,c) -> f b; f t; f c
| App (c,l) -> f c; Array.iter f l
- | Proj (p,c) -> f c
+ | Proj (_p,c) -> f c
| Evar (_,l) -> Array.iter f l
| Case (_,p,c,bl) -> f p; f c; Array.iter f bl
| Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
@@ -463,7 +463,7 @@ let iter_with_binders g f n c = match kind c with
| App (c,l) -> f n c; Array.Fun1.iter f n l
| Evar (_,l) -> Array.Fun1.iter f n l
| Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl
- | Proj (p,c) -> f n c
+ | Proj (_p,c) -> f n c
| Fix (_,(_,tl,bl)) ->
Array.Fun1.iter f n tl;
Array.Fun1.iter f (iterate g (Array.length tl) n) bl
@@ -483,19 +483,19 @@ let fold_constr_with_binders g f n acc c =
| (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
| Construct _) -> acc
| Cast (c,_, t) -> f n (f n acc c) t
- | Prod (na,t,c) -> f (g n) (f n acc t) c
- | Lambda (na,t,c) -> f (g n) (f n acc t) c
- | LetIn (na,b,t,c) -> f (g n) (f n (f n acc b) t) c
+ | Prod (_na,t,c) -> f (g n) (f n acc t) c
+ | Lambda (_na,t,c) -> f (g n) (f n acc t) c
+ | LetIn (_na,b,t,c) -> f (g n) (f n (f n acc b) t) c
| App (c,l) -> Array.fold_left (f n) (f n acc c) l
- | Proj (p,c) -> f n acc c
+ | Proj (_p,c) -> f n acc c
| Evar (_,l) -> Array.fold_left (f n) acc l
| Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
| Fix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in
+ let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in
let fd = Array.map2 (fun t b -> (t,b)) tl bl in
Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
| CoFix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in
+ let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in
let fd = Array.map2 (fun t b -> (t,b)) tl bl in
Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
@@ -963,11 +963,11 @@ let constr_ord_int f t1 t2 =
| LetIn _, _ -> -1 | _, LetIn _ -> 1
| App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2
| App _, _ -> -1 | _, App _ -> 1
- | Const (c1,u1), Const (c2,u2) -> Constant.CanOrd.compare c1 c2
+ | Const (c1,_u1), Const (c2,_u2) -> Constant.CanOrd.compare c1 c2
| Const _, _ -> -1 | _, Const _ -> 1
- | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2
+ | Ind (ind1, _u1), Ind (ind2, _u2) -> ind_ord ind1 ind2
| Ind _, _ -> -1 | _, Ind _ -> 1
- | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2
+ | Construct (ct1,_u1), Construct (ct2,_u2) -> constructor_ord ct1 ct2
| Construct _, _ -> -1 | _, Construct _ -> 1
| Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2
@@ -1226,9 +1226,9 @@ let rec hash t =
combinesmall 11 (combine (constructor_hash c) (Instance.hash u))
| Case (_ , p, c, bl) ->
combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl))
- | Fix (ln ,(_, tl, bl)) ->
+ | Fix (_ln ,(_, tl, bl)) ->
combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
- | CoFix(ln, (_, tl, bl)) ->
+ | CoFix(_ln, (_, tl, bl)) ->
combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
| Meta n -> combinesmall 15 n
| Rel n -> combinesmall 16 n
diff --git a/kernel/context.ml b/kernel/context.ml
index 4a7204b75c..3d98381fbb 100644
--- a/kernel/context.ml
+++ b/kernel/context.ml
@@ -142,8 +142,8 @@ struct
(** Reduce all terms in a given declaration to a single value. *)
let fold_constr f decl acc =
match decl with
- | LocalAssum (n,ty) -> f ty acc
- | LocalDef (n,v,ty) -> f ty (f v acc)
+ | LocalAssum (_n,ty) -> f ty acc
+ | LocalDef (_n,v,ty) -> f ty (f v acc)
let to_tuple = function
| LocalAssum (na, ty) -> na, None, ty
@@ -151,7 +151,7 @@ struct
let drop_body = function
| LocalAssum _ as d -> d
- | LocalDef (na, v, ty) -> LocalAssum (na, ty)
+ | LocalDef (na, _v, ty) -> LocalAssum (na, ty)
end
@@ -356,7 +356,7 @@ struct
let drop_body = function
| LocalAssum _ as d -> d
- | LocalDef (id, v, ty) -> LocalAssum (id, ty)
+ | LocalDef (id, _v, ty) -> LocalAssum (id, ty)
let of_rel_decl f = function
| Rel.Declaration.LocalAssum (na,t) ->
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 7ef63c1860..c74f2ab318 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -42,7 +42,7 @@ let empty = {
cst_trstate = Cpred.full;
}
-let get_strategy { var_opacity; cst_opacity } f = function
+let get_strategy { var_opacity; cst_opacity; _ } f = function
| VarKey id ->
(try Id.Map.find id var_opacity
with Not_found -> default)
@@ -51,7 +51,7 @@ let get_strategy { var_opacity; cst_opacity } f = function
with Not_found -> default)
| RelKey _ -> Expand
-let set_strategy ({ var_opacity; cst_opacity } as oracle) k l =
+let set_strategy ({ var_opacity; cst_opacity; _ } as oracle) k l =
match k with
| VarKey id ->
let var_opacity =
@@ -75,13 +75,13 @@ let set_strategy ({ var_opacity; cst_opacity } as oracle) k l =
{ oracle with cst_opacity; cst_trstate; }
| RelKey _ -> CErrors.user_err Pp.(str "set_strategy: RelKey")
-let fold_strategy f { var_opacity; cst_opacity; } accu =
+let fold_strategy f { var_opacity; cst_opacity; _ } accu =
let fvar id lvl accu = f (VarKey id) lvl accu in
let fcst cst lvl accu = f (ConstKey cst) lvl accu in
let accu = Id.Map.fold fvar var_opacity accu in
Cmap.fold fcst cst_opacity accu
-let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate)
+let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate)
(* Unfold the first constant only if it is "more transparent" than the
second one. In case of tie, use the recommended default. *)
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 657478a106..b361e36bbf 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -91,7 +91,7 @@ let update_case_info cache ci modlist =
try
let ind, n =
match share cache (IndRef ci.ci_ind) modlist with
- | (IndRef f,(u,l)) -> (f, Array.length l)
+ | (IndRef f,(_u,l)) -> (f, Array.length l)
| _ -> assert false in
{ ci with ci_ind = ind; ci_npar = ci.ci_npar + n }
with Not_found ->
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index bb9231d000..8bef6aec42 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -173,7 +173,7 @@ and slot_for_fv env fv =
| Some (v, _) -> v
end
| FVevar evk -> val_of_evar evk
- | FVuniv_var idu ->
+ | FVuniv_var _idu ->
assert false
and eval_to_patch env (buff,pl,fv) =
@@ -192,5 +192,5 @@ and val_of_constr env c =
| Some v -> eval_to_patch env (to_memory v)
| None -> assert false
-let set_transparent_const kn = () (* !?! *)
-let set_opaque_const kn = () (* !?! *)
+let set_transparent_const _kn = () (* !?! *)
+let set_opaque_const _kn = () (* !?! *)
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index 51ec3defb3..d995786d97 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -181,7 +181,7 @@ let subst_regular_ind_arity sub s =
if uar' == s.mind_user_arity then s
else { mind_user_arity = uar'; mind_sort = s.mind_sort }
-let subst_template_ind_arity sub s = s
+let subst_template_ind_arity _sub s = s
(* FIXME records *)
let subst_ind_arity =
@@ -240,14 +240,14 @@ let inductive_polymorphic_context mib =
let inductive_is_polymorphic mib =
match mib.mind_universes with
| Monomorphic_ind _ -> false
- | Polymorphic_ind ctx -> true
- | Cumulative_ind cumi -> true
+ | Polymorphic_ind _ctx -> true
+ | Cumulative_ind _cumi -> true
let inductive_is_cumulative mib =
match mib.mind_universes with
| Monomorphic_ind _ -> false
- | Polymorphic_ind ctx -> false
- | Cumulative_ind cumi -> true
+ | Polymorphic_ind _ctx -> false
+ | Cumulative_ind _cumi -> true
let inductive_make_projection ind mib ~proj_arg =
match mib.mind_record with
diff --git a/kernel/dune b/kernel/dune
index 011af9c28c..a503238907 100644
--- a/kernel/dune
+++ b/kernel/dune
@@ -13,3 +13,8 @@
(documentation
(package coq))
+
+; In dev profile, we check the kernel against a more strict set of
+; warnings.
+(env
+ (dev (flags :standard -w +a-4-44-50)))
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 3bfcaa7f52..dffcd70282 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -296,12 +296,12 @@ let eq_named_context_val c1 c2 =
(* A local const is evaluable if it is defined *)
-open Context.Named.Declaration
-
let named_type id env =
+ let open Context.Named.Declaration in
get_type (lookup_named id env)
let named_body id env =
+ let open Context.Named.Declaration in
get_value (lookup_named id env)
let evaluable_named id env =
@@ -333,7 +333,7 @@ let fold_named_context f env ~init =
let rec fold_right env =
match match_named_context_val env.env_named_context with
| None -> init
- | Some (d, v, rem) ->
+ | Some (d, _v, rem) ->
let env =
reset_with_named_context rem env in
f env d (fold_right env)
@@ -415,7 +415,7 @@ let constant_type env (kn,u) =
let cb = lookup_constant kn env in
match cb.const_universes with
| Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty
- | Polymorphic_const ctx ->
+ | Polymorphic_const _ctx ->
let csts = constraints_of cb u in
(subst_instance_constr u cb.const_type, csts)
@@ -508,14 +508,14 @@ let get_projections env ind =
Declareops.inductive_make_projections ind mib
(* Mutual Inductives *)
-let polymorphic_ind (mind,i) env =
+let polymorphic_ind (mind,_i) env =
Declareops.inductive_is_polymorphic (lookup_mind mind env)
let polymorphic_pind (ind,u) env =
if Univ.Instance.is_empty u then false
else polymorphic_ind ind env
-let type_in_type_ind (mind,i) env =
+let type_in_type_ind (mind,_i) env =
not (lookup_mind mind env).mind_typing_flags.check_universes
let template_polymorphic_ind (mind,i) env =
@@ -527,7 +527,7 @@ let template_polymorphic_pind (ind,u) env =
if not (Univ.Instance.is_empty u) then false
else template_polymorphic_ind ind env
-let add_mind_key kn (mind, _ as mind_key) env =
+let add_mind_key kn (_mind, _ as mind_key) env =
let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in
let new_globals =
{ env.env_globals with
@@ -543,7 +543,7 @@ let lookup_constant_variables c env =
let cmap = lookup_constant c env in
Context.Named.to_vars cmap.const_hyps
-let lookup_inductive_variables (kn,i) env =
+let lookup_inductive_variables (kn,_i) env =
let mis = lookup_mind kn env in
Context.Named.to_vars mis.mind_hyps
@@ -579,6 +579,7 @@ let global_vars_set env constr =
contained in the types of the needed variables. *)
let really_needed env needed =
+ let open! Context.Named.Declaration in
Context.Named.fold_inside
(fun need decl ->
if Id.Set.mem (get_id decl) need then
@@ -594,6 +595,7 @@ let really_needed env needed =
(named_context env)
let keep_hyps env needed =
+ let open Context.Named.Declaration in
let really_needed = really_needed env needed in
Context.Named.fold_outside
(fun d nsign ->
@@ -647,6 +649,7 @@ type unsafe_type_judgment = types punsafe_type_judgment
exception Hyp_not_found
let apply_to_hyp ctxt id f =
+ let open Context.Named.Declaration in
let rec aux rtail ctxt =
match match_named_context_val ctxt with
| Some (d, v, ctxt) ->
@@ -663,6 +666,7 @@ let remove_hyps ids check_context check_value ctxt =
let rec remove_hyps ctxt = match match_named_context_val ctxt with
| None -> empty_named_context_val, false
| Some (d, v, rctxt) ->
+ let open Context.Named.Declaration in
let (ans, seen) = remove_hyps rctxt in
if Id.Set.mem (get_id d) ids then (ans, true)
else if not seen then ctxt, false
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 7abf8027bd..b976469ff7 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -242,7 +242,7 @@ let check_subtyping cumi paramsctxt env_ar inds =
in
let env = Environ.add_constraints subtyp_constraints env in
(* process individual inductive types: *)
- Array.iter (fun (id,cn,lc,(sign,arity)) ->
+ Array.iter (fun (_id,_cn,lc,(_sign,arity)) ->
match arity with
| RegularArity (_, full_arity, _) ->
check_subtyping_arity_constructor env dosubst full_arity numparams true;
@@ -368,7 +368,7 @@ let typecheck_inductive env mie =
RegularArity (not is_natural,full_arity,defu)
in
let template_polymorphic () =
- let _, s =
+ let _sign, s =
try dest_arity env full_arity
with NotArity -> raise (InductiveError (NotAnArity (env, full_arity)))
in
@@ -428,7 +428,7 @@ exception IllFormedInd of ill_formed_ind
let mind_extract_params = decompose_prod_n_assum
let explain_ind_err id ntyp env nparamsctxt c err =
- let (lparams,c') = mind_extract_params nparamsctxt c in
+ let (_lparams,c') = mind_extract_params nparamsctxt c in
match err with
| LocalNonPos kt ->
raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt))))
@@ -596,7 +596,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt (
discharged to the [check_positive_nested] function. *)
if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
else check_positive_nested ienv nmr (ind_kn, largs)
- | err ->
+ | _err ->
(** If an inductive of the mutually inductive block
appears in any other way, then the positivy check gives
up. *)
@@ -613,7 +613,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt (
defined types, not one of the types of the mutually inductive
block being defined). *)
(* accesses to the environment are not factorised, but is it worth? *)
- and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) =
+ and check_positive_nested (env,n,ntypes,_ra_env as ienv) nmr ((mi,u), largs) =
let (mib,mip) = lookup_mind_specif env mi in
let auxnrecpar = mib.mind_nparams_rec in
let auxnnonrecpar = mib.mind_nparams - auxnrecpar in
@@ -664,7 +664,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt (
the type [c]) is checked to be the right (properly applied)
inductive type. *)
and check_constructors ienv check_head nmr c =
- let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c =
+ let rec check_constr_rec (env,n,ntypes,_ra_env as ienv) nmr lrec c =
let x,largs = decompose_app (whd_all env c) in
match kind x with
@@ -813,7 +813,7 @@ let compute_projections (kn, i as ind) mib =
in
let projections decl (i, j, labs, pbs, letsubst) =
match decl with
- | LocalDef (na,c,t) ->
+ | LocalDef (_na,c,_t) ->
(* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)]
to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *)
let c = liftn 1 j c in
@@ -841,7 +841,7 @@ let compute_projections (kn, i as ind) mib =
(i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst)
| Anonymous -> raise UndefinableExpansion
in
- let (_, _, labs, pbs, letsubst) =
+ let (_, _, labs, pbs, _letsubst) =
List.fold_right projections ctx (0, 1, [], [], paramsletsubst)
in
Array.of_list (List.rev labs),
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 1d2f22b006..9bbcf07f7e 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -154,10 +154,10 @@ let make_subst env =
let rec make subst = function
| LocalDef _ :: sign, exp, args ->
make subst (sign, exp, args)
- | d::sign, None::exp, args ->
+ | _d::sign, None::exp, args ->
let args = match args with _::args -> args | [] -> [] in
make subst (sign, exp, args)
- | d::sign, Some u::exp, a::args ->
+ | _d::sign, Some u::exp, a::args ->
(* We recover the level of the argument, but we don't change the *)
(* level in the corresponding type in the arity; this level in the *)
(* arity is a global level which, at typing time, will be enforce *)
@@ -165,7 +165,7 @@ let make_subst env =
(* a useless extra constraint *)
let s = Sorts.univ_of_sort (snd (dest_arity env (Lazy.force a))) in
make (cons_subst u s subst) (sign, exp, args)
- | LocalAssum (na,t) :: sign, Some u::exp, [] ->
+ | LocalAssum (_na,_t) :: sign, Some u::exp, [] ->
(* No more argument here: we add the remaining universes to the *)
(* substitution (when [u] is distinct from all other universes in the *)
(* template, it is identity substitution otherwise (ie. when u is *)
@@ -173,7 +173,7 @@ let make_subst env =
(* update its image [x] by [sup x u] in order not to forget the *)
(* dependency in [u] that remains to be fullfilled. *)
make (remember_subst u subst) (sign, exp, [])
- | sign, [], _ ->
+ | _sign, [], _ ->
(* Uniform parameters are exhausted *)
subst
| [], _, _ ->
@@ -199,7 +199,7 @@ let instantiate_universes env ctx ar argsorts =
(* Type of an inductive type *)
-let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps =
+let type_of_inductive_gen ?(polyprop=true) env ((_mib,mip),u) paramtyps =
match mip.mind_arity with
| RegularArity a -> subst_instance_constr u a.mind_user_arity
| TemplateArity ar ->
@@ -215,12 +215,12 @@ let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps =
let type_of_inductive env pind =
type_of_inductive_gen env pind [||]
-let constrained_type_of_inductive env ((mib,mip),u as pind) =
+let constrained_type_of_inductive env ((mib,_mip),u as pind) =
let ty = type_of_inductive env pind in
let cst = instantiate_inductive_constraints mib u in
(ty, cst)
-let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args =
+let constrained_type_of_inductive_knowing_parameters env ((mib,_mip),u as pind) args =
let ty = type_of_inductive_gen env pind args in
let cst = instantiate_inductive_constraints mib u in
(ty, cst)
@@ -249,7 +249,7 @@ let type_of_constructor (cstr, u) (mib,mip) =
if i > nconstr then user_err Pp.(str "Not enough constructors in the type.");
constructor_instantiate (fst ind) u mib specif.(i-1)
-let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) =
+let constrained_type_of_constructor (_cstr,u as cstru) (mib,_mip as ind) =
let ty = type_of_constructor cstru ind in
let cst = instantiate_inductive_constraints mib u in
(ty, cst)
@@ -279,7 +279,7 @@ let inductive_sort_family mip =
let mind_arity mip =
mip.mind_arity_ctxt, inductive_sort_family mip
-let get_instantiated_arity (ind,u) (mib,mip) params =
+let get_instantiated_arity (_ind,u) (mib,mip) params =
let sign, s = mind_arity mip in
full_inductive_instantiate mib u params sign, s
@@ -563,7 +563,7 @@ let check_inductive_codomain env p =
let env = push_rel_context absctx env in
let arctx, s = dest_prod_assum env ar in
let env = push_rel_context arctx env in
- let i,l' = decompose_app (whd_all env s) in
+ let i,_l' = decompose_app (whd_all env s) in
isInd i
(* The following functions are almost duplicated from indtypes.ml, except
@@ -635,10 +635,10 @@ let get_recargs_approx env tree ind args =
build_recargs_nested ienv tree (ind_kn, largs)
| _ -> mk_norec
end
- | err ->
+ | _err ->
mk_norec
- and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) =
+ and build_recargs_nested (env,_ra_env as ienv) tree (((mind,i),u), largs) =
(* If the inferred tree already disallows recursion, no need to go further *)
if eq_wf_paths tree mk_norec then tree
else
@@ -676,7 +676,7 @@ let get_recargs_approx env tree ind args =
(Rtree.mk_rec irecargs).(i)
and build_recargs_constructors ienv trees c =
- let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c =
+ let rec recargs_constr_rec (env,_ra_env as ienv) trees lrec c =
let x,largs = decompose_app (whd_all env c) in
match kind x with
@@ -685,7 +685,7 @@ let get_recargs_approx env tree ind args =
let recarg = build_recargs ienv (List.hd trees) b in
let ienv' = ienv_push_var ienv (na,b,mk_norec) in
recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d
- | hd ->
+ | _hd ->
List.rev lrec
in
recargs_constr_rec ienv trees [] c
@@ -794,7 +794,7 @@ let rec subterm_specif renv stack t =
| Proj (p, c) ->
let subt = subterm_specif renv stack c in
(match subt with
- | Subterm (s, wf) ->
+ | Subterm (_s, wf) ->
(* We take the subterm specs of the constructor of the record *)
let wf_args = (dest_subterms wf).(0) in
(* We extract the tree of the projected argument *)
@@ -964,7 +964,7 @@ let check_one_fix renv recpos trees def =
else check_rec_call renv' [] body)
bodies
- | Const (kn,u as cu) ->
+ | Const (kn,_u as cu) ->
if evaluable_constant kn renv.env then
try List.iter (check_rec_call renv []) l
with (FixGuardError _ ) ->
@@ -983,7 +983,7 @@ let check_one_fix renv recpos trees def =
check_rec_call renv [] a;
check_rec_call (push_var_renv renv (x,a)) [] b
- | CoFix (i,(_,typarray,bodies as recdef)) ->
+ | CoFix (_i,(_,typarray,bodies as recdef)) ->
List.iter (check_rec_call renv []) l;
Array.iter (check_rec_call renv []) typarray;
let renv' = push_fix_renv renv recdef in
@@ -992,13 +992,13 @@ let check_one_fix renv recpos trees def =
| (Ind _ | Construct _) ->
List.iter (check_rec_call renv []) l
- | Proj (p, c) ->
+ | Proj (_p, c) ->
List.iter (check_rec_call renv []) l;
check_rec_call renv [] c
| Var id ->
begin
- let open Context.Named.Declaration in
+ let open! Context.Named.Declaration in
match lookup_named id renv.env with
| LocalAssum _ ->
List.iter (check_rec_call renv []) l
@@ -1129,10 +1129,10 @@ let check_one_cofix env nbfix def deftype =
raise (CoFixGuardError (env,UnguardedRecursiveCall t))
else if not(List.for_all (noccur_with_meta n nbfix) args) then
raise (CoFixGuardError (env,NestedRecursiveOccurrences))
- | Construct ((_,i as cstr_kn),u) ->
+ | Construct ((_,i as cstr_kn),_u) ->
let lra = vlra.(i-1) in
let mI = inductive_of_constructor cstr_kn in
- let (mib,mip) = lookup_mind_specif env mI in
+ let (mib,_mip) = lookup_mind_specif env mI in
let realargs = List.skipn mib.mind_nparams args in
let rec process_args_of_constr = function
| (t::lr), (rar::lrar) ->
@@ -1157,7 +1157,7 @@ let check_one_cofix env nbfix def deftype =
else
raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
- | CoFix (j,(_,varit,vdefs as recdef)) ->
+ | CoFix (_j,(_,varit,vdefs as recdef)) ->
if List.for_all (noccur_with_meta n nbfix) args
then
if Array.for_all (noccur_with_meta n nbfix) varit then
@@ -1203,7 +1203,7 @@ let check_one_cofix env nbfix def deftype =
(* The function which checks that the whole block of definitions
satisfies the guarded condition *)
-let check_cofix env (bodynum,(names,types,bodies as recdef)) =
+let check_cofix env (_bodynum,(names,types,bodies as recdef)) =
let flags = Environ.typing_flags env in
if flags.check_guarded then
let nbfix = Array.length bodies in
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index f1d08ef6dd..bff3092655 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -319,12 +319,12 @@ let subst_con sub cst =
let subst_con_kn sub con =
subst_con sub (con,Univ.Instance.empty)
-let subst_pcon sub (con,u as pcon) =
- try let con', can = subst_con0 sub pcon in
+let subst_pcon sub (_con,u as pcon) =
+ try let con', _can = subst_con0 sub pcon in
con',u
with No_subst -> pcon
-let subst_pcon_term sub (con,u as pcon) =
+let subst_pcon_term sub (_con,u as pcon) =
try let con', can = subst_con0 sub pcon in
(con',u), can
with No_subst -> pcon, mkConstU pcon
@@ -441,7 +441,7 @@ let replace_mp_in_kn mpfrom mpto kn =
let rec mp_in_mp mp mp1 =
match mp1 with
| _ when ModPath.equal mp1 mp -> true
- | MPdot (mp2,l) -> mp_in_mp mp mp2
+ | MPdot (mp2,_l) -> mp_in_mp mp mp2
| _ -> false
let subset_prefixed_by mp resolver =
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 9435f46c6b..424d329e09 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -138,7 +138,7 @@ let rec functor_smart_map fty f0 funct = match funct with
let a' = f0 a in if a==a' then funct else NoFunctor a'
let rec functor_iter fty f0 = function
- |MoreFunctor (mbid,ty,e) -> fty ty; functor_iter fty f0 e
+ |MoreFunctor (_mbid,ty,e) -> fty ty; functor_iter fty f0 e
|NoFunctor a -> f0 a
(** {6 Misc operations } *)
@@ -171,7 +171,7 @@ let implem_iter fs fa impl = match impl with
(** {6 Substitutions of modular structures } *)
-let id_delta x y = x
+let id_delta x _y = x
let subst_with_body sub = function
|WithMod(id,mp) as orig ->
@@ -200,7 +200,7 @@ let rec subst_structure sub do_delta sign =
and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body =
fun is_mod sub subst_impl do_delta mb ->
- let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in
+ let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; _ } = mb in
let mp' = subst_mp sub mp in
let sub =
if ModPath.equal mp mp' then sub
@@ -371,7 +371,7 @@ and strengthen_sig mp_from struc mp_to reso = match struc with
let item' = l,SFBmodule mb' in
let reso',rest' = strengthen_sig mp_from rest mp_to reso in
add_delta_resolver reso' mb.mod_delta, item':: rest'
- |(l,SFBmodtype mty as item) :: rest ->
+ |(_l,SFBmodtype _mty as item) :: rest ->
let reso',rest' = strengthen_sig mp_from rest mp_to reso in
reso',item::rest'
@@ -628,7 +628,7 @@ let join_structure except otab s =
let rec join_module : 'a. 'a generic_module_body -> unit = fun mb ->
Option.iter join_expression mb.mod_type_alg;
join_signature mb.mod_type
- and join_field (l,body) = match body with
+ and join_field (_l,body) = match body with
|SFBconst sb -> join_constant_body except otab sb
|SFBmind _ -> ()
|SFBmodule m ->
diff --git a/kernel/names.ml b/kernel/names.ml
index 933cefe993..6d33f233e9 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -207,7 +207,7 @@ struct
let repr mbid = mbid
- let to_string (i, s, p) =
+ let to_string (_i, s, p) =
DirPath.to_string p ^ "." ^ s
let debug_to_string (i, s, p) =
@@ -328,7 +328,7 @@ module ModPath = struct
let rec dp = function
| MPfile sl -> sl
| MPbound (_,_,dp) -> dp
- | MPdot (mp,l) -> dp mp
+ | MPdot (mp,_l) -> dp mp
module Self_Hashcons = struct
type t = module_path
@@ -420,7 +420,7 @@ module KerName = struct
let hash kn =
let h = kn.refhash in
if h < 0 then
- let { modpath = mp; dirpath = dp; knlabel = lbl; } = kn in
+ let { modpath = mp; dirpath = dp; knlabel = lbl; _ } = kn in
let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in
(* Ensure positivity on all platforms. *)
let h = h land 0x3FFFFFFF in
@@ -623,8 +623,8 @@ let constr_modpath (ind,_) = ind_modpath ind
let ith_mutual_inductive (mind, _) i = (mind, i)
let ith_constructor_of_inductive ind i = (ind, i)
-let inductive_of_constructor (ind, i) = ind
-let index_of_constructor (ind, i) = i
+let inductive_of_constructor (ind, _i) = ind
+let index_of_constructor (_ind, i) = i
let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2
let eq_user_ind (m1, i1) (m2, i2) =
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index eed25a4ca4..74b075f4a5 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -1007,7 +1007,7 @@ let compile_prim decl cond paux =
*)
let rec opt_prim_aux paux =
match paux with
- | PAprim(prefix, kn, op, args) ->
+ | PAprim(_prefix, _kn, op, args) ->
let args = Array.map opt_prim_aux args in
app_prim (Coq_primitive(op,None)) args
(*
@@ -1071,7 +1071,7 @@ let ml_of_instance instance u =
match t with
| Lrel(id ,i) -> get_rel env id i
| Lvar id -> get_var env id
- | Lmeta(mv,ty) ->
+ | Lmeta(mv,_ty) ->
let tyn = fresh_lname Anonymous in
let i = push_symbol (SymbMeta mv) in
MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|])
@@ -1184,7 +1184,7 @@ let ml_of_instance instance u =
let lf,env_n = push_rels (empty_env env.env_univ ()) ids in
let t_params = Array.make ndef [||] in
let t_norm_f = Array.make ndef (Gnorm (l,-1)) in
- let mk_let envi (id,def) t = MLlet (id,def,t) in
+ let mk_let _envi (id,def) t = MLlet (id,def,t) in
let mk_lam_or_let (params,lets,env) (id,def) =
let ln,env' = push_rel env id in
match def with
@@ -1217,7 +1217,7 @@ let ml_of_instance instance u =
(Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in
(* Compilation of fix *)
let fv_args = fv_args env fvn fvr in
- let lf, env = push_rels env ids in
+ let lf, _env = push_rels env ids in
let lf_args = Array.map (fun id -> MLlocal id) lf in
let mk_norm = MLapp(MLglobal norm, fv_args) in
let mkrec i lname =
@@ -1272,9 +1272,9 @@ let ml_of_instance instance u =
let mk_norm = MLapp(MLglobal norm, fv_args) in
let lnorm = fresh_lname Anonymous in
let ltype = fresh_lname Anonymous in
- let lf, env = push_rels env ids in
+ let lf, _env = push_rels env ids in
let lf_args = Array.map (fun id -> MLlocal id) lf in
- let upd i lname cont =
+ let upd i _lname cont =
let paramsi = t_params.(i) in
let pargsi = Array.map (fun id -> MLlocal id) paramsi in
let uniti = fresh_lname Anonymous in
@@ -1305,7 +1305,7 @@ let ml_of_instance instance u =
(lname, paramsi, body) in
MLletrec(Array.mapi mkrec lf, lf_args.(start)) *)
- | Lmakeblock (prefix,(cn,u),_,args) ->
+ | Lmakeblock (prefix,(cn,_u),_,args) ->
let args = Array.map (ml_of_lam env l) args in
MLconstruct(prefix,cn,args)
| Lconstruct (prefix, (cn,u)) ->
@@ -1561,7 +1561,7 @@ let rec list_of_mp acc = function
let list_of_mp mp = list_of_mp [] mp
let string_of_kn kn =
- let (mp,dp,l) = KerName.repr kn in
+ let (mp,_dp,l) = KerName.repr kn in
let mp = list_of_mp mp in
String.concat "_" mp ^ "_" ^ string_of_label l
@@ -1987,7 +1987,7 @@ let compile_mind mb mind stack =
(MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc
in
let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in
- let add_proj proj_arg acc pb =
+ let add_proj proj_arg acc _pb =
let tbl = ob.mind_reloc_tbl in
(* Building info *)
let ci = { ci_ind = ind; ci_npar = nparams;
@@ -2053,9 +2053,9 @@ let compile_mind_deps env prefix ~interactive
let compile_deps env sigma prefix ~interactive init t =
let rec aux env lvl init t =
match kind t with
- | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind
+ | Ind ((mind,_),_u) -> compile_mind_deps env prefix ~interactive init mind
| Const c ->
- let c,u = get_alias env c in
+ let c,_u = get_alias env c in
let cb,(nameref,_) = lookup_constant_key c env in
let (_, (_, const_updates)) = init in
if is_code_loaded ~interactive nameref
@@ -2074,11 +2074,11 @@ let compile_deps env sigma prefix ~interactive init t =
let comp_stack = code@comp_stack in
let const_updates = Cmap_env.add c (nameref, name) const_updates in
comp_stack, (mind_updates, const_updates)
- | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind
+ | Construct (((mind,_),_),_u) -> compile_mind_deps env prefix ~interactive init mind
| Proj (p,c) ->
let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in
aux env lvl init c
- | Case (ci, p, c, ac) ->
+ | Case (ci, _p, _c, _ac) ->
let mind = fst ci.ci_ind in
let init = compile_mind_deps env prefix ~interactive init mind in
fold_constr_with_binders succ (aux env) lvl init t
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
index c75dde843e..054b6a2d17 100644
--- a/kernel/nativeconv.ml
+++ b/kernel/nativeconv.ml
@@ -25,9 +25,9 @@ let rec conv_val env pb lvl v1 v2 cu =
| Vfun f1, Vfun f2 ->
let v = mk_rel_accu lvl in
conv_val env CONV (lvl+1) (f1 v) (f2 v) cu
- | Vfun f1, _ ->
+ | Vfun _f1, _ ->
conv_val env CONV lvl v1 (fun x -> v2 x) cu
- | _, Vfun f2 ->
+ | _, Vfun _f2 ->
conv_val env CONV lvl (fun x -> v1 x) v2 cu
| Vaccu k1, Vaccu k2 ->
conv_accu env pb lvl k1 k2 cu
@@ -110,7 +110,7 @@ and conv_atom env pb lvl a1 a2 cu =
else
if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible
else conv_fix env lvl t1 f1 t2 f2 cu
- | Aprod(_,d1,c1), Aprod(_,d2,c2) ->
+ | Aprod(_,d1,_c1), Aprod(_,d2,_c2) ->
let cu = conv_val env CONV lvl d1 d2 cu in
let v = mk_rel_accu lvl in
conv_val env pb (lvl + 1) (d1 v) (d2 v) cu
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
index ab40c643f9..70cb8691c6 100644
--- a/kernel/nativelambda.ml
+++ b/kernel/nativelambda.ml
@@ -142,7 +142,7 @@ let rec map_lam_with_binders g f n lam =
let args' = Array.Smart.map (f n) args in
if args == args' then lam else Levar (evk, args')
-and map_uint g f n u =
+and map_uint _g f n u =
match u with
| UintVal _ -> u
| UintDigits(prefix,c,args) ->
@@ -203,7 +203,7 @@ let can_subst lam =
let can_merge_if bt bf =
match bt, bf with
- | Llam(idst,_), Llam(idsf,_) -> true
+ | Llam(_idst,_), Llam(_idsf,_) -> true
| _ -> false
let merge_if t bt bf =
@@ -370,7 +370,7 @@ module Cache =
let is_lazy env prefix t =
match kind t with
- | App (f,args) ->
+ | App (f,_args) ->
begin match kind f with
| Construct (c,_) ->
let gr = GlobRef.IndRef (fst c) in
@@ -431,7 +431,7 @@ let rec lambda_of_constr cache env sigma c =
| Sort s -> Lsort s
- | Ind (ind,u as pind) ->
+ | Ind (ind,_u as pind) ->
let prefix = get_mind_prefix env (fst ind) in
Lind (prefix, pind)
@@ -529,7 +529,7 @@ let rec lambda_of_constr cache env sigma c =
and lambda_of_app cache env sigma f args =
match kind f with
- | Const (kn,u as c) ->
+ | Const (_kn,_u as c) ->
let kn,u = get_alias env c in
let cb = lookup_constant kn env in
(try
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
index f784509b6f..b4126dd68c 100644
--- a/kernel/nativelib.ml
+++ b/kernel/nativelib.ml
@@ -40,7 +40,7 @@ let include_dirs () =
[Filename.get_temp_dir_name (); coqlib () / "kernel"; coqlib () / "library"]
(* Pointer to the function linking an ML object into coq's toplevel *)
-let load_obj = ref (fun x -> () : string -> unit)
+let load_obj = ref (fun _x -> () : string -> unit)
let rt1 = ref (dummy_value ())
let rt2 = ref (dummy_value ())
@@ -113,7 +113,7 @@ let call_compiler ?profile:(profile=false) ml_filename =
let res = CUnix.sys_command (ocamlfind ()) args in
let res = match res with
| Unix.WEXITED 0 -> true
- | Unix.WEXITED n | Unix.WSIGNALED n | Unix.WSTOPPED n ->
+ | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n ->
warn_native_compiler_failed (Inl res); false
in
res, link_filename
@@ -158,7 +158,7 @@ let call_linker ?(fatal=true) prefix f upds =
(try
if Dynlink.is_native then Dynlink.loadfile f else !load_obj f;
register_native_file prefix
- with Dynlink.Error e as exn ->
+ with Dynlink.Error _ as exn ->
let exn = CErrors.push exn in
if fatal then iraise exn
else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn));
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index f8b71e4564..303cb06c55 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -87,21 +87,21 @@ let discharge_direct_opaque ~cook_constr ci = function
| Direct (d,cu) ->
Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u))
-let join_opaque { opaque_val = prfs; opaque_dir = odp } = function
+let join_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) -> ignore(Future.join cu)
| Indirect (_,dp,i) ->
if DirPath.equal dp odp then
let fp = snd (Int.Map.find i prfs) in
ignore(Future.join fp)
-let uuid_opaque { opaque_val = prfs; opaque_dir = odp } = function
+let uuid_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) -> Some (Future.uuid cu)
| Indirect (_,dp,i) ->
if DirPath.equal dp odp
then Some (Future.uuid (snd (Int.Map.find i prfs)))
else None
-let force_proof { opaque_val = prfs; opaque_dir = odp } = function
+let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) ->
fst(Future.force cu)
| Indirect (l,dp,i) ->
@@ -112,7 +112,7 @@ let force_proof { opaque_val = prfs; opaque_dir = odp } = function
let c = Future.force pt in
force_constr (List.fold_right subst_substituted l (from_val c))
-let force_constraints { opaque_val = prfs; opaque_dir = odp } = function
+let force_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) -> snd(Future.force cu)
| Indirect (_,dp,i) ->
if DirPath.equal dp odp
@@ -121,14 +121,14 @@ let force_constraints { opaque_val = prfs; opaque_dir = odp } = function
| None -> Univ.ContextSet.empty
| Some u -> Future.force u
-let get_constraints { opaque_val = prfs; opaque_dir = odp } = function
+let get_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) -> Some(Future.chain cu snd)
| Indirect (_,dp,i) ->
if DirPath.equal dp odp
then Some(Future.chain (snd (Int.Map.find i prfs)) snd)
else !get_univ dp i
-let get_proof { opaque_val = prfs; opaque_dir = odp } = function
+let get_proof { opaque_val = prfs; opaque_dir = odp; _ } = function
| Direct (_,cu) -> Future.chain cu fst
| Indirect (l,dp,i) ->
let pt =
@@ -144,7 +144,7 @@ let a_constr = Future.from_val (mkRel 1)
let a_univ = Future.from_val Univ.ContextSet.empty
let a_discharge : cooking_info list = []
-let dump { opaque_val = otab; opaque_len = n } =
+let dump { opaque_val = otab; opaque_len = n; _ } =
let opaque_table = Array.make n a_constr in
let univ_table = Array.make n a_univ in
let disch_table = Array.make n a_discharge in
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index c701b53fe4..2abb4b485c 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -53,9 +53,9 @@ let compare_stack_shape stk1 stk2 =
| (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
| (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
| (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
- | (Zproj p1::s1, Zproj p2::s2) ->
+ | (Zproj _p1::s1, Zproj _p2::s2) ->
Int.equal bal 0 && compare_rec 0 s1 s2
- | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) ->
+ | (ZcaseT(_c1,_,_,_)::s1, ZcaseT(_c2,_,_,_)::s2) ->
Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2
| (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
@@ -261,7 +261,7 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u
s
| Declarations.Polymorphic_ind _ ->
cmp_instances u1 u2 s
- | Declarations.Cumulative_ind cumi ->
+ | Declarations.Cumulative_ind _cumi ->
let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in
if not (Int.equal num_cnstr_args nargs) then
cmp_instances u1 u2 s
@@ -296,7 +296,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
(match (z1,z2) with
| (Zlapp a1,Zlapp a2) ->
Array.fold_right2 f a1 a2 cu1
- | (Zlproj (c1,l1),Zlproj (c2,l2)) ->
+ | (Zlproj (c1,_l1),Zlproj (c2,_l2)) ->
if not (Projection.Repr.equal c1 c2) then
raise NotConvertible
else cu1
@@ -498,7 +498,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv
| None ->
match c2 with
- | FConstruct ((ind2,j2),u2) ->
+ | FConstruct ((ind2,_j2),_u2) ->
(try
let v2, v1 =
eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1)
@@ -515,7 +515,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv
| None ->
match c1 with
- | FConstruct ((ind1,j1),u1) ->
+ | FConstruct ((ind1,_j1),_u1) ->
(try let v1, v2 =
eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2)
in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
@@ -554,14 +554,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
else raise NotConvertible
(* Eta expansion of records *)
- | (FConstruct ((ind1,j1),u1), _) ->
+ | (FConstruct ((ind1,_j1),_u1), _) ->
(try
let v1, v2 =
eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2)
in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
with Not_found -> raise NotConvertible)
- | (_, FConstruct ((ind2,j2),u2)) ->
+ | (_, FConstruct ((ind2,_j2),_u2)) ->
(try
let v2, v1 =
eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1)
@@ -659,14 +659,14 @@ let check_sort_cmp_universes env pb s0 s1 univs =
| Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible
| Set, Prop -> raise NotConvertible
| Set, Type u -> check_pb Univ.type0_univ u
- | Type u, Prop -> raise NotConvertible
+ | Type _u, Prop -> raise NotConvertible
| Type u, Set -> check_pb u Univ.type0_univ
| Type u0, Type u1 -> check_pb u0 u1
let checked_sort_cmp_universes env pb s0 s1 univs =
check_sort_cmp_universes env pb s0 s1 univs; univs
-let check_convert_instances ~flex u u' univs =
+let check_convert_instances ~flex:_ u u' univs =
if UGraph.check_eq_instances univs u u' then univs
else raise NotConvertible
@@ -707,7 +707,7 @@ let infer_cmp_universes env pb s0 s1 univs =
| Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs
| Set, Prop -> raise NotConvertible
| Set, Type u -> infer_pb Univ.type0_univ u
- | Type u, Prop -> raise NotConvertible
+ | Type _u, Prop -> raise NotConvertible
| Type u, Set -> infer_pb u Univ.type0_univ
| Type u0, Type u1 -> infer_pb u0 u1
@@ -781,7 +781,7 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta
env univs t1 t2 =
infer_conv_universes CUMUL l2r evars ts env univs t1 t2
-let default_conv cv_pb ?(l2r=false) env t1 t2 =
+let default_conv cv_pb ?l2r:_ env t1 t2 =
gen_conv cv_pb env t1 t2
let default_conv_leq = default_conv CUMUL
@@ -912,7 +912,7 @@ let is_arity env c =
with NotArity -> false
let eta_expand env t ty =
- let ctxt, codom = dest_prod env ty in
+ let ctxt, _codom = dest_prod env ty in
let ctxt',t = dest_lam env t in
let d = Context.Rel.nhyps ctxt - Context.Rel.nhyps ctxt' in
let eta_args = List.rev_map mkRel (List.interval 1 d) in
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 74042f9e04..bfe68671a2 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -138,7 +138,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
let mib2 = Declareops.subst_mind_body subst2 mib2 in
let check_inductive_type cst name t1 t2 =
check_conv (NotConvertibleInductiveField name)
- cst (inductive_is_polymorphic mib1) infer_conv_leq env t1 t2
+ cst (inductive_is_polymorphic mib1) (infer_conv_leq ?l2r:None ?evars:None ?ts:None) env t1 t2
in
let check_packet cst p1 p2 =
@@ -162,10 +162,10 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
cst
in
let mind = MutInd.make1 kn1 in
- let check_cons_types i cst p1 p2 =
+ let check_cons_types _i cst p1 p2 =
Array.fold_left3
(fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst
- (inductive_is_polymorphic mib1) infer_conv env t1 t2)
+ (inductive_is_polymorphic mib1) (infer_conv ?l2r:None ?evars:None ?ts:None) env t1 t2)
cst
p2.mind_consnames
(arities_of_specif (mind, inst) (mib1, p1))
@@ -229,7 +229,7 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 =
let check_conv cst poly f = check_conv_error error cst poly f in
let check_type poly cst env t1 t2 =
let err = NotConvertibleTypeField (env, t1, t2) in
- check_conv err cst poly infer_conv_leq env t1 t2
+ check_conv err cst poly (infer_conv_leq ?l2r:None ?evars:None ?ts:None) env t1 t2
in
match info1 with
| Constant cb1 ->
@@ -268,14 +268,14 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 =
Anyway [check_conv] will handle that afterwards. *)
let c1 = Mod_subst.force_constr lc1 in
let c2 = Mod_subst.force_constr lc2 in
- check_conv NotConvertibleBodyField cst poly infer_conv env c1 c2))
- | IndType ((kn,i),mind1) ->
+ check_conv NotConvertibleBodyField cst poly (infer_conv ?l2r:None ?evars:None ?ts:None) env c1 c2))
+ | IndType ((_kn,_i),_mind1) ->
CErrors.user_err Pp.(str @@
"The kernel does not recognize yet that a parameter can be " ^
"instantiated by an inductive type. Hint: you can rename the " ^
"inductive type and give a definition to map the old name to the new " ^
"name.")
- | IndConstr (((kn,i),j),mind1) ->
+ | IndConstr (((_kn,_i),_j),_mind1) ->
CErrors.user_err Pp.(str @@
"The kernel does not recognize yet that a parameter can be " ^
"instantiated by a constructor. Hint: you can rename the " ^
diff --git a/kernel/term.ml b/kernel/term.ml
index 4851a9c0d0..795cdeb040 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -54,13 +54,13 @@ let mkProd_wo_LetIn decl c =
let open Context.Rel.Declaration in
match decl with
| LocalAssum (na,t) -> mkProd (na, t, c)
- | LocalDef (na,b,t) -> subst1 b c
+ | LocalDef (_na,b,_t) -> subst1 b c
let mkNamedProd_wo_LetIn decl c =
let open Context.Named.Declaration in
match decl with
| LocalAssum (id,t) -> mkNamedProd id t c
- | LocalDef (id,b,t) -> subst1 b (subst_var id c)
+ | LocalDef (id,b,_t) -> subst1 b (subst_var id c)
(* non-dependent product t1 -> t2 *)
let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
@@ -81,7 +81,7 @@ let mkNamedLambda_or_LetIn decl c =
(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
let prodn n env b =
let rec prodrec = function
- | (0, env, b) -> b
+ | (0, _env, b) -> b
| (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b))
| _ -> assert false
in
@@ -93,7 +93,7 @@ let compose_prod l b = prodn (List.length l) l b
(* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *)
let lamn n env b =
let rec lamrec = function
- | (0, env, b) -> b
+ | (0, _env, b) -> b
| (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b))
| _ -> assert false
in
@@ -276,7 +276,7 @@ let decompose_prod_n_assum n =
| Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
| Cast (c,_,_) -> prodec_rec l n c
- | c -> user_err (str "decompose_prod_n_assum: not enough assumptions")
+ | _ -> user_err (str "decompose_prod_n_assum: not enough assumptions")
in
prodec_rec Context.Rel.empty n
@@ -297,7 +297,7 @@ let decompose_lam_n_assum n =
| Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c
| Cast (c,_,_) -> lamdec_rec l n c
- | c -> user_err (str "decompose_lam_n_assum: not enough abstractions")
+ | _c -> user_err (str "decompose_lam_n_assum: not enough abstractions")
in
lamdec_rec Context.Rel.empty n
@@ -313,7 +313,7 @@ let decompose_lam_n_decls n =
| Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
| Cast (c,_,_) -> lamdec_rec l n c
- | c -> user_err (str "decompose_lam_n_decls: not enough abstractions")
+ | _ -> user_err (str "decompose_lam_n_decls: not enough abstractions")
in
lamdec_rec Context.Rel.empty n
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index f59e07098b..f39dde772a 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -73,7 +73,7 @@ type _ trust =
let uniq_seff_rev = SideEffects.repr
let uniq_seff l =
let ans = List.rev (SideEffects.repr l) in
- List.map_append (fun { eff } -> eff) ans
+ List.map_append (fun { eff ; _ } -> eff) ans
let empty_seff = SideEffects.empty
let add_seff mb eff effs =
@@ -122,7 +122,7 @@ let inline_side_effects env body ctx side_eff =
let subst = Cmap_env.add c (Inr var) subst in
let ctx = Univ.ContextSet.union ctx univs in
(subst, var + 1, ctx, (cname c, b, ty, opaque) :: args)
- | Polymorphic_const auctx ->
+ | Polymorphic_const _auctx ->
(** Inline the term to emulate universe polymorphism *)
let subst = Cmap_env.add c (Inl b) subst in
(subst, var, ctx, args)
@@ -250,9 +250,9 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
delay even in the polymorphic case. *)
| DefinitionEntry ({ const_entry_type = Some typ;
const_entry_opaque = true;
- const_entry_universes = Monomorphic_const_entry univs } as c) ->
+ const_entry_universes = Monomorphic_const_entry univs; _ } as c) ->
let env = push_context_set ~strict:true univs env in
- let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
+ let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in
let tyj = infer_type env typ in
let proofterm =
Future.chain body (fun ((body,uctx),side_eff) ->
@@ -288,8 +288,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
(** Other definitions have to be processed immediately. *)
| DefinitionEntry c ->
- let { const_entry_type = typ; const_entry_opaque = opaque } = c in
- let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
+ let { const_entry_type = typ; const_entry_opaque = opaque ; _ } = c in
+ let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in
let (body, ctx), side_eff = Future.join body in
let body, ctx, _ = match trust with
| Pure -> body, ctx, []
@@ -348,7 +348,7 @@ let record_aux env s_ty s_bo =
(keep_hyps env s_bo)) in
Aux_file.record_in_aux "context_used" v
-let build_constant_declaration kn env result =
+let build_constant_declaration _kn env result =
let open Cooking in
let typ = result.cook_type in
let check declared inferred =
@@ -478,7 +478,7 @@ let export_eff eff =
(eff.seff_constant, eff.seff_body, eff.seff_role)
let export_side_effects mb env c =
- let { const_entry_body = body } = c in
+ let { const_entry_body = body; _ } = c in
let _, eff = Future.force body in
let ce = { c with
const_entry_body = Future.chain body
@@ -493,7 +493,7 @@ let export_side_effects mb env c =
let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in
let trusted = check_signatures mb signatures in
let push_seff env eff =
- let { seff_constant = kn; seff_body = cb } = eff in
+ let { seff_constant = kn; seff_body = cb ; _ } = eff in
let env = Environ.add_constant kn cb env in
match cb.const_universes with
| Polymorphic_const _ -> env
@@ -511,7 +511,7 @@ let export_side_effects mb env c =
if Int.equal sl 0 then
let env, cbs =
List.fold_left (fun (env,cbs) eff ->
- let { seff_constant = kn; seff_body = ocb; seff_env = u } = eff in
+ let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in
let ce = constant_entry_of_side_effect ocb u in
let cb = translate_constant Pure env kn ce in
let eff = { eff with
@@ -543,7 +543,7 @@ let translate_recipe env kn r =
let hcons = DirPath.is_empty dir in
build_constant_declaration kn env (Cooking.cook_constant ~hcons r)
-let translate_local_def env id centry =
+let translate_local_def env _id centry =
let open Cooking in
let body = Future.from_val ((centry.secdef_body, Univ.ContextSet.empty), ()) in
let centry = {
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 25c1cbff3a..7456ecea56 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -118,14 +118,14 @@ let check_hyps_inclusion env f c sign =
(* Type of constants *)
-let type_of_constant env (kn,u as cst) =
+let type_of_constant env (kn,_u as cst) =
let cb = lookup_constant kn env in
let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
let ty, cu = constant_type env cst in
let () = check_constraints cu env in
ty
-let type_of_constant_in env (kn,u as cst) =
+let type_of_constant_in env (kn,_u as cst) =
let cb = lookup_constant kn env in
let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
constant_type_in env cst
@@ -142,7 +142,7 @@ let type_of_constant_in env (kn,u as cst) =
and no upper constraint exists on the sort $s$, we don't need to compute $s$
*)
-let type_of_abstraction env name var ty =
+let type_of_abstraction _env name var ty =
mkProd (name, var, ty)
(* Type of an application. *)
@@ -204,7 +204,7 @@ let sort_of_product env domsort rangsort =
where j.uj_type is convertible to a sort s2
*)
-let type_of_product env name s1 s2 =
+let type_of_product env _name s1 s2 =
let s = sort_of_product env s1 s2 in
mkSort s
@@ -247,7 +247,7 @@ let check_cast env c ct k expected_type =
dynamic constraints of the form u<=v are enforced *)
let type_of_inductive_knowing_parameters env (ind,u as indu) args =
- let (mib,mip) as spec = lookup_mind_specif env ind in
+ let (mib,_mip) as spec = lookup_mind_specif env ind in
check_hyps_inclusion env mkIndU indu mib.mind_hyps;
let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters
env (spec,u) args
@@ -264,7 +264,7 @@ let type_of_inductive env (ind,u as indu) =
(* Constructors. *)
-let type_of_constructor env (c,u as cu) =
+let type_of_constructor env (c,_u as cu) =
let () =
let ((kn,_),_) = c in
let mib = lookup_mind kn env in
@@ -285,7 +285,7 @@ let check_branch_types env (ind,u) c ct lft explft =
| Invalid_argument _ ->
error_number_branches env (make_judge c ct) (Array.length explft)
-let type_of_case env ci p pt c ct lf lft =
+let type_of_case env ci p pt c ct _lf lft =
let (pind, _ as indspec) =
try find_rectype env ct
with Not_found -> error_case_not_inductive env (make_judge c ct) in
@@ -399,7 +399,7 @@ let rec execute env cstr =
let lft = execute_array env lf in
type_of_case env ci p pt c ct lf lft
- | Fix ((vn,i as vni),recdef) ->
+ | Fix ((_vn,i as vni),recdef) ->
let (fix_ty,recdef') = execute_recdef env recdef i in
let fix = (vni,recdef') in
check_fix env fix; fix_ty
@@ -432,12 +432,12 @@ and execute_array env = Array.map (execute env)
(* Derived functions *)
-let universe_levels_of_constr env c =
+let universe_levels_of_constr _env c =
let rec aux s c =
match kind c with
- | Const (c, u) ->
+ | Const (_c, u) ->
LSet.fold LSet.add (Instance.levels u) s
- | Ind ((mind,_), u) | Construct (((mind,_),_), u) ->
+ | Ind ((_mind,_), u) | Construct (((_mind,_),_), u) ->
LSet.fold LSet.add (Instance.levels u) s
| Sort u when not (Sorts.is_small u) ->
let u = Sorts.univ_of_sort u in
@@ -530,7 +530,7 @@ let judge_of_product env x varj outj =
make_judge (mkProd (x, varj.utj_val, outj.utj_val))
(mkSort (sort_of_product env varj.utj_type outj.utj_type))
-let judge_of_letin env name defj typj j =
+let judge_of_letin _env name defj typj j =
make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val))
(subst1 defj.uj_val j.uj_type)
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
index 95d71965df..9ff51fca55 100644
--- a/kernel/uGraph.ml
+++ b/kernel/uGraph.ml
@@ -194,7 +194,7 @@ let check_universes_invariants g =
UMap.iter (fun l u ->
match u with
| Canonical u ->
- UMap.iter (fun v strict ->
+ UMap.iter (fun v _strict ->
incr n_edges;
let v = repr g v in
assert (topo_compare u v = -1);
@@ -435,7 +435,7 @@ let reorder g u v =
| n0::q0 ->
(* Computing new root. *)
let root, rank_rest =
- List.fold_left (fun ((best, rank_rest) as acc) n ->
+ List.fold_left (fun ((best, _rank_rest) as acc) n ->
if n.rank >= best.rank then n, best.rank else acc)
(n0, min_int) q0
in
@@ -809,7 +809,7 @@ let normalize_universes g =
in
UMap.fold (fun _ u g ->
match u with
- | Equiv u -> g
+ | Equiv _u -> g
| Canonical u ->
let _, u, g = get_ltle g u in
let _, _, g = get_gtge g u in
@@ -821,7 +821,7 @@ let constraints_of_universes g =
let uf = UF.create () in
let constraints_of u v acc =
match v with
- | Canonical {univ=u; ltle} ->
+ | Canonical {univ=u; ltle; _} ->
UMap.fold (fun v strict acc->
let typ = if strict then Lt else Le in
Constraint.add (u,typ,v) acc) ltle acc
@@ -943,7 +943,7 @@ let check_eq_instances g t1 t2 =
(** Pretty-printing *)
let pr_arc prl = function
- | _, Canonical {univ=u; ltle} ->
+ | _, Canonical {univ=u; ltle; _} ->
if UMap.is_empty ltle then mt ()
else
prl u ++ str " " ++
@@ -963,7 +963,7 @@ let pr_universes prl g =
let dump_universes output g =
let dump_arc u = function
- | Canonical {univ=u; ltle} ->
+ | Canonical {univ=u; ltle; _} ->
let u_str = Level.to_string u in
UMap.iter (fun v strict ->
let typ = if strict then Lt else Le in
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 311477daca..747a901f45 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -86,7 +86,7 @@ struct
| Level (n,d) as x ->
let d' = Names.DirPath.hcons d in
if d' == d then x else Level (n,d')
- | Var n as x -> x
+ | Var _n as x -> x
open Hashset.Combine
@@ -206,13 +206,13 @@ module LMap = struct
include M
let union l r =
- merge (fun k l r ->
+ merge (fun _k l r ->
match l, r with
| Some _, _ -> l
| _, _ -> r) l r
let subst_union l r =
- merge (fun k l r ->
+ merge (fun _k l r ->
match l, r with
| Some (Some _), _ -> l
| Some None, None -> l
@@ -365,14 +365,14 @@ struct
else f v ++ str"+" ++ int n
let is_level = function
- | (v, 0) -> true
+ | (_v, 0) -> true
| _ -> false
let level = function
| (v,0) -> Some v
| _ -> None
- let get_level (v,n) = v
+ let get_level (v,_n) = v
let map f (v, n as x) =
let v' = f v in
@@ -582,7 +582,7 @@ struct
prl u2 ++ fnl () ) c (str "")
let universes_of c =
- fold (fun (u1, op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty
+ fold (fun (u1, _op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty
end
let universes_of_constraints = Constraint.universes_of
@@ -907,7 +907,7 @@ let subst_instance_constraints s csts =
type universe_instance = Instance.t
type 'a puniverses = 'a * Instance.t
-let out_punivs (x, y) = x
+let out_punivs (x, _y) = x
let in_punivs x = (x, Instance.empty)
let eq_puniverses f (x, u) (y, u') =
f x y && Instance.equal u u'
@@ -932,8 +932,8 @@ struct
let hcons (univs, cst) =
(Instance.hcons univs, hcons_constraints cst)
- let instance (univs, cst) = univs
- let constraints (univs, cst) = cst
+ let instance (univs, _cst) = univs
+ let constraints (_univs, cst) = cst
let union (univs, cst) (univs', cst') =
Instance.append univs univs', Constraint.union cst cst'
@@ -952,7 +952,7 @@ struct
include UContext
let repr (inst, cst) =
- (Array.mapi (fun i l -> Level.var i) inst, cst)
+ (Array.mapi (fun i _l -> Level.var i) inst, cst)
let instantiate inst (u, cst) =
assert (Array.length u = Array.length inst);
@@ -988,8 +988,8 @@ struct
let hcons (univs, variance) = (* should variance be hconsed? *)
(UContext.hcons univs, variance)
- let univ_context (univs, subtypcst) = univs
- let variance (univs, variance) = variance
+ let univ_context (univs, _subtypcst) = univs
+ let variance (_univs, variance) = variance
(** This function takes a universe context representing constraints
of an inductive and produces a CumulativityInfo.t with the
@@ -1066,8 +1066,8 @@ struct
if is_empty ctx then mt() else
h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst))
- let constraints (univs, cst) = cst
- let levels (univs, cst) = univs
+ let constraints (_univs, cst) = cst
+ let levels (univs, _cst) = univs
let size (univs,_) = LSet.cardinal univs
end
@@ -1155,7 +1155,7 @@ let make_inverse_instance_subst i =
LMap.empty arr
let make_abstract_instance (ctx, _) =
- Array.mapi (fun i l -> Level.var i) ctx
+ Array.mapi (fun i _l -> Level.var i) ctx
let abstract_universes ctx =
let instance = UContext.instance ctx in
diff --git a/kernel/vars.ml b/kernel/vars.ml
index 0f588a6302..9d5d79124b 100644
--- a/kernel/vars.ml
+++ b/kernel/vars.ml
@@ -66,7 +66,7 @@ let isMeta c = match Constr.kind c with
let noccur_with_meta n m term =
let rec occur_rec n c = match Constr.kind c with
| Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur
- | Constr.App(f,cl) ->
+ | Constr.App(f,_cl) ->
(match Constr.kind f with
| Constr.Cast (c,_,_) when isMeta c -> ()
| Constr.Meta _ -> ()
@@ -188,7 +188,7 @@ let adjust_rel_to_rel_context sign n =
let open RelDecl in
match sign with
| LocalAssum _ :: sign' -> let (n',p) = aux sign' in (n'+1,p)
- | LocalDef (_,c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p)
+ | LocalDef (_,_c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p)
| [] -> (0,n)
in snd (aux sign)
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index d19bea5199..5965853e1e 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -11,7 +11,7 @@ open Csymtable
let compare_zipper z1 z2 =
match z1, z2 with
| Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2)
- | Zfix(f1,args1), Zfix(f2,args2) -> Int.equal (nargs args1) (nargs args2)
+ | Zfix(_f1,args1), Zfix(_f2,args2) -> Int.equal (nargs args1) (nargs args2)
| Zswitch _, Zswitch _ | Zproj _, Zproj _ -> true
| Zapp _ , _ | Zfix _, _ | Zswitch _, _ | Zproj _, _ -> false
@@ -84,7 +84,7 @@ and conv_whd env pb k whd1 whd2 cu =
and conv_atom env pb k a1 stk1 a2 stk2 cu =
(* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *)
match a1, a2 with
- | Aind ((mi,i) as ind1) , Aind ind2 ->
+ | Aind ((mi,_i) as ind1) , Aind ind2 ->
if eq_ind ind1 ind2 && compare_stack stk1 stk2 then
if Environ.polymorphic_ind ind1 env then
let mib = Environ.lookup_mind mi env in
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 9917e94a35..eaf64ba4af 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -187,5 +187,5 @@ let apply_whd k whd =
interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0
| Vatom_stk(a,stk) ->
apply_stack (val_of_atom a) stk v
- | Vuniv_level lvl -> assert false
+ | Vuniv_level _lvl -> assert false
diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml
index 8edd49f77f..217ef4b8e5 100644
--- a/kernel/vmvalues.ml
+++ b/kernel/vmvalues.ml
@@ -100,7 +100,7 @@ let eq_structured_constant c1 c2 = match c1, c2 with
| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2
| Const_univ_level _ , _ -> false
| Const_val v1, Const_val v2 -> eq_structured_values v1 v2
-| Const_val v1, _ -> false
+| Const_val _v1, _ -> false
let hash_structured_constant c =
let open Hashset.Combine in
@@ -245,7 +245,7 @@ type id_key =
| RelKey of Int.t
| EvarKey of Evar.t
-let eq_id_key k1 k2 = match k1, k2 with
+let eq_id_key (k1 : id_key) (k2 : id_key) = match k1, k2 with
| ConstKey c1, ConstKey c2 -> Constant.equal c1 c2
| VarKey id1, VarKey id2 -> Id.equal id1 id2
| RelKey n1, RelKey n2 -> Int.equal n1 n2
@@ -304,9 +304,9 @@ let uni_lvl_val (v : values) : Univ.Level.t =
| Vfun _ -> str "Vfun"
| Vfix _ -> str "Vfix"
| Vcofix _ -> str "Vcofix"
- | Vconstr_const i -> str "Vconstr_const"
- | Vconstr_block b -> str "Vconstr_block"
- | Vatom_stk (a,stk) -> str "Vatom_stk"
+ | Vconstr_const _i -> str "Vconstr_const"
+ | Vconstr_block _b -> str "Vconstr_block"
+ | Vatom_stk (_a,_stk) -> str "Vatom_stk"
| _ -> assert false
in
CErrors.anomaly
@@ -444,7 +444,7 @@ struct
type t = id_key
let equal = eq_id_key
open Hashset.Combine
- let hash = function
+ let hash : t -> tag = function
| ConstKey c -> combinesmall 1 (Constant.hash c)
| VarKey id -> combinesmall 2 (Id.hash id)
| RelKey i -> combinesmall 3 (Int.hash i)
@@ -658,7 +658,7 @@ and pr_whd w =
| Vfix _ -> str "Vfix"
| Vcofix _ -> str "Vcofix"
| Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")"
- | Vconstr_block b -> str "Vconstr_block"
+ | Vconstr_block _b -> str "Vconstr_block"
| Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")"
| Vuniv_level _ -> assert false)
and pr_stack stk =
@@ -668,6 +668,6 @@ and pr_stack stk =
and pr_zipper z =
Pp.(match z with
| Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")"
- | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")"
- | Zswitch s -> str "Zswitch(...)"
+ | Zfix (_f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")"
+ | Zswitch _s -> str "Zswitch(...)"
| Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")")