From 0aa2544d04dbd4b6ee665b551ed165e4fb02d2fa Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 15 Jul 2015 10:36:12 +0200 Subject: Imported Upstream version 8.5~beta2+dfsg --- kernel/indtypes.ml | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'kernel/indtypes.ml') diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 99d9f52c..6b909824 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -164,10 +164,12 @@ let infer_constructor_packet env_ar_par ctx params lc = (* If indices matter *) let cumulate_arity_large_levels env sign = fst (List.fold_right - (fun (_,_,t as d) (lev,env) -> - let tj = infer_type env t in - let u = univ_of_sort tj.utj_type in - (Universe.sup u lev, push_rel d env)) + (fun (_,b,t as d) (lev,env) -> + if Option.is_empty b then + let tj = infer_type env t in + let u = univ_of_sort tj.utj_type in + (Universe.sup u lev, push_rel d env) + else lev, push_rel d env) sign (Universe.type0m,env)) let is_impredicative env u = @@ -344,7 +346,7 @@ let typecheck_inductive env mie = in (id,cn,lc,(sign,arity))) inds - in (env_arities, params, inds) + in (env_arities, env_ar_par, params, inds) (************************************************************************) (************************************************************************) @@ -364,9 +366,8 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env0 nbpar c nargs err = +let explain_ind_err id ntyp env nbpar c nargs err = let (lpar,c') = mind_extract_params nbpar c in - let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) @@ -484,6 +485,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in + let largs = List.map (whd_betadeltaiota env) largs in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv hyps nmr largs @@ -654,7 +656,6 @@ let used_section_variables env inds = keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) -let rel_appvect n m = rel_vect n (List.length m) exception UndefinableExpansion @@ -821,9 +822,9 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, params, inds) = typecheck_inductive env mie in + let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity kn env_ar params inds in + let (nmr,recargs) = check_positivity kn env_ar_par params inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes -- cgit v1.2.3